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

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

db4
Joe Groff 2009-03-07 11:57:40 -06:00
parent 78dd25c5b9 2cd0ebb98d
commit 32223de89c
396 changed files with 527 additions and 7349 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

30
basis/compiler/tests/redefine1.factor
View File

@ -1,24 +1,42 @@
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
definitions arrays words assocs eval ;
definitions arrays words assocs eval strings ;
IN: compiler.tests
GENERIC: method-redefine-test ( a -- b )
GENERIC: method-redefine-generic-1 ( a -- b )
M: integer method-redefine-test 3 + ;
M: integer method-redefine-generic-1 3 + ;
: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
: method-redefine-test-1 ( -- b ) 3 method-redefine-generic-1 ;
[ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test
[ ] [ [ fixnum \ method-redefine-generic-1 method forget ] with-compilation-unit ] unit-test
[ 6 ] [ method-redefine-test-1 ] unit-test
GENERIC: method-redefine-generic-2 ( a -- b )
M: integer method-redefine-generic-2 3 + ;
: method-redefine-test-2 ( -- b ) 3 method-redefine-generic-2 ;
[ 6 ] [ method-redefine-test-2 ] unit-test
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test
[ ] [
[
fixnum string [ \ method-redefine-generic-2 method forget ] bi@
] with-compilation-unit
] unit-test
! Test ripple-up behavior
: hey ( -- ) ;
: there ( -- ) hey ;

19
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -17,8 +17,10 @@ IN: compiler.tree.propagation.inlining
! we are more eager to inline
SYMBOL: node-count
: count-nodes ( nodes -- )
0 swap [ drop 1+ ] each-node node-count set ;
: count-nodes ( nodes -- n )
0 swap [ drop 1+ ] each-node ;
: compute-node-count ( nodes -- ) count-nodes node-count set ;
! We try not to inline the same word too many times, to avoid
! combinatorial explosion
@ -33,9 +35,6 @@ M: word splicing-nodes
M: callable splicing-nodes
build-sub-tree analyze-recursive normalize ;
: propagate-body ( #call -- )
body>> (propagate) ;
! Dispatch elimination
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
@ -44,7 +43,7 @@ M: callable splicing-nodes
2dup splicing-nodes
[ >>method ] [ >>body ] bi*
] if
propagate-body t
body>> (propagate) t
] [ 2drop f >>method f >>body f >>class drop f ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
@ -161,10 +160,10 @@ SYMBOL: history
: inline-word-def ( #call word quot -- ? )
over history get memq? [ 3drop f ] [
[
swap remember-inlining
dupd splicing-nodes >>body
propagate-body
] with-scope
[ remember-inlining ] dip
[ drop ] [ splicing-nodes ] 2bi
[ >>body drop ] [ count-nodes ] [ (propagate) ] tri
] with-scope node-count +@
t
] if ;

2
basis/compiler/tree/propagation/propagation.factor
View File

@ -20,5 +20,5 @@ IN: compiler.tree.propagation
H{ } clone 1array value-infos set
H{ } clone 1array constraints set
H{ } clone inlining-count set
dup count-nodes
dup compute-node-count
dup (propagate) ;

0
extra/rewrite-closures/tags.txt → basis/constructors/tags.txt
View File

12
basis/delegate/delegate-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.syntax help.markup ;
USING: help.syntax help.markup delegate.private ;
IN: delegate
HELP: define-protocol
@ -8,7 +8,7 @@ HELP: define-protocol
HELP: PROTOCOL:
{ $syntax "PROTOCOL: protocol-name words... ;" }
{ $description "Defines an explicit protocol, which can be used as a basis for delegation or mimicry." } ;
{ $description "Defines an explicit protocol, which can be used as a basis for delegation." } ;
{ define-protocol POSTPONE: PROTOCOL: } related-words
@ -22,6 +22,12 @@ HELP: CONSULT:
{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } }
{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ;
HELP: SLOT-PROTOCOL:
{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ;
{ define-protocol POSTPONE: PROTOCOL: } related-words
{ define-consult POSTPONE: CONSULT: } related-words
HELP: group-words
@ -40,6 +46,8 @@ $nl
"Defining new protocols:"
{ $subsection POSTPONE: PROTOCOL: }
{ $subsection define-protocol }
"Defining new protocols consisting of slot accessors:"
{ $subsection POSTPONE: SLOT-PROTOCOL: }
"Defining consultation:"
{ $subsection POSTPONE: CONSULT: }
{ $subsection define-consult }

63
basis/delegate/delegate-tests.factor
View File

@ -1,6 +1,7 @@
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
accessors eval multiline ;
accessors eval multiline generic.standard delegate.protocols
delegate.private assocs ;
IN: delegate.tests
TUPLE: hello this that ;
@ -35,7 +36,7 @@ M: hello bing hello-test ;
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test
[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
@ -112,6 +113,7 @@ PROTOCOL: silly-protocol do-me ;
[ ] [ T{ a-tuple } do-me ] unit-test
! Change method definition to consultation
[ [ ] ] [
<" IN: delegate.tests
USE: kernel
@ -119,13 +121,22 @@ PROTOCOL: silly-protocol do-me ;
CONSULT: silly-protocol a-tuple drop f ; "> <string-reader> "delegate-test" parse-stream
] unit-test
! Method should be there
[ ] [ T{ a-tuple } do-me ] unit-test
! Now try removing the consulation
[ [ ] ] [
<" IN: delegate.tests "> <string-reader> "delegate-test" parse-stream
] unit-test
! Method should be gone
[ T{ a-tuple } do-me ] [ no-method? ] must-fail-with
! A slot protocol issue
DEFER: slot-protocol-test-3
SLOT: y
[ f ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ [ ] ] [
<" IN: delegate.tests
@ -135,7 +146,7 @@ CONSULT: y>> slot-protocol-test-3 x>> ;">
<string-reader> "delegate-test-1" parse-stream
] unit-test
[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
[ [ ] ] [
<" IN: delegate.tests
@ -143,4 +154,46 @@ TUPLE: slot-protocol-test-3 x y ;">
<string-reader> "delegate-test-1" parse-stream
] unit-test
[ t ] [ \ y>> \ slot-protocol-test-3 method >boolean ] unit-test
! We now have a real accessor for the y slot; we don't want it to
! get lost
[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
! We want to be able to override methods after consultation
[ [ ] ] [
<" IN: delegate.tests
USING: delegate kernel sequences delegate.protocols accessors ;
TUPLE: override-method-test seq ;
CONSULT: sequence-protocol override-method-test seq>> ;
M: override-method-test like drop ; ">
<string-reader> "delegate-test-2" parse-stream
] unit-test
DEFER: seq-delegate
! See if removing a consultation updates protocol-consult word prop
[ [ ] ] [
<" IN: delegate.tests
USING: accessors delegate delegate.protocols ;
TUPLE: seq-delegate seq ;
CONSULT: sequence-protocol seq-delegate seq>> ;">
<string-reader> "remove-consult-test" parse-stream
] unit-test
[ t ] [
seq-delegate
sequence-protocol \ protocol-consult word-prop
key?
] unit-test
[ [ ] ] [
<" IN: delegate.tests
USING: delegate delegate.protocols ;
TUPLE: seq-delegate seq ;">
<string-reader> "remove-consult-test" parse-stream
] unit-test
[ f ] [
seq-delegate
sequence-protocol \ protocol-consult word-prop
key?
] unit-test

87
basis/delegate/delegate.factor
View File

@ -2,10 +2,13 @@
! Portions copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes.tuple definitions generic
generic.standard hashtables kernel lexer make math parser
generic.parser sequences sets slots words words.symbol fry ;
generic.standard hashtables kernel lexer math parser
generic.parser sequences sets slots words words.symbol fry
compiler.units ;
IN: delegate
<PRIVATE
: protocol-words ( protocol -- words )
\ protocol-words word-prop ;
@ -27,27 +30,74 @@ M: tuple-class group-words
! Consultation
: consult-method ( word class quot -- )
[ drop swap first create-method-in ]
[ nip [ swap [ second [ [ dip ] curry ] times % ] [ first , ] bi ] [ ] make ] 3bi
TUPLE: consultation group class quot loc ;
: <consultation> ( group class quot -- consultation )
f consultation boa ;
: create-consult-method ( word consultation -- method )
[ class>> swap first create-method dup fake-definition ] keep
[ drop ] [ "consultation" set-word-prop ] 2bi ;
PREDICATE: consult-method < method-body "consultation" word-prop ;
M: consult-method reset-word
[ call-next-method ] [ f "consultation" set-word-prop ] bi ;
: consult-method-quot ( quot word -- object )
[ second [ [ dip ] curry ] times ] [ first ] bi
'[ _ call _ execute ] ;
: consult-method ( word consultation -- )
[ create-consult-method ]
[ quot>> swap consult-method-quot ] 2bi
define ;
: change-word-prop ( word prop quot -- )
[ swap props>> ] dip change-at ; inline
: register-protocol ( group class quot -- )
[ \ protocol-consult ] 2dip
'[ [ _ _ swap ] dip ?set-at ] change-word-prop ;
: each-generic ( consultation quot -- )
[ [ group>> group-words ] keep ] dip curry each ; inline
: define-consult ( group class quot -- )
[ register-protocol ]
[ [ group-words ] 2dip '[ _ _ consult-method ] each ]
3bi ;
: register-consult ( consultation -- )
[ group>> \ protocol-consult ] [ ] [ class>> ] tri
'[ [ _ _ ] dip ?set-at ] change-word-prop ;
: consult-methods ( consultation -- )
[ consult-method ] each-generic ;
: unregister-consult ( consultation -- )
[ class>> ] [ group>> ] bi
\ protocol-consult word-prop delete-at ;
: unconsult-method ( word consultation -- )
[ class>> swap first method ] keep
over [
over "consultation" word-prop eq?
[ forget ] [ drop ] if
] [ 2drop ] if ;
: unconsult-methods ( consultation -- )
[ unconsult-method ] each-generic ;
PRIVATE>
: define-consult ( consultation -- )
[ register-consult ] [ consult-methods ] bi ;
: CONSULT:
scan-word scan-word parse-definition define-consult ; parsing
scan-word scan-word parse-definition <consultation>
[ save-location ] [ define-consult ] bi ; parsing
M: consultation where loc>> ;
M: consultation set-where (>>loc) ;
M: consultation forget*
[ unconsult-methods ] [ unregister-consult ] bi ;
! Protocols
<PRIVATE
: cross-2each ( seq1 seq2 quot -- )
[ with each ] 2curry each ; inline
@ -69,8 +119,8 @@ M: tuple-class group-words
swap protocol-words diff ;
: add-new-definitions ( protocol wordlist -- )
[ drop protocol-consult >alist ] [ added-words ] 2bi
[ swap first2 consult-method ] cross-2each ;
[ drop protocol-consult values ] [ added-words ] 2bi
[ swap consult-method ] cross-2each ;
: initialize-protocol-props ( protocol wordlist -- )
[
@ -81,6 +131,11 @@ M: tuple-class group-words
: fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ;
: show-words ( wordlist' -- wordlist )
[ dup second zero? [ first ] when ] map ;
PRIVATE>
: define-protocol ( protocol wordlist -- )
[ drop define-symbol ] [
fill-in-depth
@ -97,8 +152,6 @@ PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
M: protocol forget*
[ f forget-old-definitions ] [ call-next-method ] bi ;
: show-words ( wordlist' -- wordlist )
[ dup second zero? [ first ] when ] map ;
M: protocol definition protocol-words show-words ;

0
unmaintained/bitfields/tags.txt → basis/delegate/tags.txt
View File

2
basis/fry/fry.factor
View File

@ -53,4 +53,4 @@ M: callable deep-fry
M: object deep-fry , ;
: '[ \ ] parse-until fry over push-all ; parsing
: '[ parse-quotation fry over push-all ; parsing

17
basis/functors/functors.factor
View File

@ -122,20 +122,13 @@ DEFER: ;FUNCTOR delimiter
functor-words use get delq ;
: parse-functor-body ( -- form )
t in-lambda? [
V{ } clone
push-functor-words
"WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda)
<let*> parsed-lambda
pop-functor-words
>quotation
] with-variable ;
push-functor-words
"WHERE" parse-bindings*
[ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) <let*> 1quotation
pop-functor-words ;
: (FUNCTOR:) ( -- word def )
CREATE
parse-locals dup push-locals
parse-functor-body swap pop-locals <lambda>
rewrite-closures first ;
CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
PRIVATE>

10
basis/io/streams/byte-array/byte-array.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays byte-vectors kernel io.encodings io.streams.string
sequences io namespaces io.encodings.private accessors sequences.private
io.streams.sequence destructors ;
io.streams.sequence destructors math combinators ;
IN: io.streams.byte-array
: <byte-writer> ( encoding -- stream )
@ -20,6 +20,14 @@ M: byte-reader stream-read1 sequence-read1 ;
M: byte-reader stream-read-until sequence-read-until ;
M: byte-reader dispose drop ;
M: byte-reader stream-seek ( n seek-type stream -- )
swap {
{ seek-absolute [ (>>i) ] }
{ seek-relative [ [ + ] change-i drop ] }
{ seek-end [ dup underlying>> length >>i [ + ] change-i drop ] }
[ bad-seek-type ]
} case ;
: <byte-reader> ( byte-array encoding -- stream )
[ B{ } like 0 byte-reader boa ] dip <decoder> ;

10
basis/locals/errors/errors.factor
View File

@ -29,12 +29,12 @@ ERROR: :>-outside-lambda-error ;
M: :>-outside-lambda-error summary
drop ":> cannot be used outside of lambda expressions" ;
ERROR: bad-lambda-rewrite output ;
M: bad-lambda-rewrite summary
drop "You have found a bug in locals. Please report." ;
ERROR: bad-local args obj ;
M: bad-local summary
drop "You have found a bug in locals. Please report." ;
ERROR: bad-rewrite args obj ;
M: bad-rewrite summary
drop "You have found a bug in locals. Please report." ;

19
basis/locals/locals-docs.factor
View File

@ -134,19 +134,30 @@ $nl
"ordinary-word-test ordinary-word-test eq? ."
"t"
}
"In a word with locals, literals expand into code which constructs the literal, and so every invocation pushes a new object:"
"In a word with locals, literals which do not contain locals still behave in the same way:"
{ $example
"USE: locals"
"IN: scratchpad"
"TUPLE: person first-name last-name ;"
":: ordinary-word-test ( -- tuple )"
":: locals-word-test ( -- tuple )"
" T{ person { first-name \"Alan\" } { last-name \"Kay\" } } ;"
"ordinary-word-test ordinary-word-test eq? ."
"locals-word-test locals-word-test eq? ."
"t"
}
"However, literals with locals in them actually expand into code for constructing a new object:"
{ $example
"USING: locals splitting ;"
"IN: scratchpad"
"TUPLE: person first-name last-name ;"
":: constructor-test ( -- tuple )"
" \"Jane Smith\" \" \" split1 :> last :> first"
" T{ person { first-name first } { last-name last } } ;"
"constructor-test constructor-test eq? ."
"f"
}
"One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
{ $heading "Example" }
"For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
"Here is an implementation of the " { $link 3array } " word which uses this feature:"
{ $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
ARTICLE: "locals-mutable" "Mutable locals"

34
basis/locals/locals-tests.factor
View File

@ -357,12 +357,12 @@ ERROR: punned-class x ;
[ T{ punned-class f 3 } ] [ 3 [| a | T{ punned-class f a } ] call ] unit-test
:: literal-identity-test ( -- a b )
{ } V{ } ;
{ 1 } V{ } ;
[ t f ] [
[ t t ] [
literal-identity-test
literal-identity-test
swapd [ eq? ] [ eq? ] 2bi*
[ eq? ] [ eq? ] bi-curry* bi*
] unit-test
:: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ;
@ -401,9 +401,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
[
"USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
eval call
] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
: funny-macro-test ( n -- ? ) [ odd? ] (funny-macro-test) ;
@ -492,7 +493,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
] unit-test
! Discovered by littledan
! littledan found this problem
[ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
@ -503,8 +504,25 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test
! erg found this problem
:: erg's-:>-bug ( n ? -- n ) [ n :> n n ] [ n :> b b ] if ;
:: erg's-:>-bug ( n ? -- n ) ? [ n :> n n ] [ n :> b b ] if ;
[ 3 ] [ 3 f erg's-:>-bug ] unit-test
[ 3 ] [ 3 t erg's-:>-bug ] unit-test
[ 3 ] [ 3 t erg's-:>-bug ] unit-test
:: erg's-:>-bug-2 ( n ? -- n ) ? n '[ _ :> n n ] [ n :> b b ] if ;
[ 3 ] [ 3 f erg's-:>-bug-2 ] unit-test
[ 3 ] [ 3 t erg's-:>-bug-2 ] unit-test
! dharmatech found this problem
GENERIC: ed's-bug ( a -- b )
M: string ed's-bug reverse ;
M: integer ed's-bug neg ;
:: ed's-test-case ( a -- b )
{ [ a ed's-bug ] } && ;
[ t ] [ \ ed's-test-case optimized>> ] unit-test

16
basis/locals/locals.factor
View File

@ -9,19 +9,13 @@ IN: locals
scan locals get [ :>-outside-lambda-error ] unless*
[ make-local ] bind <def> parsed ; parsing
: [| parse-lambda parsed-lambda ; parsing
: [| parse-lambda over push-all ; parsing
: [let
"|" expect "|" parse-bindings
\ ] (parse-lambda) <let> parsed-lambda ; parsing
: [let parse-let over push-all ; parsing
: [let*
"|" expect "|" parse-bindings*
\ ] (parse-lambda) <let*> parsed-lambda ; parsing
: [let* parse-let* over push-all ; parsing
: [wlet
"|" expect "|" parse-wbindings
\ ] (parse-lambda) <wlet> parsed-lambda ; parsing
: [wlet parse-wlet over push-all ; parsing
: :: (::) define ; parsing
@ -31,6 +25,8 @@ IN: locals
: MEMO:: (::) define-memoized ; parsing
USE: syntax
{
"locals.macros"
"locals.fry"

66
basis/locals/parser/parser.factor
View File

@ -6,6 +6,11 @@ locals.rewrite.closures locals.types make namespaces parser
quotations sequences splitting words vocabs.parser ;
IN: locals.parser
SYMBOL: in-lambda?
: ?rewrite-closures ( form -- form' )
in-lambda? get [ 1array ] [ rewrite-closures ] if ;
: make-local ( name -- word )
"!" ?tail [
<local-reader>
@ -20,28 +25,33 @@ IN: locals.parser
[ <local-word> [ dup name>> set ] [ ] [ ] tri ] dip
"local-word-def" set-word-prop ;
SYMBOL: locals
: push-locals ( assoc -- )
use get push ;
: pop-locals ( assoc -- )
use get delete ;
use get delq ;
SYMBOL: in-lambda?
SINGLETON: lambda-parser
: (parse-lambda) ( assoc end -- quot )
[
SYMBOL: locals
: ((parse-lambda)) ( assoc quot -- quot' )
'[
in-lambda? on
over locals set
over push-locals
parse-until >quotation
swap pop-locals
] with-scope ;
lambda-parser quotation-parser set
[ locals set ] [ push-locals @ ] [ pop-locals ] tri
] with-scope ; inline
: (parse-lambda) ( assoc -- quot )
[ \ ] parse-until >quotation ] ((parse-lambda)) ;
: parse-lambda ( -- lambda )
"|" parse-tokens make-locals
\ ] (parse-lambda) <lambda> ;
(parse-lambda) <lambda>
?rewrite-closures ;
M: lambda-parser parse-quotation ( -- quotation )
H{ } clone (parse-lambda) ;
: parse-binding ( end -- pair/f )
scan {
@ -65,6 +75,10 @@ SYMBOL: in-lambda?
: parse-bindings ( end -- bindings vars )
[ (parse-bindings) ] with-bindings ;
: parse-let ( -- form )
"|" expect "|" parse-bindings
(parse-lambda) <let> ?rewrite-closures ;
: parse-bindings* ( end -- words assoc )
[
namespace push-locals
@ -72,6 +86,10 @@ SYMBOL: in-lambda?
namespace pop-locals
] with-bindings ;
: parse-let* ( -- form )
"|" expect "|" parse-bindings*
(parse-lambda) <let*> ?rewrite-closures ;
: (parse-wbindings) ( end -- )
dup parse-binding dup [
first2 [ make-local-word ] keep 2array ,
@ -81,21 +99,29 @@ SYMBOL: in-lambda?
: parse-wbindings ( end -- bindings vars )
[ (parse-wbindings) ] with-bindings ;
: parse-wlet ( -- form )
"|" expect "|" parse-wbindings
(parse-lambda) <wlet> ?rewrite-closures ;
: parse-locals ( -- vars assoc )
"(" expect ")" parse-effect
word [ over "declared-effect" set-word-prop ] when*
in>> [ dup pair? [ first ] when ] map make-locals ;
: parse-locals-definition ( word -- word quot )
parse-locals \ ; (parse-lambda) <lambda>
: parse-locals-definition ( word reader -- word quot )
[ parse-locals ] dip
((parse-lambda)) <lambda>
[ "lambda" set-word-prop ]
[ rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ] 2bi ;
[ rewrite-closures dup length 1 = [ first ] [ bad-rewrite ] if ] 2bi ; inline
: (::) ( -- word def ) CREATE-WORD parse-locals-definition ;
: (::) ( -- word def )
CREATE-WORD
[ parse-definition ]
parse-locals-definition ;
: (M::) ( -- word def )
CREATE-METHOD
[ parse-locals-definition ] with-method-definition ;
: parsed-lambda ( accum form -- accum )
in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ;
[
[ parse-definition ]
parse-locals-definition
] with-method-definition ;

18
basis/locals/rewrite/sugar/sugar.factor
View File

@ -37,13 +37,13 @@ M: array rewrite-literal? [ rewrite-literal? ] any? ;
M: quotation rewrite-literal? [ rewrite-literal? ] any? ;
M: vector rewrite-literal? [ rewrite-literal? ] any? ;
M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
M: hashtable rewrite-literal? drop t ;
M: hashtable rewrite-literal? >alist rewrite-literal? ;
M: vector rewrite-literal? drop t ;
M: tuple rewrite-literal? drop t ;
M: tuple rewrite-literal? tuple>array rewrite-literal? ;
M: object rewrite-literal? drop f ;
@ -58,12 +58,16 @@ GENERIC: rewrite-element ( obj -- )
M: array rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: vector rewrite-element rewrite-sequence ;
M: vector rewrite-element
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
M: hashtable rewrite-element
dup rewrite-literal? [ >alist rewrite-sequence \ >hashtable , ] [ , ] if ;
M: tuple rewrite-element
[ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ;
dup rewrite-literal? [
[ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] %
] [ , ] if ;
M: quotation rewrite-element rewrite-sugar* ;

2
basis/opengl/opengl.factor
View File

@ -42,7 +42,7 @@ MACRO: all-enabled ( seq quot -- )
[ words>values ] dip '[ _ _ (all-enabled) ] ;
MACRO: all-enabled-client-state ( seq quot -- )
[ words>values ] dip '[ _ (all-enabled-client-state) ] ;
[ words>values ] dip '[ _ _ (all-enabled-client-state) ] ;
: do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep

4
basis/tools/annotations/annotations-tests.factor
View File

@ -1,5 +1,5 @@
USING: tools.test tools.annotations tools.time math parser eval
io.streams.string kernel ;
io.streams.string kernel strings ;
IN: tools.annotations.tests
: foo ;
@ -45,4 +45,4 @@ M: string blah-generic ;
{ string blah-generic } watch
[ ] [ "hi" blah-generic ] unit-test
[ ] [ "hi" blah-generic ] unit-test

4
basis/tools/vocabs/browser/browser.factor
View File

@ -288,7 +288,7 @@ M: vocab-tag article-name name>> ;
M: vocab-tag article-content
\ $tagged-vocabs swap name>> 2array ;
M: vocab-tag article-parent drop "vocab-index" ;
M: vocab-tag article-parent drop "vocab-tags" ;
M: vocab-tag summary article-title ;
@ -302,6 +302,6 @@ M: vocab-author article-name name>> ;
M: vocab-author article-content
\ $authored-vocabs swap name>> 2array ;
M: vocab-author article-parent drop "vocab-index" ;
M: vocab-author article-parent drop "vocab-authors" ;
M: vocab-author summary article-title ;

14
basis/ui/gadgets/canvas/canvas.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2007 Slava Pestov.
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ui.backend ui.gadgets
ui.gadgets.worlds ui.render opengl opengl.gl kernel namespaces
classes.tuple colors accessors ;
USING: ui.backend ui.gadgets ui.gadgets.worlds ui.pens.solid opengl
opengl.gl kernel namespaces classes.tuple colors colors.constants
accessors ;
IN: ui.gadgets.canvas
TUPLE: canvas < gadget dlist ;
: new-canvas ( class -- canvas )
new black <solid> >>interior ; inline
new COLOR: black <solid> >>interior ; inline
: delete-canvas-dlist ( canvas -- )
[ find-gl-context ]
@ -23,8 +23,6 @@ TUPLE: canvas < gadget dlist ;
[ 2nip ] [ drop make-canvas-dlist ] if ; inline
: draw-canvas ( canvas quot -- )
origin get [
cache-canvas-dlist glCallList
] with-translation ; inline
cache-canvas-dlist glCallList ; inline
M: canvas ungraft* delete-canvas-dlist ;

2
basis/ui/pens/polygon/polygon-docs.factor
View File

@ -1,5 +1,5 @@
USING: colors help.markup help.syntax ui.pens ;
IN: ui.pens.polygon
USING: help.markup help.syntax ;
HELP: polygon
{ $class-description "A class implementing the " { $link draw-boundary } " and " { $link draw-interior } " generic words to draw a solid outline or a solid filled polygon, respectively. Instances of " { $link polygon } " have two slots:"

3
basis/ui/pens/polygon/polygon.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: ;
USING: accessors colors help.markup help.syntax kernel opengl
opengl.gl sequences specialized-arrays.float ui.pens ;
IN: ui.pens.polygon
! Polygon pen

0
unmaintained/fs/tags.txt → basis/ui/text/pango/tags.txt
View File

4
basis/ui/text/text-tests.factor
View File

@ -1,4 +1,6 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test ui.text ;
USING: tools.test ui.text fonts ;
IN: ui.text.tests
[ 0.0 ] [ 0 sans-serif-font "aaa" offset>x ] unit-test

2
basis/ui/tools/listener/listener-docs.factor
View File

@ -24,7 +24,7 @@ ARTICLE: "ui-listener" "UI listener"
{ $operations \ word }
{ $command-map interactor "quotation" }
{ $heading "Editing commands" }
"The text editing commands are standard; see " { $link "ui.gadgets.editors" } "."
"The text editing commands are standard; see " { $link "gadgets-editors-commands" } "."
{ $heading "Implementation" }
"Listeners are instances of " { $link listener-gadget } ". The listener consists of an output area (instance of " { $link pane } ") and an input area (instance of " { $link interactor } "). Clickable presentations can also be printed to the listener; see " { $link "ui-presentations" } "." ;

1
basis/ui/windows/summary.txt
View File

@ -1 +0,0 @@
Windows UI backend

1
basis/ui/x11/summary.txt
View File

@ -1 +0,0 @@
X11 UI backend

297
basis/ui/x11/x11.factor
View File

@ -1,297 +0,0 @@
! Copyright (C) 2005, 2008 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays ui ui.gadgets
ui.gestures ui.backend ui.clipboards ui.gadgets.worlds ui.render
ui.event-loop assocs kernel math namespaces opengl sequences
strings x11.xlib x11.events x11.xim x11.glx x11.clipboard
x11.constants x11.windows io.encodings.string io.encodings.ascii
io.encodings.utf8 combinators combinators.short-circuit command-line
math.vectors classes.tuple opengl.gl threads math.geometry.rect
environment ascii ;
IN: ui.x11
SINGLETON: x11-ui-backend
: XA_NET_WM_NAME ( -- atom ) "_NET_WM_NAME" x-atom ;
TUPLE: x11-handle-base glx ;
TUPLE: x11-handle < x11-handle-base xic window ;
TUPLE: x11-pixmap-handle < x11-handle-base pixmap glx-pixmap ;
C: <x11-handle> x11-handle
C: <x11-pixmap-handle> x11-pixmap-handle
M: world expose-event nip relayout ;
M: world configure-event
over configured-loc >>window-loc
swap configured-dim >>dim
! In case dimensions didn't change
relayout-1 ;
CONSTANT: modifiers
{
{ S+ HEX: 1 }
{ C+ HEX: 4 }
{ A+ HEX: 8 }
}
CONSTANT: key-codes
H{
{ HEX: FF08 "BACKSPACE" }
{ HEX: FF09 "TAB" }
{ HEX: FF0D "RET" }
{ HEX: FF8D "ENTER" }
{ HEX: FF1B "ESC" }
{ HEX: FFFF "DELETE" }
{ HEX: FF50 "HOME" }
{ HEX: FF51 "LEFT" }
{ HEX: FF52 "UP" }
{ HEX: FF53 "RIGHT" }
{ HEX: FF54 "DOWN" }
{ HEX: FF55 "PAGE_UP" }
{ HEX: FF56 "PAGE_DOWN" }
{ HEX: FF57 "END" }
{ HEX: FF58 "BEGIN" }
{ HEX: FFBE "F1" }
{ HEX: FFBF "F2" }
{ HEX: FFC0 "F3" }
{ HEX: FFC1 "F4" }
{ HEX: FFC2 "F5" }
{ HEX: FFC3 "F6" }
{ HEX: FFC4 "F7" }
{ HEX: FFC5 "F8" }
{ HEX: FFC6 "F9" }
}
: key-code ( keysym -- keycode action? )
dup key-codes at [ t ] [ 1string f ] ?if ;
: event-modifiers ( event -- seq )
XKeyEvent-state modifiers modifier ;
: valid-input? ( string gesture -- ? )
over empty? [ 2drop f ] [
mods>> { f { S+ } } member? [
[ { [ 127 = not ] [ CHAR: \s >= ] } 1&& ] all?
] [
[ { [ 127 = not ] [ CHAR: \s >= ] [ alpha? not ] } 1&& ] all?
] if
] if ;
: key-down-event>gesture ( event world -- string gesture )
dupd
handle>> xic>> lookup-string
[ swap event-modifiers ] dip key-code <key-down> ;
M: world key-down-event
[ key-down-event>gesture ] keep
[ propagate-key-gesture drop ]
[ 2over valid-input? [ nip user-input ] [ 3drop ] if ]
3bi ;
: key-up-event>gesture ( event -- gesture )
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
M: world key-up-event
[ key-up-event>gesture ] dip propagate-key-gesture ;
: mouse-event>gesture ( event -- modifiers button loc )
[ event-modifiers ]
[ XButtonEvent-button ]
[ mouse-event-loc ]
tri ;
M: world button-down-event
[ mouse-event>gesture [ <button-down> ] dip ] dip
send-button-down ;
M: world button-up-event
[ mouse-event>gesture [ <button-up> ] dip ] dip
send-button-up ;
: mouse-event>scroll-direction ( event -- pair )
XButtonEvent-button {
{ 4 { 0 -1 } }
{ 5 { 0 1 } }
{ 6 { -1 0 } }
{ 7 { 1 0 } }
} at ;
M: world wheel-event
[ [ mouse-event>scroll-direction ] [ mouse-event-loc ] bi ] dip
send-wheel ;
M: world enter-event motion-event ;
M: world leave-event 2drop forget-rollover ;
M: world motion-event
[ [ XMotionEvent-x ] [ XMotionEvent-y ] bi 2array ] dip
move-hand fire-motion ;
M: world focus-in-event
nip
dup handle>> xic>> XSetICFocus focus-world ;
M: world focus-out-event
nip
dup handle>> xic>> XUnsetICFocus unfocus-world ;
M: world selection-notify-event
[ handle>> window>> selection-from-event ] keep
user-input ;
: supported-type? ( atom -- ? )
{ "UTF8_STRING" "STRING" "TEXT" }
[ x-atom = ] with any? ;
: clipboard-for-atom ( atom -- clipboard )
{
{ XA_PRIMARY [ selection get ] }
{ XA_CLIPBOARD [ clipboard get ] }
[ drop <clipboard> ]
} case ;
: encode-clipboard ( string type -- bytes )
XSelectionRequestEvent-target
XA_UTF8_STRING = utf8 ascii ? encode ;
: set-selection-prop ( evt -- )
dpy get swap
[ XSelectionRequestEvent-requestor ] keep
[ XSelectionRequestEvent-property ] keep
[ XSelectionRequestEvent-target ] keep
[ 8 PropModeReplace ] dip
[
XSelectionRequestEvent-selection
clipboard-for-atom contents>>
] keep encode-clipboard dup length XChangeProperty drop ;
M: world selection-request-event
drop dup XSelectionRequestEvent-target {
{ [ dup supported-type? ] [ drop dup set-selection-prop send-notify-success ] }
{ [ dup "TARGETS" x-atom = ] [ drop dup set-targets-prop send-notify-success ] }
{ [ dup "TIMESTAMP" x-atom = ] [ drop dup set-timestamp-prop send-notify-success ] }
[ drop send-notify-failure ]
} cond ;
M: x11-ui-backend (close-window) ( handle -- )
dup xic>> XDestroyIC
dup glx>> destroy-glx
window>> dup unregister-window
destroy-window ;
M: world client-event
swap close-box? [ ungraft ] [ drop ] if ;
: gadget-window ( world -- )
dup window-loc>> over rect-dim glx-window
over "Factor" create-xic rot <x11-handle>
2dup window>> register-window
>>handle drop ;
: wait-event ( -- event )
QueuedAfterFlush events-queued 0 > [
next-event dup
None XFilterEvent zero? [ drop wait-event ] unless
] [
ui-wait wait-event
] if ;
M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup
[ handle-event ] [ 2drop ] if ;
: x-clipboard@ ( gadget clipboard -- prop win )
atom>> swap
find-world handle>> window>> ;
M: x-clipboard copy-clipboard
[ x-clipboard@ own-selection ] keep
(>>contents) ;
M: x-clipboard paste-clipboard
[ find-world handle>> window>> ] dip atom>> convert-selection ;
: init-clipboard ( -- )
XA_PRIMARY <x-clipboard> selection set-global
XA_CLIPBOARD <x-clipboard> clipboard set-global ;
: set-title-old ( dpy window string -- )
dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
: set-title-new ( dpy window string -- )
[ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
utf8 encode dup length XChangeProperty drop ;
M: x11-ui-backend set-title ( string world -- )
handle>> window>> swap
[ dpy get ] 2dip [ set-title-old ] [ set-title-new ] 3bi ;
M: x11-ui-backend set-fullscreen* ( ? world -- )
handle>> window>> "XClientMessageEvent" <c-object>
tuck set-XClientMessageEvent-window
swap _NET_WM_STATE_ADD _NET_WM_STATE_REMOVE ?
over set-XClientMessageEvent-data0
ClientMessage over set-XClientMessageEvent-type
dpy get over set-XClientMessageEvent-display
"_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
32 over set-XClientMessageEvent-format
"_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
[ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
M: x11-ui-backend (open-window) ( world -- )
dup gadget-window
handle>> window>> dup set-closable map-window ;
M: x11-ui-backend raise-window* ( world -- )
handle>> [
dpy get swap window>> XRaiseWindow drop
] when* ;
M: x11-handle select-gl-context ( handle -- )
dpy get swap
[ window>> ] [ glx>> ] bi glXMakeCurrent
[ "Failed to set current GLX context" throw ] unless ;
M: x11-handle flush-gl-context ( handle -- )
dpy get swap window>> glXSwapBuffers ;
M: x11-pixmap-handle select-gl-context ( handle -- )
dpy get swap
[ glx-pixmap>> ] [ glx>> ] bi glXMakeCurrent
[ "Failed to set current GLX context" throw ] unless ;
M: x11-pixmap-handle flush-gl-context ( handle -- )
drop ;
M: x11-ui-backend (open-offscreen-buffer) ( world -- )
dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
dpy get swap
[ glx-pixmap>> glXDestroyGLXPixmap ]
[ pixmap>> XFreePixmap drop ]
[ glx>> glXDestroyContext ] 2tri ;
M: x11-ui-backend offscreen-pixels ( world -- alien w h )
[ [ dim>> ] [ handle>> pixmap>> ] bi pixmap-bits ] [ dim>> first2 ] bi ;
M: x11-ui-backend ui ( -- )
[
f [
[
init-clipboard
start-ui
event-loop
] with-xim
] with-x
] ui-running ;
M: x11-ui-backend beep ( -- )
dpy get 100 XBell drop ;
x11-ui-backend ui-backend set-global
[ "DISPLAY" os-env "ui" "listener" ? ]
main-vocab-hook set-global

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

@ -703,3 +703,31 @@ TUPLE: bogus-hashcode-2 x ;
M: bogus-hashcode-1 hashcode* 2drop 0 >bignum ;
[ ] [ T{ bogus-hashcode-2 f T{ bogus-hashcode-1 } } hashcode drop ] unit-test
DEFER: change-slot-test
SLOT: kex
[ ] [
"IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
<string-reader> "change-slot-test" parse-stream
drop
] unit-test
[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
[ ] [
"IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test kex ;"
<string-reader> "change-slot-test" parse-stream
drop
] unit-test
[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
[ ] [
"IN: classes.tuple.tests USING: kernel accessors ; TUPLE: change-slot-test ; SLOT: kex M: change-slot-test kex>> drop 3 ;"
<string-reader> "change-slot-test" parse-stream
drop
] unit-test
[ t ] [ \ change-slot-test \ kex>> method >boolean ] unit-test
[ f ] [ \ change-slot-test \ kex>> method "reading" word-prop ] unit-test

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

@ -23,6 +23,9 @@ TUPLE: redefine-error def ;
: remember-definition ( definition loc -- )
new-definitions get first (remember-definition) ;
: fake-definition ( definition -- )
old-definitions get [ delete-at ] with each ;
: remember-class ( class loc -- )
[ dup new-definitions get first key? [ dup redefine-error ] when ] dip
new-definitions get second (remember-definition) ;
@ -72,14 +75,12 @@ SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
SYMBOL: remake-generics-hook
: index>= ( obj1 obj2 seq -- ? )
[ index ] curry bi@ >= ;
: dependency>= ( how1 how2 -- ? )
[
{
called-dependency
flushed-dependency
inlined-dependency
} index
] bi@ >= ;
{ called-dependency flushed-dependency inlined-dependency }
index>= ;
: strongest-dependency ( how1 how2 -- how )
[ called-dependency or ] bi@ [ dependency>= ] most ;

16
core/definitions/definitions.factor
View File

@ -9,13 +9,9 @@ SYMBOL: inlined-dependency
SYMBOL: flushed-dependency
SYMBOL: called-dependency
<PRIVATE
: set-in-unit ( value key assoc -- )
[ set-at ] [ no-compilation-unit ] if* ;
PRIVATE>
SYMBOL: changed-definitions
: changed-definition ( defspec -- )
@ -23,14 +19,8 @@ SYMBOL: changed-definitions
SYMBOL: changed-generics
: changed-generic ( class generic -- )
changed-generics get set-in-unit ;
SYMBOL: remake-generics
: remake-generic ( generic -- )
dup remake-generics get set-in-unit ;
SYMBOL: new-classes
: new-class ( word -- )
@ -52,11 +42,9 @@ M: object forget* drop ;
SYMBOL: forgotten-definitions
: forgotten-definition ( defspec -- )
dup forgotten-definitions get
[ no-compilation-unit ] unless*
set-at ;
dup forgotten-definitions get set-in-unit ;
: forget ( defspec -- ) dup forgotten-definition forget* ;
: forget ( defspec -- ) [ forgotten-definition ] [ forget* ] bi ;
: forget-all ( definitions -- ) [ forget ] each ;

9
core/generic/generic.factor
View File

@ -71,6 +71,13 @@ TUPLE: check-method class generic ;
\ check-method boa throw
] unless ; inline
: changed-generic ( class generic -- )
changed-generics get
[ [ [ class-or ] when* ] change-at ] [ no-compilation-unit ] if* ;
: remake-generic ( generic -- )
dup remake-generics get set-in-unit ;
: with-methods ( class generic quot -- )
[ drop changed-generic ]
[ [ "methods" word-prop ] dip call ]
@ -113,7 +120,7 @@ M: method-body crossref?
2bi ;
: create-method ( class generic -- method )
2dup method dup [ 2nip ] [
2dup method dup [ 2nip dup reset-generic ] [
drop
[ <method> dup ] 2keep
reveal-method

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

@ -556,3 +556,37 @@ EXCLUDE: qualified.tests.bar => x ;
[ "IN: qualified.tests RENAME: doesnotexist qualified.tests => blahx" eval ]
[ error>> no-word-error? ] must-fail-with
! Two similar bugs
! Replace : def with something in << >>
[ [ ] ] [
"IN: parser.tests : was-once-a-word-bug ( -- ) ;"
<string-reader> "was-once-a-word-test" parse-stream
] unit-test
[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test
[ [ ] ] [
"IN: parser.tests USE: words << \"was-once-a-word-bug\" \"parser.tests\" create [ ] (( -- )) define-declared >>"
<string-reader> "was-once-a-word-test" parse-stream
] unit-test
[ t ] [ "was-once-a-word-bug" "parser.tests" lookup >boolean ] unit-test
! Replace : def with DEFER:
[ [ ] ] [
"IN: parser.tests : is-not-deferred ( -- ) ;"
<string-reader> "is-not-deferred" parse-stream
] unit-test
[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test
[ f ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test
[ [ ] ] [
"IN: parser.tests DEFER: is-not-deferred"
<string-reader> "is-not-deferred" parse-stream
] unit-test
[ t ] [ "is-not-deferred" "parser.tests" lookup >boolean ] unit-test
[ t ] [ "is-not-deferred" "parser.tests" lookup deferred? ] unit-test

24
core/parser/parser.factor
View File

@ -5,7 +5,7 @@ sequences strings vectors words words.symbol quotations io
combinators sorting splitting math.parser effects continuations
io.files vocabs io.encodings.utf8 source-files
classes hashtables compiler.errors compiler.units accessors sets
lexer vocabs.parser ;
lexer vocabs.parser slots ;
IN: parser
: location ( -- loc )
@ -113,12 +113,16 @@ ERROR: staging-violation word ;
: parse-until ( end -- vec )
100 <vector> swap (parse-until) ;
SYMBOL: quotation-parser
HOOK: parse-quotation quotation-parser ( -- quot )
M: f parse-quotation \ ] parse-until >quotation ;
: parsed ( accum obj -- accum ) over push ;
: (parse-lines) ( lexer -- quot )
[
f parse-until >quotation
] with-lexer ;
[ f parse-until >quotation ] with-lexer ;
: parse-lines ( lines -- quot )
lexer-factory get call (parse-lines) ;
@ -216,10 +220,14 @@ print-use-hook [ [ ] ] initialize
"quiet" get [ drop ] [ "Loading " write print flush ] if ;
: filter-moved ( assoc1 assoc2 -- seq )
swap assoc-diff [
drop where dup [ first ] when
file get path>> =
] assoc-filter keys ;
swap assoc-diff keys [
{
{ [ dup where dup [ first ] when file get path>> = not ] [ f ] }
{ [ dup reader-method? ] [ f ] }
{ [ dup writer-method? ] [ f ] }
[ t ]
} cond nip
] filter ;
: removed-definitions ( -- assoc1 assoc2 )
new-definitions old-definitions

4
core/slots/slots.factor
View File

@ -10,8 +10,12 @@ TUPLE: slot-spec name offset class initial read-only ;
PREDICATE: reader < word "reader" word-prop ;
PREDICATE: reader-method < method-body "reading" word-prop ;
PREDICATE: writer < word "writer" word-prop ;
PREDICATE: writer-method < method-body "writing" word-prop ;
: <slot-spec> ( -- slot-spec )
slot-spec new
object bootstrap-word >>class ;

5
core/syntax/syntax.factor
View File

@ -94,7 +94,7 @@ IN: bootstrap.syntax
lexer get skip-blank parse-string <pathname> parsed
] define-syntax
"[" [ \ ] [ >quotation ] parse-literal ] define-syntax
"[" [ parse-quotation parsed ] define-syntax
"{" [ \ } [ >array ] parse-literal ] define-syntax
"V{" [ \ } [ >vector ] parse-literal ] define-syntax
"B{" [ \ } [ >byte-array ] parse-literal ] define-syntax
@ -135,8 +135,7 @@ IN: bootstrap.syntax
"DEFER:" [
scan current-vocab create
dup old-definitions get [ delete-at ] with each
set-word
[ fake-definition ] [ set-word ] [ [ undefined ] define ] tri
] define-syntax
":" [

47
extra/4DNav/4DNav.factor
View File

@ -13,6 +13,7 @@ sequences
combinators
continuations
colors
colors.constants
prettyprint
vars
quotations
@ -28,23 +29,19 @@ ui.gadgets.panes
ui.gadgets.borders
ui.gadgets.handler
ui.gadgets.slate
ui.gadgets.theme
ui.gadgets.frames
ui.gadgets.tracks
ui.gadgets.labels
ui.gadgets.labelled
ui.gadgets.labeled
ui.gadgets.lists
ui.gadgets.buttons
ui.gadgets.packs
ui.gadgets.grids
ui.gestures
ui.tools.workspace
ui.gadgets.scrollers
splitting
vectors
math.vectors
rewrite-closures
self
values
4DNav.turtle
4DNav.window3D
@ -55,6 +52,8 @@ fry
adsoda
adsoda.tools
;
QUALIFIED-WITH: ui.pens.solid s
IN: 4DNav
VALUE: selected-file
@ -74,10 +73,13 @@ VAR: present-space
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! replacement of namespaces.lib
! namespace utilities
: make* ( seq -- seq ) [ dup quotation? [ call ] [ ] if ] map ;
: closed-quot ( quot -- quot )
namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! waiting for deep-cleave-quots
@ -131,11 +133,11 @@ VAR: present-space
: model-projection-chooser ( -- gadget )
observer3d> projection-mode>>
{ { 1 "perspective" } { 0 "orthogonal" } }
<toggle-buttons> ;
<radio-buttons> ;
: collision-detection-chooser ( -- gadget )
observer3d> collision-mode>>
{ { t "on" } { f "off" } } <toggle-buttons> ;
{ { t "on" } { f "off" } } <radio-buttons> ;
: model-projection ( x -- space )
present-space> swap space-project ;
@ -184,8 +186,11 @@ VAR: present-space
! menu
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: ui.gadgets.labeled.private
: menu-rotations-4D ( -- gadget )
<frame>
3 3 <frame>
{ 1 1 } >>filled-cell
<pile> 1 >>fill
"XY +" [ drop rotation-step 4D-Rxy rotation-4D ]
button* add-gadget
@ -225,7 +230,8 @@ VAR: present-space
;
: menu-translations-4D ( -- gadget )
<frame>
3 3 <frame>
{ 1 1 } >>filled-cell
<pile> 1 >>fill
<shelf> 1 >>fill
"X+" [ drop { 1 0 0 0 } translation-step v*n
@ -325,12 +331,13 @@ VAR: present-space
[ ".xml" tail? ] filter
[ append-path ] with map
[ <run-file-button> add-gadget ] each
swap <labelled-gadget> ;
swap <labeled-gadget> ;
! -----------------------------------------------------
: menu-rotations-3D ( -- gadget )
<frame>
3 3 <frame>
{ 1 1 } >>filled-cell
"Turn\n left" [ rotation-step turn-left ]
camera-button @left grid-add
"Turn\n right" [ rotation-step turn-right ]
@ -348,7 +355,8 @@ VAR: present-space
;
: menu-translations-3D ( -- gadget )
<frame>
3 3 <frame>
{ 1 1 } >>filled-cell
"left\n(alt)" [ translation-step strafe-left ]
camera-button @left grid-add
"right\n(alt)" [ translation-step strafe-right ]
@ -477,8 +485,7 @@ M: space adsoda-display-model
{ 0 1 } <track>
menu-bar f track-add
<list-runner>
<limited-scroller>
{ 200 400 } >>max-dim
<scroller>
f track-add
<shelf>
"Projection mode : " <label> add-gadget
@ -492,17 +499,17 @@ M: space adsoda-display-model
<pile>
0.5 >>align
menu-4D add-gadget
light-purple solid-interior
"4D movements" <labelled-gadget>
COLOR: purple s:<solid> >>interior
"4D movements" <labeled-gadget>
f track-add
<pile>
0.5 >>align
{ 2 2 } >>gap
menu-3D add-gadget
light-purple solid-interior
"Camera 3D" <labelled-gadget>
COLOR: purple s:<solid> >>interior
"Camera 3D" <labeled-gadget>
f track-add
gray solid-interior
COLOR: gray s:<solid> >>interior
;
: viewer-windows* ( -- )

3
extra/4DNav/camera/camera.factor
View File

@ -1,5 +1,4 @@
USING: kernel namespaces math.vectors opengl 4DNav.turtle
self ;
USING: kernel namespaces math.vectors opengl 4DNav.turtle ;
IN: 4DNav.camera

4
extra/4DNav/file-chooser/file-chooser.factor
View File

@ -139,9 +139,9 @@ file-chooser H{
f track-add
<shelf>
over [ swap fc-go-parent ] curry "go up"
swap <bevel-button> add-gadget
swap <border-button> add-gadget
over [ swap fc-go-home ] curry "go home"
swap <bevel-button> add-gadget
swap <border-button> add-gadget
! over [ swap fc-ok-action ] curry "OK"
! swap <bevel-button> add-gadget
! [ drop ] "Cancel" swap <bevel-button> add-gadget

12
extra/4DNav/turtle/turtle.factor
View File

@ -2,10 +2,18 @@ USING: kernel math arrays math.vectors math.matrices
namespaces make
math.constants math.functions
math.vectors
splitting grouping self math.trig
sequences accessors 4DNav.deep models ;
splitting grouping math.trig
sequences accessors 4DNav.deep models vars ;
IN: 4DNav.turtle
! replacement of self
VAR: self
: with-self ( quot obj -- ) [ >self call ] with-scope ;
: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
TUPLE: turtle pos ori ;

2
extra/4DNav/window3D/window3D.factor
View File

@ -28,7 +28,7 @@ IN: 4DNav.window3D
TUPLE: window3D < gadget observer ;
: <window3D> ( model observer -- gadget )
window3D new-gadget
window3D new
swap 2dup
projection-mode>> add-connection
2dup

3
extra/annotations/annotations.factor
View File

@ -1,6 +1,7 @@
! (c)2009 Joe Groff, Doug Coleman. see BSD license
USING: accessors combinators.short-circuit definitions functors
kernel lexer namespaces parser prettyprint sequences words ;
kernel lexer namespaces parser prettyprint tools.crossref
sequences words ;
IN: annotations
<<

2
extra/bunny/outlined/outlined.factor
View File

@ -1,6 +1,6 @@
USING: arrays bunny.model bunny.cel-shaded continuations
destructors kernel math multiline opengl opengl.shaders
opengl.framebuffers opengl.gl opengl.demo-support fry
opengl.framebuffers opengl.gl opengl.textures opengl.demo-support fry
opengl.capabilities sequences ui.gadgets combinators accessors
macros locals ;
IN: bunny.outlined

14
extra/color-picker/color-picker.factor
View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions math.parser models
models.arrow models.range models.product sequences ui
ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs
ui.gadgets.sliders ui.render math.rectangles accessors
ui.gadgets ui.gadgets.tracks ui.gadgets.labels ui.gadgets.packs
ui.gadgets.sliders ui.pens.solid ui.render math.rectangles accessors
ui.gadgets.grids colors ;
IN: color-picker
@ -12,7 +12,7 @@ IN: color-picker
TUPLE: color-preview < gadget ;
: <color-preview> ( model -- gadget )
color-preview new-gadget
color-preview new
swap >>model
{ 100 100 } >>dim ;
@ -32,16 +32,16 @@ M: color-preview model-changed
bi ;
: <color-picker> ( -- gadget )
<frame>
vertical <track>
{ 5 5 } >>gap
<color-sliders>
[ @top grid-add ]
[ f track-add ]
[
[ <color-model> <color-preview> @center grid-add ]
[ <color-model> <color-preview> 1 track-add ]
[
[ [ truncate number>string ] map " " join ]
<arrow> <label-control>
@bottom grid-add
f track-add
] bi
] bi* ;

2
extra/demos/demos.factor
View File

@ -10,7 +10,7 @@ IN: demos
: demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
: <run-vocab-button> ( vocab-name -- button )
dup '[ drop [ _ run ] call-listener ] <bevel-button> { 0 0 } >>align ;
dup '[ drop [ _ run ] call-listener ] <border-button> ;
: <demo-runner> ( -- gadget )
<pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;

7
extra/game-input/game-input-tests.factor Normal file
View File

@ -0,0 +1,7 @@
IN: game-input.tests
USING: game-input tools.test kernel system ;
os windows? os macosx? or [
[ ] [ open-game-input ] unit-test
[ ] [ close-game-input ] unit-test
] when

2
extra/images/viewer/viewer.factor
View File

@ -19,7 +19,7 @@ M: image-gadget draw-gadget* ( gadget -- )
image>> draw-image ;
: <image-gadget> ( image -- gadget )
\ image-gadget new-gadget
\ image-gadget new
swap >>image ;
: image-window ( path -- gadget )

2
extra/infix/infix.factor
View File

@ -95,4 +95,4 @@ PRIVATE>
: [infix|
"|" parse-bindings "infix]" parse-infix-locals <let>
parsed-lambda ; parsing
?rewrite-closures over push-all ; parsing

20
extra/joystick-demo/joystick-demo.factor
View File

@ -1,7 +1,7 @@
USING: ui ui.gadgets sequences kernel arrays math colors
ui.render math.vectors accessors fry ui.gadgets.packs game-input
ui.gadgets.labels ui.gadgets.borders alarms
calendar locals strings ui.gadgets.buttons
colors.constants ui.render ui.pens.polygon ui.pens.solid math.vectors
accessors fry ui.gadgets.packs game-input ui.gadgets.labels
ui.gadgets.borders alarms calendar locals strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: joystick-demo
@ -56,11 +56,11 @@ CONSTANT: pov-polygons
[ z-indicator>> (>>loc) ] 2bi* ;
: move-pov ( gadget pov -- )
swap pov>> [ interior>> -rot = [ gray ] [ white ] if >>color drop ]
swap pov>> [ interior>> -rot = COLOR: gray COLOR: white ? >>color drop ]
with assoc-each ;
:: add-pov-gadget ( gadget direction polygon -- gadget direction gadget )
gadget white polygon <polygon-gadget> [ add-gadget ] keep
gadget COLOR: white polygon <polygon-gadget> [ add-gadget ] keep
direction swap ;
: add-pov-gadgets ( gadget -- gadget )
@ -69,14 +69,14 @@ CONSTANT: pov-polygons
: <axis-gadget> ( -- gadget )
axis-gadget new
add-pov-gadgets
black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
COLOR: black <indicator-gadget> [ >>z-indicator ] [ add-gadget ] bi
COLOR: red <indicator-gadget> [ >>indicator ] [ add-gadget ] bi
dup [ 0.0 0.0 0.0 move-axis ] [ f move-pov ] bi ;
TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
: add-gadget-with-border ( parent child -- parent )
{ 2 2 } <border> gray <solid> >>boundary add-gadget ;
{ 2 2 } <border> COLOR: gray <solid> >>boundary add-gadget ;
: add-controller-label ( gadget controller -- gadget )
[ >>controller ] [ product-string <label> add-gadget ] bi ;
@ -89,7 +89,7 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
:: (add-button-gadgets) ( gadget shelf -- )
gadget controller>> read-controller buttons>> length [
number>string [ ] <bevel-button>
number>string [ drop ] <border-button>
shelf over add-gadget drop
] map gadget (>>buttons) ;
@ -107,7 +107,7 @@ TUPLE: joystick-demo-gadget < pack axis raxis controller buttons alarm ;
[ >>selected? drop ] 2each ;
: kill-update-axes ( gadget -- )
gray <solid> >>interior
COLOR: gray <solid> >>interior
[ [ cancel-alarm ] when* f ] change-alarm
relayout-1 ;

2
extra/key-caps/key-caps.factor
View File

@ -139,7 +139,7 @@ TUPLE: key-caps-gadget < gadget keys alarm ;
: make-key-gadget ( scancode dim array -- )
[
swap [
" " [ drop ] <bevel-button>
" " [ drop ] <border-button>
swap [ first >>loc ] [ second >>dim ] bi
] [ execute ] bi*
] dip set-nth ;

4
extra/lcd/lcd.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors sequences kernel math io calendar grouping
calendar.format calendar.model arrays models models.arrow
namespaces ui.gadgets ui.gadgets.labels ui.gadgets.theme ui ;
calendar.format calendar.model fonts arrays models models.arrow
namespaces ui.gadgets ui.gadgets.labels ui ;
IN: lcd
: lcd-digit ( row digit -- str )

6
extra/literals/literals-tests.factor
View File

@ -2,11 +2,11 @@ USING: kernel literals math tools.test ;
IN: literals.tests
<<
: six-six-six 6 6 6 ;
: six-six-six ( -- a b c ) 6 6 6 ;
>>
: five 5 ;
: seven-eleven 7 11 ;
: five ( -- a ) 5 ;
: seven-eleven ( -- b c ) 7 11 ;
[ { 5 } ] [ { $ five } ] unit-test
[ { 7 11 } ] [ { $ seven-eleven } ] unit-test

2
extra/literals/literals.factor
View File

@ -3,4 +3,4 @@ USING: accessors continuations kernel parser words quotations vectors ;
IN: literals
: $ scan-word [ def>> call ] curry with-datastack >vector ; parsing
: $[ \ ] parse-until >quotation with-datastack >vector ; parsing
: $[ parse-quotation with-datastack >vector ; parsing

1
extra/literals/tags.txt
View File

@ -1 +1,2 @@
extensions
syntax

2
extra/maze/maze.factor
View File

@ -1,7 +1,7 @@
! From http://www.ffconsultancy.com/ocaml/maze/index.html
USING: sequences namespaces math math.vectors opengl opengl.gl
arrays kernel random ui ui.gadgets ui.gadgets.canvas ui.render
math.order math.rectangles ;
math.order math.rectangles accessors ;
IN: maze
CONSTANT: line-width 8

8
extra/nehe/nehe.factor
View File

@ -5,10 +5,10 @@ IN: nehe
: nehe-window ( -- )
[
<filled-pile>
"Nehe 2" [ drop run2 ] <bevel-button> add-gadget
"Nehe 3" [ drop run3 ] <bevel-button> add-gadget
"Nehe 4" [ drop run4 ] <bevel-button> add-gadget
"Nehe 5" [ drop run5 ] <bevel-button> add-gadget
"Nehe 2" [ drop run2 ] <border-button> add-gadget
"Nehe 3" [ drop run3 ] <border-button> add-gadget
"Nehe 4" [ drop run4 ] <border-button> add-gadget
"Nehe 5" [ drop run5 ] <border-button> add-gadget
"Nehe examples" open-window
] with-ui ;

4
extra/opengl/demo-support/demo-support.factor
View File

@ -15,7 +15,7 @@ TUPLE: demo-gadget < gadget yaw pitch distance ;
new
swap >>distance
swap >>pitch
swap >>yaw ;
swap >>yaw ; inline
GENERIC: far-plane ( gadget -- z )
GENERIC: near-plane ( gadget -- z )
@ -104,6 +104,6 @@ demo-gadget H{
{ T{ button-down f f 1 } [ drop reset-last-drag-rel ] }
{ T{ drag f 1 } [ drag-yaw-pitch rot [ pitch-demo-gadget ] keep yaw-demo-gadget ] }
{ T{ mouse-scroll } [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
{ mouse-scroll [ scroll-direction get second over distance-step * swap zoom-demo-gadget ] }
} set-gestures

27
extra/rewrite-closures/rewrite-closures.factor
View File

@ -1,27 +0,0 @@
USING: kernel parser math quotations namespaces sequences macros fry ;
IN: rewrite-closures
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [set-parameters] ( seq -- quot ) reverse [ [ set ] curry ] map concat ;
MACRO: set-parameters ( seq -- quot ) [set-parameters] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: parametric-quot ( parameters quot -- quot ) '[ _ set-parameters _ call ] ;
: scoped-quot ( quot -- quot ) '[ _ with-scope ] ;
: closed-quot ( quot -- quot )
namestack swap '[ namestack [ _ set-namestack @ ] dip set-namestack ] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: lambda ( parameters quot -- quot ) parametric-quot scoped-quot closed-quot ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: C[ \ ] [ >quotation ] parse-literal \ closed-quot parsed ; parsing

1
extra/rewrite-closures/summary.txt
View File

@ -1 +0,0 @@
Closures implemented via quotation rewriting

10
extra/self/self.factor
View File

@ -1,10 +0,0 @@
USING: kernel namespaces vars ;
IN: self
VAR: self
: with-self ( quot obj -- ) [ >self call ] with-scope ;
: save-self ( quot -- ) self> [ self> clone >self call ] dip >self ;

27
extra/self/slots/slots.factor
View File

@ -1,27 +0,0 @@
USING: kernel words lexer parser sequences accessors self ;
IN: self.slots
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: define-self-slot-reader ( slot -- )
[ "->" append current-vocab create dup set-word ]
[ ">>" append search [ self> ] swap suffix ] bi
(( -- value )) define-declared ;
: define-self-slot-writer ( slot -- )
[ "->" prepend current-vocab create dup set-word ]
[ ">>" prepend search [ self> swap ] swap suffix [ drop ] append ] bi
(( value -- )) define-declared ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: define-self-slot-accessors ( class -- )
"slots" word-prop
[ name>> ] map
[ [ define-self-slot-reader ] [ define-self-slot-writer ] bi ] each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: SELF-SLOTS: scan-word define-self-slot-accessors ; parsing

11
extra/slides/slides.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables help.markup help.stylesheet io
io.styles kernel math models namespaces sequences ui ui.gadgets
ui.gadgets.books ui.gadgets.panes ui.gestures ui.render
ui.gadgets.books ui.gadgets.panes ui.gestures ui.pens.gradient ui.render
parser accessors colors ;
IN: slides
@ -10,7 +10,7 @@ CONSTANT: stylesheet
H{
{ default-span-style
H{
{ font "sans-serif" }
{ font-name "sans-serif" }
{ font-size 36 }
}
}
@ -21,14 +21,14 @@ CONSTANT: stylesheet
}
{ code-style
H{
{ font "monospace" }
{ font-name "monospace" }
{ font-size 36 }
{ page-color T{ rgba f 0.4 0.4 0.4 0.3 } }
}
}
{ snippet-style
H{
{ font "monospace" }
{ font-name "monospace" }
{ font-size 36 }
{ foreground T{ rgba f 0.1 0.1 0.4 1 } }
}
@ -39,11 +39,10 @@ CONSTANT: stylesheet
{ list-style
H{ { table-gap { 10 20 } } }
}
{ bullet "\u0000b7" }
}
: $title ( string -- )
[ H{ { font "sans-serif" } { font-size 48 } } format ] ($block) ;
[ H{ { font-name "sans-serif" } { font-size 48 } } format ] ($block) ;
: $divider ( -- )
[

2
extra/spheres/spheres.factor
View File

@ -1,4 +1,4 @@
USING: kernel opengl opengl.demo-support opengl.gl
USING: kernel opengl opengl.demo-support opengl.gl opengl.textures
opengl.shaders opengl.framebuffers opengl.capabilities multiline
ui.gadgets accessors sequences ui.render ui math locals arrays
generalizations combinators ui.gadgets.worlds ;

1
extra/springies/models/urchin/authors.txt
View File

@ -1 +0,0 @@
Eduardo Cavazos

1
extra/springies/ui/authors.txt
View File

@ -1 +0,0 @@
Eduardo Cavazos

6
extra/tetris/gl/gl.factor
View File

@ -1,6 +1,8 @@
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators kernel math math.vectors namespaces opengl opengl.gl sequences tetris.board tetris.game tetris.piece ui.render tetris.tetromino ui.gadgets ;
USING: accessors arrays combinators kernel math math.vectors
namespaces opengl opengl.gl sequences tetris.board tetris.game
tetris.piece ui.render tetris.tetromino ui.gadgets colors ;
IN: tetris.gl
#! OpenGL rendering for tetris
@ -16,7 +18,7 @@ IN: tetris.gl
: draw-next-piece ( piece -- )
dup tetromino>> colour>>
clone 0.2 >>alpha gl-color draw-piece-blocks ;
>rgba-components drop 0.2 <rgba> gl-color draw-piece-blocks ;
! TODO: move implementation specific stuff into tetris-board
: (draw-row) ( x y row -- )

18
extra/tetris/tetromino/tetromino.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007, 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays namespaces sequences math math.order
math.vectors colors random ;
math.vectors colors colors.constants random ;
IN: tetris.tetromino
TUPLE: tetromino states colour ;
@ -20,7 +20,7 @@ SYMBOL: tetrominoes
{ 0 2 }
{ 0 3 }
}
} cyan
} COLOR: cyan
] [
{
{ { 1 0 }
@ -37,11 +37,11 @@ SYMBOL: tetrominoes
{ 0 1 } { 1 1 }
{ 1 2 }
}
} purple
} COLOR: purple
] [
{ { { 0 0 } { 1 0 }
{ 0 1 } { 1 1 } }
} yellow
} COLOR: yellow
] [
{
{ { 0 0 } { 1 0 } { 2 0 }
@ -58,7 +58,7 @@ SYMBOL: tetrominoes
{ 0 1 }
{ 0 2 } { 1 2 }
}
} orange
} COLOR: orange
] [
{
{ { 0 0 } { 1 0 } { 2 0 }
@ -75,7 +75,7 @@ SYMBOL: tetrominoes
{ 0 1 }
{ 0 2 }
}
} blue
} COLOR: blue
] [
{
{ { 1 0 } { 2 0 }
@ -85,7 +85,7 @@ SYMBOL: tetrominoes
{ 0 1 } { 1 1 }
{ 1 2 }
}
} green
} COLOR: green
] [
{
{
@ -96,9 +96,9 @@ SYMBOL: tetrominoes
{ 0 1 } { 1 1 }
{ 0 2 }
}
} red
} COLOR: red
]
} [ call <tetromino> ] map tetrominoes set-global
} [ first2 <tetromino> ] map tetrominoes set-global
: random-tetromino ( -- tetromino )
tetrominoes get random ;

5
extra/ui/gadgets/lists/lists.factor
View File

@ -4,8 +4,7 @@ USING: accessors math.vectors classes.tuple math.rectangles colors
kernel sequences models opengl math math.order namespaces
ui.commands ui.gestures ui.render ui.gadgets
ui.gadgets.labels ui.gadgets.scrollers
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs
ui.gadgets.theme ;
ui.gadgets.presentations ui.gadgets.viewports ui.gadgets.packs ;
IN: ui.gadgets.lists
TUPLE: list < pack index presenter color hook ;
@ -14,7 +13,7 @@ TUPLE: list < pack index presenter color hook ;
selection-color >>color ; inline
: <list> ( hook presenter model -- gadget )
list new-gadget
list new
{ 0 1 } >>orientation
1 >>fill
0 >>index

6
extra/ui/gadgets/slate/slate.factor
View File

@ -14,7 +14,6 @@ TUPLE: slate < gadget action pdim graft ungraft ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init-slate ( slate -- slate )
init-gadget
[ ] >>action
{ 200 200 } >>pdim
[ ] >>graft
@ -29,9 +28,12 @@ M: slate pref-dim* ( slate -- dim ) pdim>> ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USING: combinators arrays sequences math math.geometry
USING: combinators arrays sequences math
opengl.gl ui.gadgets.worlds ;
: width ( rect -- w ) dim>> first ;
: height ( rect -- h ) dim>> second ;
: screen-y* ( gadget -- loc )
{
[ find-world height ]

0
extra/L-system/L-system.factor → unmaintained/L-system/L-system.factor
View File

0
extra/L-system/models/abop-1/abop-1.factor → unmaintained/L-system/models/abop-1/abop-1.factor
View File

0
extra/L-system/models/abop-2/abop-2.factor → unmaintained/L-system/models/abop-2/abop-2.factor
View File

0
extra/L-system/models/abop-3/abop-3.factor → unmaintained/L-system/models/abop-3/abop-3.factor
View File

0
extra/L-system/models/abop-4/abop-4.factor → unmaintained/L-system/models/abop-4/abop-4.factor
View File

0
extra/L-system/models/abop-5-angular/abop-5-angular.factor → unmaintained/L-system/models/abop-5-angular/abop-5-angular.factor
View File

0
extra/L-system/models/abop-5/abop-5.factor → unmaintained/L-system/models/abop-5/abop-5.factor
View File

0
extra/L-system/models/abop-6/abop-6.factor → unmaintained/L-system/models/abop-6/abop-6.factor
View File

0
extra/L-system/models/airhorse/airhorse.factor → unmaintained/L-system/models/airhorse/airhorse.factor
View File

0
extra/L-system/models/tree-5/tree-5.factor → unmaintained/L-system/models/tree-5/tree-5.factor
View File

1
unmaintained/assocs-lib/authors.txt
View File

@ -1 +0,0 @@
Eduardo Cavazos

17
unmaintained/assocs-lib/lib-tests.factor
View File

@ -1,17 +0,0 @@
USING: kernel tools.test sequences vectors assocs.lib ;
IN: assocs.lib.tests
{ 1 1 } [ [ ?push ] histogram ] must-infer-as
! substitute
[ { 2 } ] [ { 1 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
[ { 3 } ] [ { 3 } H{ { 1 2 } } [ ?at drop ] curry map ] unit-test
[ 2 ] [ 1 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
[ 3 ] [ 3 H{ { 1 2 } } [ ] [ ] if-at ] unit-test
[ "hi" ] [ 1 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
[ 3 ] [ 3 H{ { 1 2 } } [ drop "hi" ] when-at ] unit-test
[ 2 ] [ 1 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test
[ "hi" ] [ 3 H{ { 1 2 } } [ drop "hi" ] unless-at ] unit-test

49
unmaintained/assocs-lib/lib.factor
View File

@ -1,49 +0,0 @@
USING: arrays assocs kernel vectors sequences namespaces
random math.parser math fry ;
IN: assocs.lib
: set-assoc-stack ( value key seq -- )
dupd [ key? ] with find-last nip set-at ;
: at-default ( key assoc -- value/key )
dupd at [ nip ] when* ;
: replace-at ( assoc value key -- assoc )
[ dupd 1vector ] dip rot set-at ;
: peek-at* ( assoc key -- obj ? )
swap at* dup [ [ peek ] dip ] when ;
: peek-at ( assoc key -- obj )
peek-at* drop ;
: >multi-assoc ( assoc -- new-assoc )
[ 1vector ] assoc-map ;
: multi-assoc-each ( assoc quot -- )
[ with each ] curry assoc-each ; inline
: insert ( value variable -- ) namespace push-at ;
: generate-key ( assoc -- str )
[ 32 random-bits >hex ] dip
2dup key? [ nip generate-key ] [ drop ] if ;
: set-at-unique ( value assoc -- key )
dup generate-key [ swap set-at ] keep ;
: histogram ( assoc quot -- assoc' )
H{ } clone [
swap [ change-at ] 2curry assoc-each
] keep ; inline
: ?at ( obj assoc -- value/obj ? )
dupd at* [ [ nip ] [ drop ] if ] keep ;
: if-at ( obj assoc quot1 quot2 -- )
[ ?at ] 2dip if ; inline
: when-at ( obj assoc quot -- ) [ ] if-at ; inline
: unless-at ( obj assoc quot -- ) [ ] swap if-at ; inline

1
unmaintained/assocs-lib/summary.txt
View File

@ -1 +0,0 @@
Non-core assoc words

1
unmaintained/assocs-lib/tags.txt
View File

@ -1 +0,0 @@
collections

0
extra/automata/authors.txt → unmaintained/automata/authors.txt
View File

0
extra/automata/automata.factor → unmaintained/automata/automata.factor
View File

0
extra/automata/summary.txt → unmaintained/automata/summary.txt
View File

0
extra/automata/ui/authors.txt → unmaintained/automata/ui/authors.txt
View File

0
extra/automata/ui/deploy.factor → unmaintained/automata/ui/deploy.factor
View File

0
extra/automata/ui/tags.txt → unmaintained/automata/ui/tags.txt
View File

0
extra/automata/ui/ui.factor → unmaintained/automata/ui/ui.factor
View File

1
unmaintained/bake/authors.txt
View File

@ -1 +0,0 @@
Eduardo Cavazos

28
unmaintained/bake/bake-tests.factor
View File

@ -1,28 +0,0 @@
USING: kernel tools.test bake ;
IN: bake.tests
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: unit-test* ( input output -- ) swap unit-test ;
: must-be-t ( in -- ) [ t ] swap unit-test ;
: must-be-f ( in -- ) [ f ] swap unit-test ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ 10 20 30 `{ , , , } ] [ { 10 20 30 } ] unit-test*
[ 10 20 30 `{ , { , } , } ] [ { 10 { 20 } 30 } ] unit-test*
[ 10 { 20 21 22 } 30 `{ , , , } ] [ { 10 { 20 21 22 } 30 } ] unit-test*
[ 10 { 20 21 22 } 30 `{ , @ , } ] [ { 10 20 21 22 30 } ] unit-test*
[ { 1 2 3 } `{ @ } ] [ { 1 2 3 } ] unit-test*
[ { 1 2 3 } { 4 5 6 } { 7 8 9 } `{ @ @ @ } ]
[ { 1 2 3 4 5 6 7 8 9 } ]
unit-test*

97
unmaintained/bake/bake.factor
View File

@ -1,97 +0,0 @@
USING: kernel parser namespaces sequences quotations arrays vectors splitting
strings words math generalizations
macros combinators.conditional newfx ;
IN: bake
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: ,
SYMBOL: @
: comma? ( obj -- ? ) , = ;
: atsym? ( obj -- ? ) @ = ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: [bake]
: broil-element ( obj -- quot )
{
{ [ comma? ] [ drop [ >r ] ] }
{ [ f = ] [ [ >r ] prefix-on ] }
{ [ integer? ] [ [ >r ] prefix-on ] }
{ [ string? ] [ [ >r ] prefix-on ] }
{ [ sequence? ] [ [bake] [ >r ] append ] }
{ [ word? ] [ literalize [ >r ] prefix-on ] }
{ [ drop t ] [ [ >r ] prefix-on ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: constructor ( seq -- quot )
{
{ [ array? ] [ length [ narray ] prefix-on ] }
! { [ quotation? ] [ length [ ncurry ] prefix-on [ ] prefix ] }
{ [ quotation? ] [ length [ narray >quotation ] prefix-on ] }
{ [ vector? ] [ length [ narray >vector ] prefix-on ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [broil] ( seq -- quot )
[ reverse [ broil-element ] map concat ]
[ length [ drop [ r> ] ] map concat ]
[ constructor ]
tri append append
>quotation ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: saved-sequence
: [connector] ( -- quot )
saved-sequence get quotation? [ [ compose ] ] [ [ append ] ] if ;
: [starter] ( -- quot )
saved-sequence get
{
{ [ quotation? ] [ drop [ [ ] ] ] }
{ [ array? ] [ drop [ { } ] ] }
{ [ vector? ] [ drop [ V{ } ] ] }
}
1cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [simmer] ( seq -- quot )
dup saved-sequence set
{ @ } split reverse
[ [ [bake] [connector] append [ >r ] append ] map concat ]
[ length [ drop [ r> ] [connector] append ] map concat ]
bi
>r 1 invert-index pluck r> ! remove the last append/compose
[starter] prepend
append ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: [bake] ( seq -- quot ) [ @ member? ] [ [simmer] ] [ [broil] ] 1if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: bake ( seq -- quot ) [bake] ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: `{ \ } [ >array ] parse-literal \ bake parsed ; parsing
: `V{ \ } [ >vector ] parse-literal \ bake parsed ; parsing
: `[ \ ] [ >quotation ] parse-literal \ bake parsed ; parsing

89
unmaintained/bake/fry/fry-tests.factor
View File

@ -1,89 +0,0 @@
USING: tools.test math prettyprint kernel io arrays vectors sequences
generalizations bake bake.fry ;
IN: bake.fry.tests
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: unit-test* ( input output -- ) swap unit-test ;
: must-be-t ( in -- ) [ t ] swap unit-test ;
: must-be-f ( in -- ) [ f ] swap unit-test ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
[ [ 3 + ] ] [ 3 '[ , + ] ] unit-test
[ [ 1 3 + ] ] [ 1 3 '[ , , + ] ] unit-test
[ [ 1 + ] ] [ 1 [ + ] '[ , @ ] ] unit-test
[ [ 1 + . ] ] [ 1 [ + ] '[ , @ . ] ] unit-test
[ [ + - ] ] [ [ + ] [ - ] '[ @ @ ] ] unit-test
[ [ "a" write "b" print ] ]
[ "a" "b" '[ , write , print ] ] unit-test
[ [ 1 2 + 3 4 - ] ]
[ [ + ] [ - ] '[ 1 2 @ 3 4 @ ] ] unit-test
[ 1/2 ] [
1 '[ , _ / ] 2 swap call
] unit-test
[ { { 1 "a" "A" } { 1 "b" "B" } { 1 "c" "C" } } ] [
1 '[ , _ _ 3array ]
{ "a" "b" "c" } { "A" "B" "C" } rot 2map
] unit-test
[ { { 1 "a" } { 1 "b" } { 1 "c" } } ] [
'[ 1 _ 2array ]
{ "a" "b" "c" } swap map
] unit-test
[ 1 2 ] [
1 2 '[ _ , ] call
] unit-test
[ { { 1 "a" 2 } { 1 "b" 2 } { 1 "c" 2 } } ] [
1 2 '[ , _ , 3array ]
{ "a" "b" "c" } swap map
] unit-test
: funny-dip '[ @ _ ] call ; inline
[ "hi" 3 ] [ "h" "i" 3 [ append ] funny-dip ] unit-test
[ { 1 2 3 } ] [
3 1 '[ , [ , + ] map ] call
] unit-test
[ { 1 { 2 { 3 } } } ] [
1 2 3 '[ , [ , [ , 1array ] call 2array ] call 2array ] call
] unit-test
{ 1 1 } [ '[ [ [ , ] ] ] ] must-infer-as
[ { { { 3 } } } ] [
3 '[ [ [ , 1array ] call 1array ] call 1array ] call
] unit-test
[ { { { 3 } } } ] [
3 '[ [ [ , 1array ] call 1array ] call 1array ] call
] unit-test
! [ 10 20 30 40 '[ , V{ , { , } } , ] ] [ [ 10 V{ 20 { 30 } } 40 ] ] unit-test*
[ 10 20 30 40 '[ , V{ , { , } } , ] ]
[ [ 10 20 30 >r r> 1 narray >r >r r> r> 2 narray >vector 40 ] ]
unit-test*
[ { 1 2 3 } { 4 5 6 } { 7 8 9 } '[ , { V{ @ } { , } } ] call ]
[
{ 1 2 3 }
{ V{ 4 5 6 } { { 7 8 9 } } }
]
unit-test*

80
unmaintained/bake/fry/fry.factor
View File

@ -1,80 +0,0 @@
USING: kernel combinators arrays vectors quotations sequences splitting
parser macros sequences.deep
combinators.short-circuit combinators.conditional bake newfx ;
IN: bake.fry
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: _
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
DEFER: (shallow-fry)
DEFER: shallow-fry
: ((shallow-fry)) ( accum quot adder -- result )
>r shallow-fry r>
append swap dup empty?
[ drop ]
[ [ prepose ] curry append ]
if ; inline
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: (shallow-fry) ( accum quot -- result )
dup empty?
[ drop 1quotation ]
[
unclip
{
{ \ , [ [ curry ] ((shallow-fry)) ] }
{ \ @ [ [ compose ] ((shallow-fry)) ] }
[ swap >r suffix r> (shallow-fry) ]
}
case
]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: shallow-fry ( quot -- quot' ) [ ] swap (shallow-fry) ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: deep-fry ( quot -- quot )
{ _ } split1-last dup
[
shallow-fry [ >r ] rot
deep-fry [ [ dip ] curry r> compose ] 4array concat
]
[ drop shallow-fry ]
if ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: bakeable? ( obj -- ? ) { [ array? ] [ vector? ] } 1|| ;
: fry-specifier? ( obj -- ? ) { , @ } member-of? ;
: count-inputs ( quot -- n ) flatten [ fry-specifier? ] count ;
: commas ( n -- seq ) , <repetition> ;
: [fry] ( quot -- quot' )
[
{
{ [ callable? ] [ [ count-inputs commas ] [ [fry] ] bi append ] }
{ [ bakeable? ] [ [ count-inputs commas ] [ [bake] ] bi append ] }
{ [ drop t ] [ 1quotation ] }
}
1cond
]
map concat deep-fry ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MACRO: fry ( seq -- quot ) [fry] ;
: '[ \ ] [ >quotation ] parse-literal \ fry parsed ; parsing

1
unmaintained/bake/summary.txt
View File

@ -1 +0,0 @@
Bake is similar to make but with additional features

1
unmaintained/bitfields/authors.txt
View File

@ -1 +0,0 @@
Daniel Ehrenberg

17
unmaintained/bitfields/bitfields-docs.factor
View File

@ -1,17 +0,0 @@
USING: help.markup help.syntax ;
IN: bitfields
HELP: BITFIELD:
{ $syntax "BITFIELD: name slot:size... ;" }
{ $values { "name" "name of bitfield" } { "slot" "names of slots" } { "size" "sizes of slots" } }
{ $description "Creates a new bitfield specification, with the constructor <name> and slot accessors of the form name-slot. Slots' values can be changed by words of the form with-name-slot, with the stack effect " { $code "( newvalue bitfield -- newbitfield )" } ". The slots have the amount of space specified, in bits, after the colon. The constructor and setters do not check to make sure there is no overflow, and any inappropriately high value (except in the first field) will corrupt the bitfield. To check overflow, use " { $link POSTPONE: SAFE-BITFIELD: } " instead. Padding can be included by writing the binary number to be used as a pad in the middle of the bitfield specification. The first slot written will have the most significant digits. Note that bitfields do not form a class; they are merely integers. For efficiency across platforms, it is often the best to keep the total size at or below 29, allowing fixnums to be used on all platforms." }
{ $see-also define-bitfield } ;
HELP: define-bitfield
{ $values { "classname" "a string" } { "slots" "slot specifications" } }
{ $description "Defines a bitfield constructor and slot accessors and setters. The workings of these are described in more detail at " { $link POSTPONE: BITFIELD: } ". The slot specifications should be an assoc. Any key which looks like a binary number will be treated as padding." } ;
HELP: SAFE-BITFIELD:
{ $syntax "SAFE-BITFIELD: name slot:size... ;" }
{ $values { "name" "name of bitfield" } { "slot" "name of slots" } { "size" "size in bits of slots" } }
{ $description "Defines a bitfield in the same way as " { $link POSTPONE: BITFIELD: } " but the constructor and slot setters check for overflow." } ;

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