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 2010-02-17 11:37:14 -08:00
parent 27cfeec43a 512e65920a
commit 052a0cb6d4
53 changed files with 511 additions and 219 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

25
basis/classes/struct/struct-tests.factor
View File

@ -1,11 +1,11 @@
! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.data ascii
assocs byte-arrays classes.struct classes.tuple.private
assocs byte-arrays classes.struct classes.tuple.private classes.tuple
combinators compiler.tree.debugger compiler.units destructors
io.encodings.utf8 io.pathnames io.streams.string kernel libc
literals math mirrors namespaces prettyprint
prettyprint.config see sequences specialized-arrays system
tools.test parser lexer eval layouts ;
tools.test parser lexer eval layouts generic.single classes ;
FROM: math => float ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: char
@ -338,13 +338,28 @@ STRUCT: struct-that's-a-word { x int } ;
[
"USE: classes.struct IN: classes.struct.tests TUPLE: not-a-struct ; S{ not-a-struct }"
eval( -- value )
] must-fail
] [ error>> no-method? ] must-fail-with
! Subclassing a struct class should not be allowed
[
"USE: classes.struct IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
"USING: alien.c-types classes.struct ; IN: classes.struct.tests STRUCT: a-struct { x int } ; TUPLE: not-a-struct < a-struct ;"
eval( -- )
] must-fail
] [ error>> bad-superclass? ] must-fail-with
! Changing a superclass into a struct should reset the subclass
TUPLE: will-become-struct ;
TUPLE: a-subclass < will-become-struct ;
[ f ] [ will-become-struct struct-class? ] unit-test
[ will-become-struct ] [ a-subclass superclass ] unit-test
[ ] [ "IN: classes.struct.tests USING: classes.struct alien.c-types ; STRUCT: will-become-struct { x int } ;" eval( -- ) ] unit-test
[ t ] [ will-become-struct struct-class? ] unit-test
[ tuple ] [ a-subclass superclass ] unit-test
! Remove c-type when struct class is forgotten
[ ] [

4
basis/classes/struct/struct.factor
View File

@ -32,8 +32,6 @@ TUPLE: struct-bit-slot-spec < struct-slot-spec
PREDICATE: struct-class < tuple-class
superclass \ struct eq? ;
M: struct-class valid-superclass? drop f ;
SLOT: fields
: struct-slots ( struct-class -- slots )
@ -273,7 +271,7 @@ M: struct binary-zero? >c-ptr [ 0 = ] all? ;
[ type>> c-type drop ] each ;
: redefine-struct-tuple-class ( class -- )
[ dup class? [ forget-class ] [ drop ] if ] [ struct f define-tuple-class ] bi ;
[ struct f define-tuple-class ] [ make-final ] bi ;
:: (define-struct-class) ( class slots offsets-quot -- )
slots empty? [ struct-must-have-slots ] when

2
basis/debugger/debugger.factor
View File

@ -194,7 +194,7 @@ M: not-a-tuple summary
drop "Not a tuple" ;
M: bad-superclass summary
drop "Tuple classes can only inherit from other tuple classes" ;
drop "Tuple classes can only inherit from non-final tuple classes" ;
M: no-initial-value summary
drop "Initial value must be provided for slots specialized to this class" ;

10
basis/functors/backend/backend.factor
View File

@ -1,6 +1,6 @@
USING: accessors arrays assocs generic.standard kernel
lexer locals.types namespaces parser quotations vocabs.parser
words ;
words classes.tuple ;
IN: functors.backend
DEFER: functor-words
@ -27,7 +27,11 @@ SYNTAX: FUNCTOR-SYNTAX:
: define* ( word def -- ) over set-word define ;
: define-declared* ( word def effect -- ) pick set-word define-declared ;
: define-declared* ( word def effect -- )
pick set-word define-declared ;
: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
: define-simple-generic* ( word effect -- )
over set-word define-simple-generic ;
: define-tuple-class* ( class superclass slots -- )
pick set-word define-tuple-class ;

47
basis/functors/functors-tests.factor
View File

@ -1,5 +1,5 @@
USING: classes.struct functors tools.test math words kernel
multiline parser io.streams.string generic ;
USING: classes.struct classes.tuple functors tools.test math
words kernel multiline parser io.streams.string generic ;
QUALIFIED-WITH: alien.c-types c
IN: functors.tests
@ -36,7 +36,7 @@ WW DEFINES ${W}${W}
WHERE
: WW ( a -- b ) \ W twice ; inline
: WW ( a -- b ) \ W twice ;
;FUNCTOR
@ -211,3 +211,44 @@ STRUCT: T-class
}
] [ a-struct struct-slots ] unit-test
<<
FUNCTOR: define-an-inline-word ( W -- )
W DEFINES ${W}
W-W DEFINES ${W}-${W}
WHERE
: W ( -- ) ; inline
: W-W ( -- ) W W ;
;FUNCTOR
"an-inline-word" define-an-inline-word
>>
[ t ] [ \ an-inline-word inline? ] unit-test
[ f ] [ \ an-inline-word-an-inline-word inline? ] unit-test
<<
FUNCTOR: define-a-final-class ( T W -- )
T DEFINES-CLASS ${T}
W DEFINES ${W}
WHERE
TUPLE: T ; final
: W ( -- ) ;
;FUNCTOR
"a-final-tuple" "a-word" define-a-final-class
>>
[ t ] [ a-final-tuple final-class? ] unit-test

5
basis/functors/functors.factor
View File

@ -61,7 +61,10 @@ FUNCTOR-SYNTAX: TUPLE:
make suffix!
]
} case
\ define-tuple-class suffix! ;
\ define-tuple-class* suffix! ;
FUNCTOR-SYNTAX: final
[ word make-final ] append! ;
FUNCTOR-SYNTAX: SINGLETON:
scan-param suffix!

2
basis/globs/globs-tests.factor Normal file → Executable file
View File

@ -30,7 +30,7 @@ IN: globs.tests
[ t ] [ "fo\\*" glob-pattern? ] unit-test
[ t ] [ "fo{o,bro}" glob-pattern? ] unit-test
"foo" "bar" append-path 1array
{ "foo" "bar" } path-separator join 1array
[ { "foo" "bar" "ba?" } path-separator join glob-parent-directory ] unit-test
[ "foo" ]

4
basis/help/markup/markup.factor
View File

@ -129,8 +129,8 @@ ALIAS: $slot $snippet
"Examples" $heading print-element ;
: $example ( element -- )
1 cut* swap "\n" join dup <input> [
input-style get format nl print-element
1 cut* [ "\n" join ] bi@ over <input> [
[ print ] [ output-style get format ] bi*
] ($code) ;
: $unchecked-example ( element -- )

7
basis/help/stylesheet/stylesheet.factor
View File

@ -80,8 +80,11 @@ H{
{ wrap-margin f }
} code-style set-global
SYMBOL: input-style
H{ { font-style bold } } input-style set-global
SYMBOL: output-style
H{
{ font-style bold }
{ foreground COLOR: dark-red }
} output-style set-global
SYMBOL: url-style
H{

29
basis/listener/listener-docs.factor
View File

@ -1,8 +1,9 @@
USING: help.markup help.syntax kernel io system prettyprint continuations quotations ;
USING: help.markup help.syntax kernel io system prettyprint
continuations quotations vocabs.loader parser ;
IN: listener
ARTICLE: "listener-watch" "Watching variables in the listener"
"The listener prints the concepts of the data and retain stacks after every expression. It can also print values of dynamic variables which are added to a watch list:"
"The listener prints values of dynamic variables which are added to a watch list:"
{ $subsections visible-vars }
"To add or remove a single variable:"
{ $subsections
@ -14,7 +15,7 @@ ARTICLE: "listener-watch" "Watching variables in the listener"
show-vars
hide-vars
}
"Hiding all visible variables:"
"Clearing the watch list:"
{ $subsections hide-all-vars } ;
HELP: only-use-vocabs
@ -46,21 +47,33 @@ HELP: hide-all-vars
{ $description "Removes all variables from the watch list." } ;
ARTICLE: "listener" "The listener"
"The listener evaluates Factor expressions read from a stream. The listener is the primary interface to the Factor runtime. Typically, you write Factor code in a text editor, then load it using the listener and test it."
"The listener evaluates Factor expressions read from the input stream. Typically, you write Factor code in a text editor, load it from the listener by calling " { $link require } ", " { $link reload } " or " { $link run-file } ", and then test it from interactively."
$nl
"The classical first program can be run in the listener:"
{ $example "\"Hello, world\" print" "Hello, world" }
"New words can also be defined in the listener:"
{ $example
"USE: math.functions"
": twice ( word -- ) [ execute ] [ execute ] bi ; inline"
"81 \\ sqrt twice ."
"3.0"
}
"Multi-line expressions are supported:"
{ $example "{ 1 2 3 } [\n .\n] each" "1\n2\n3" }
"The listener knows when to expect more input by looking at the height of the stack. Parsing words such as " { $link POSTPONE: { } " leave elements on the parser stack, and corresponding words such as " { $link POSTPONE: } } " pop them."
"The listener will display the current contents of the datastack after every line of input."
$nl
"The listener will display the current contents of the datastack after every expression is evaluated. The listener can additionally watch dynamic variables:"
"The listener can watch dynamic variables:"
{ $subsections "listener-watch" }
"To start a nested listener:"
"Nested listeners can be useful for testing code in other dynamic scopes. For example, when doing database maintanance using the " { $vocab-link "db.tuples" } " vocabulary, it can be useful to start a listener with a database connection:"
{ $code
"USING: db db.sqlite listener ;"
"\"data.db\" <sqlite-db> [ listener ] with-db"
}
"Starting a nested listener:"
{ $subsections listener }
"To exit a listener, invoke the " { $link return } " word."
$nl
"Multi-line quotations can be read independently of the rest of the listener:"
"The listener's mechanism for reading multi-line expressions from the input stream can be called from user code:"
{ $subsections read-quot } ;
ABOUT: "listener"

2
basis/math/vectors/simd/simd.factor
View File

@ -251,7 +251,7 @@ BOA-EFFECT [ N "n" <array> { "v" } <effect> ]
WHERE
TUPLE: A < simd-128 ;
TUPLE: A < simd-128 ; final
M: A new-underlying drop \ A boa ; inline
M: A simd-rep drop A-rep ; inline

12
basis/prettyprint/prettyprint-tests.factor
View File

@ -362,3 +362,15 @@ TUPLE: tuple-with-initial-declared-slot { x integer initial: 123 } ;
] [
[ \ tuple-with-initial-declared-slot see ] with-string-writer "\n" split
] unit-test
TUPLE: final-tuple ; final
[
{
"IN: prettyprint.tests"
"TUPLE: final-tuple ; final"
""
}
] [
[ \ final-tuple see ] with-string-writer "\n" split
] unit-test

21
basis/see/see.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs classes classes.builtin
classes.intersection classes.mixin classes.predicate classes.singleton
@ -182,14 +182,21 @@ M: array pprint-slot-name
dup length 1 = [ first ] when
pprint-slot-name ;
: tuple-declarations. ( class -- )
\ final declaration. ;
: superclass. ( class -- )
superclass dup tuple eq? [ drop ] [ "<" text pprint-word ] if ;
M: tuple-class see-class*
<colon \ TUPLE: pprint-word
dup pprint-word
dup superclass tuple eq? [
"<" text dup superclass pprint-word
] unless
<block "slots" word-prop [ pprint-slot ] each block>
pprint-; block> ;
{
[ pprint-word ]
[ superclass. ]
[ <block "slots" word-prop [ pprint-slot ] each block> pprint-; ]
[ tuple-declarations. ]
} cleave
block> ;
M: word see-class* drop ;

6
basis/sequences/cords/cords.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2010 Slava Pestov, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences sorting binary-search fry math
math.order arrays classes combinators kernel functors math.functions
@ -8,7 +8,7 @@ IN: sequences.cords
MIXIN: cord
TUPLE: generic-cord
{ head read-only } { tail read-only } ;
{ head read-only } { tail read-only } ; final
INSTANCE: generic-cord cord
M: cord length
@ -34,7 +34,7 @@ T-cord DEFINES-CLASS ${C}
WHERE
TUPLE: T-cord
{ head T read-only } { tail T read-only } ;
{ head T read-only } { tail T read-only } ; final
INSTANCE: T-cord cord
M: T cord-append

2
basis/specialized-arrays/specialized-arrays.factor
View File

@ -47,7 +47,7 @@ WHERE
TUPLE: A
{ underlying c-ptr read-only }
{ length array-capacity read-only } ;
{ length array-capacity read-only } ; final
: <direct-A> ( alien len -- specialized-array ) A boa ; inline

12
basis/stack-checker/dependencies/dependencies.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors classes.algebra fry generic kernel math
namespaces sequences words sets combinators.short-circuit ;
namespaces sequences words sets combinators.short-circuit
classes.tuple ;
FROM: classes.tuple.private => tuple-layout ;
IN: stack-checker.dependencies
@ -122,6 +123,15 @@ TUPLE: depends-on-flushable word ;
M: depends-on-flushable satisfied?
word>> flushable? ;
TUPLE: depends-on-final class ;
: depends-on-final ( word -- )
[ depends-on-conditionally ]
[ \ depends-on-final add-conditional-dependency ] bi ;
M: depends-on-final satisfied?
class>> final-class? ;
: init-dependencies ( -- )
H{ } clone dependencies set
H{ } clone generic-dependencies set

11
basis/tools/deploy/backend/backend.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make continuations.private kernel.private init
assocs kernel vocabs words sequences memory io system arrays
@ -19,13 +19,12 @@ TUPLE: vocab-manifest vocabs libraries ;
: copy-resources ( manifest name dir -- )
append-path swap vocabs>> [ copy-vocab-resources ] with each ;
ERROR: cant-deploy-library-file library ;
<PRIVATE
ERROR: can't-deploy-library-file library ;
: copy-library ( dir library -- )
dup find-library-file
[ nip swap over file-name append-path copy-file ]
[ cant-deploy-library-file ] if* ;
PRIVATE>
[ swap over file-name append-path copy-file ]
[ can't-deploy-library-file ] ?if ;
: copy-libraries ( manifest name dir -- )
append-path swap libraries>> [ copy-library ] with each ;

12
basis/tuple-arrays/tuple-arrays-docs.factor
View File

@ -3,20 +3,24 @@ USING: help.markup help.syntax sequences ;
HELP: TUPLE-ARRAY:
{ $syntax "TUPLE-ARRAY: class" }
{ $values { "class" "a final tuple class" } }
{ $description "Generates a new data type in the current vocabulary named " { $snippet { $emphasis "class" } "-array" } " for holding instances of " { $snippet "class" } ", which must be a tuple class word. Together with the class itself, this also generates words named " { $snippet "<" { $emphasis "class" } "-array>" } " and " { $snippet ">" { $emphasis "class" } "-array" } ", for creating new instances of this tuple array type." } ;
ARTICLE: "tuple-arrays" "Tuple arrays"
"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of pointers to heap-allocated objects, a tuple array stores its elements inline. Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of references to heap-allocated objects, a tuple array stores its elements as values."
$nl
"Since value semantics differ from reference semantics, it is best to use tuple arrays with tuples where all slots are declared " { $link read-only } "."
"Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
$nl
"Since value semantics are incompatible with inheritance, the base type of a tuple array must be declared " { $link POSTPONE: final } ". A best practice that is not enforced is to have all slots in the tuple declared " { $link read-only } "."
$nl
"Tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
$nl
"Tuple arrays should not be used with inheritance; storing an instance of a subclass in a tuple array will slice off the subclass slots, and getting the same value out again will yield an instance of the superclass. Also, tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
{ $subsections POSTPONE: TUPLE-ARRAY: }
"An example:"
{ $example
"USE: tuple-arrays"
"IN: scratchpad"
"TUPLE: point x y ;"
"TUPLE: point x y ; final"
"TUPLE-ARRAY: point"
"{ T{ point f 1 2 } T{ point f 1 3 } T{ point f 2 3 } } >point-array first short."
"T{ point f 1 2 }"

22
basis/tuple-arrays/tuple-arrays-tests.factor
View File

@ -1,9 +1,9 @@
USING: tuple-arrays sequences tools.test namespaces kernel
math accessors ;
math accessors classes.tuple eval ;
IN: tuple-arrays.tests
SYMBOL: mat
TUPLE: foo bar ;
TUPLE: foo bar ; final
C: <foo> foo
TUPLE-ARRAY: foo
@ -18,15 +18,27 @@ TUPLE-ARRAY: foo
[ T{ foo } ] [ mat get first ] unit-test
[ T{ foo f 1 } ] [ T{ foo f 1 } 0 mat get [ set-nth ] keep first ] unit-test
TUPLE: baz { bing integer } bong ;
TUPLE: baz { bing integer } bong ; final
TUPLE-ARRAY: baz
[ 0 ] [ 1 <baz-array> first bing>> ] unit-test
[ f ] [ 1 <baz-array> first bong>> ] unit-test
TUPLE: broken x ;
TUPLE: broken x ; final
: broken ( -- ) ;
TUPLE-ARRAY: broken
[ 100 ] [ 100 <broken-array> length ] unit-test
[ 100 ] [ 100 <broken-array> length ] unit-test
! Can't define a tuple array for a non-tuple class
[ "IN: tuple-arrays.tests USING: tuple-arrays words ; TUPLE-ARRAY: word" eval( -- ) ]
[ error>> not-a-tuple? ]
must-fail-with
! Can't define a tuple array for a non-final class
TUPLE: non-final x ;
[ "IN: tuple-arrays.tests USE: tuple-arrays TUPLE-ARRAY: non-final" eval( -- ) ]
[ error>> not-final? ]
must-fail-with

15
basis/tuple-arrays/tuple-arrays.factor
View File

@ -1,11 +1,13 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators.smart fry functors kernel
kernel.private macros sequences combinators sequences.private
stack-checker parser math classes.tuple.private ;
stack-checker parser math classes.tuple classes.tuple.private ;
FROM: inverse => undo ;
IN: tuple-arrays
ERROR: not-final class ;
<PRIVATE
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
@ -29,6 +31,13 @@ MACRO: write-tuple ( class -- quot )
[ tuple-arity iota <reversed> [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ]
bi '[ _ dip @ ] ;
: check-final ( class -- )
{
{ [ dup tuple-class? not ] [ not-a-tuple ] }
{ [ dup final-class? not ] [ not-final ] }
[ drop ]
} cond ;
PRIVATE>
FUNCTOR: define-tuple-array ( CLASS -- )
@ -43,6 +52,8 @@ CLASS-array? IS ${CLASS-array}?
WHERE
CLASS check-final
TUPLE: CLASS-array
{ seq array read-only }
{ n array-capacity read-only }

8
basis/typed/typed-docs.factor
View File

@ -58,10 +58,18 @@ HELP: output-mismatch-error
ARTICLE: "typed" "Strongly-typed word definitions"
"The Factor compiler supports advanced compiler optimizations that take advantage of the type information it can glean from source code. The " { $vocab-link "typed" } " vocabulary provides syntax that allows words to provide checked type information about their inputs and outputs and improve the performance of compiled code."
$nl
"Parameters and return values of typed words where the type is declared to be a " { $link POSTPONE: final } " tuple class with all slots " { $link read-only } " are passed by value."
{ $subsections
POSTPONE: TYPED:
POSTPONE: TYPED::
}
"Defining typed words at run time:"
{ $subsections
define-typed
}
"Errors:"
{ $subsections
input-mismatch-error
output-mismatch-error
} ;

37
basis/typed/typed-tests.factor
View File

@ -14,8 +14,8 @@ TYPED: fix+ ( a: fixnum b: fixnum -- c: fixnum )
most-positive-fixnum neg 1 - 1quotation
[ most-positive-fixnum 1 fix+ ] unit-test
TUPLE: tweedle-dee ;
TUPLE: tweedle-dum ;
TUPLE: tweedle-dee ; final
TUPLE: tweedle-dum ; final
TYPED: dee ( x: tweedle-dee -- y )
drop \ tweedle-dee ;
@ -39,11 +39,11 @@ TYPED:: f+locals ( a: float b: float -- c: float )
TUPLE: unboxable
{ x fixnum read-only }
{ y fixnum read-only } ;
{ y fixnum read-only } ; final
TUPLE: unboxable2
{ u unboxable read-only }
{ xy fixnum read-only } ;
{ xy fixnum read-only } ; final
TYPED: unboxy ( in: unboxable -- out: unboxable2 )
dup [ x>> ] [ y>> ] bi - unboxable2 boa ;
@ -63,7 +63,7 @@ IN: typed.tests
TUPLE: unboxable
{ x fixnum read-only }
{ y fixnum read-only }
{ z float read-only } ;
{ z float read-only } ; final
""" eval( -- )
"""
@ -79,13 +79,15 @@ TYPED: no-inputs ( -- out: integer )
[ 1 ] [ no-inputs ] unit-test
TUPLE: unboxable3
{ x read-only } ;
{ x read-only } ; final
TYPED: no-inputs-unboxable-output ( -- out: unboxable3 )
T{ unboxable3 } ;
[ T{ unboxable3 } ] [ no-inputs-unboxable-output ] unit-test
[ f ] [ no-inputs-unboxable-output no-inputs-unboxable-output eq? ] unit-test
SYMBOL: buh
TYPED: no-outputs ( x: integer -- )
@ -97,3 +99,26 @@ TYPED: no-outputs-unboxable-input ( x: unboxable3 -- )
buh set ;
[ T{ unboxable3 } ] [ T{ unboxable3 } no-outputs-unboxable-input buh get ] unit-test
[ f ] [
T{ unboxable3 } no-outputs-unboxable-input buh get
T{ unboxable3 } no-outputs-unboxable-input buh get
eq?
] unit-test
! Reported by littledan
TUPLE: superclass { x read-only } ;
TUPLE: subclass < superclass { y read-only } ; final
TYPED: unbox-fail ( a: superclass -- ? ) subclass? ;
[ t ] [ subclass new unbox-fail ] unit-test
! If a final class becomes non-final, typed words need to be recompiled
TYPED: recompile-fail ( a: subclass -- ? ) buh get eq? ;
[ f ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test
[ ] [ "IN: typed.tests TUPLE: subclass < superclass { y read-only } ;" eval( -- ) ] unit-test
[ t ] [ subclass new [ buh set ] [ recompile-fail ] bi ] unit-test

12
basis/typed/typed.factor
View File

@ -20,6 +20,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
{
[ all-slots empty? not ]
[ immutable-tuple-class? ]
[ final-class? ]
} 1&& ;
! typed inputs
@ -30,9 +31,14 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
: input-mismatch-quot ( word types -- quot )
[ input-mismatch-error ] 2curry ;
: depends-on-unboxing ( class -- )
[ dup tuple-layout depends-on-tuple-layout ]
[ depends-on-final ]
bi ;
: (unboxer) ( type -- quot )
dup unboxable-tuple-class? [
dup dup tuple-layout depends-on-tuple-layout
dup depends-on-unboxing
all-slots [
[ name>> reader-word 1quotation ]
[ class>> (unboxer) ] bi compose
@ -52,7 +58,7 @@ PREDICATE: typed-word < word "typed-word" word-prop ;
: (unboxed-types) ( type -- types )
dup unboxable-tuple-class?
[
dup dup tuple-layout depends-on-tuple-layout
dup depends-on-unboxing
all-slots [ class>> (unboxed-types) ] map concat
]
[ 1array ] if ;
@ -81,7 +87,7 @@ DEFER: make-boxer
: boxer ( type -- quot )
dup unboxable-tuple-class?
[
dup dup tuple-layout depends-on-tuple-layout
dup depends-on-unboxing
[ all-slots [ class>> ] map make-boxer ]
[ [ boa ] curry ]
bi compose

14
core/arrays/arrays.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel kernel.private math math.private
sequences sequences.private ;
@ -9,24 +9,16 @@ M: array length length>> ; inline
M: array nth-unsafe [ >fixnum ] dip array-nth ; inline
M: array set-nth-unsafe [ >fixnum ] dip set-array-nth ; inline
M: array resize resize-array ; inline
: >array ( seq -- array ) { } clone-like ;
M: array equal? over array? [ sequence= ] [ 2drop f ] if ;
M: object new-sequence drop 0 <array> ; inline
M: f new-sequence drop [ f ] [ 0 <array> ] if-zero ; inline
M: array equal?
over array? [ sequence= ] [ 2drop f ] if ;
INSTANCE: array sequence
: >array ( seq -- array ) { } clone-like ;
: 1array ( x -- array ) 1 swap <array> ; inline
: 2array ( x y -- array ) { } 2sequence ; inline
: 3array ( x y z -- array ) { } 3sequence ; inline
: 4array ( w x y z -- array ) { } 4sequence ; inline
PREDICATE: pair < array length 2 number= ;

1
core/bootstrap/syntax.factor
View File

@ -49,6 +49,7 @@ IN: bootstrap.syntax
"SYMBOLS:"
"CONSTANT:"
"TUPLE:"
"final"
"SLOT:"
"T{"
"UNION:"

3
core/classes/parser/parser.factor
View File

@ -8,8 +8,9 @@ IN: classes.parser
: create-class-in ( string -- word )
current-vocab create
dup set-word
dup save-class-location
dup create-predicate-word dup set-word save-location ;
dup create-predicate-word save-location ;
: CREATE-CLASS ( -- word )
scan create-class-in ;

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

@ -191,6 +191,8 @@ $nl
"tuple-inheritance-example"
"tuple-inheritance-anti-example"
}
"Declaring a tuple class final prohibits other classes from subclassing it:"
{ $subsections POSTPONE: final }
{ $see-also "call-next-method" "parametrized-constructors" "unions" "mixins" } ;
ARTICLE: "tuple-introspection" "Tuple introspection"
@ -441,3 +443,6 @@ HELP: boa
{ $description "Creates a new instance of " { $snippet "class" } " and fill in the slots from the stack, with the top-most stack element being stored in the right-most slot." }
{ $notes "The name " { $snippet "boa" } " is shorthand for “by order of arguments”, and “BOA constructor” is a pun on “boa constrictor”." }
{ $errors "Throws an error if the slot values do not match class declarations on slots (see" { $link "tuple-declarations" } ")." } ;
HELP: bad-superclass
{ $error-description "Thrown if an attempt is made to subclass a class that is not a tuple class, or a tuple class declared " { $link POSTPONE: final } "." } ;

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

@ -770,3 +770,30 @@ TUPLE: tuple-predicate-redefine-test ;
[ ] [ "IN: classes.tuple.tests TUPLE: tuple-predicate-redefine-test ;" eval( -- ) ] unit-test
[ t ] [ \ tuple-predicate-redefine-test? predicate? ] unit-test
! Final classes
TUPLE: final-superclass ;
TUPLE: final-subclass < final-superclass ;
[ final-superclass ] [ final-subclass superclass ] unit-test
! Making the superclass final should change the superclass of the subclass
[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ; final" eval( -- ) ] unit-test
[ tuple ] [ final-subclass superclass ] unit-test
[ f ] [ \ final-subclass final-class? ] unit-test
! Subclassing a final class should fail
[ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ;" eval( -- ) ]
[ error>> bad-superclass? ] must-fail-with
! Making a final class non-final should work
[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass ;" eval( -- ) ] unit-test
[ ] [ "IN: classes.tuple.tests TUPLE: final-subclass < final-superclass ; final" eval( -- ) ] unit-test
! Changing a superclass should not change the final status of a subclass
[ ] [ "IN: classes.tuple.tests TUPLE: final-superclass x ;" eval( -- ) ] unit-test
[ t ] [ \ final-subclass final-class? ] unit-test

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

@ -93,6 +93,14 @@ ERROR: bad-superclass class ;
] [ 2drop f ] if
] [ 2drop f ] if ; inline
GENERIC: final-class? ( class -- ? )
M: tuple-class final-class? "final" word-prop ;
M: builtin-class final-class? tuple eq? not ;
M: class final-class? drop t ;
<PRIVATE
: tuple-predicate-quot/1 ( class -- quot )
@ -238,16 +246,8 @@ M: tuple-class update-class
[ [ "slots" word-prop ] dip = ]
bi-curry* bi and ;
GENERIC: valid-superclass? ( class -- ? )
M: tuple-class valid-superclass? drop t ;
M: builtin-class valid-superclass? tuple eq? ;
M: class valid-superclass? drop f ;
: check-superclass ( superclass -- )
dup valid-superclass? [ bad-superclass ] unless drop ;
dup final-class? [ bad-superclass ] when drop ;
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
@ -261,6 +261,13 @@ GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
read-only suffix
] map ;
: reset-final ( class -- )
dup final-class? [
[ f "final" set-word-prop ]
[ changed-conditionally ]
bi
] [ drop ] if ;
PRIVATE>
: define-tuple-class ( class superclass slots -- )
@ -268,10 +275,18 @@ PRIVATE>
over prepare-slots
(define-tuple-class) ;
GENERIC: make-final ( class -- )
M: tuple-class make-final
[ dup class-usage keys ?metaclass-changed ]
[ t "final" set-word-prop ]
bi ;
M: word (define-tuple-class)
define-new-tuple-class ;
M: tuple-class (define-tuple-class)
pick reset-final
3dup tuple-class-unchanged?
[ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
@ -301,7 +316,7 @@ M: tuple-class reset-class
] with each
] [
[ call-next-method ]
[ { "layout" "slots" "boa-check" "prototype" } reset-props ]
[ { "layout" "slots" "boa-check" "prototype" "final" } reset-props ]
bi
] bi ;

6
core/combinators/combinators.factor
View File

@ -5,6 +5,10 @@ kernel kernel.private math assocs quotations vectors
hashtables sorting words sets math.order make ;
IN: combinators
! Most of these combinators have compile-time expansions in
! the optimizing compiler. See stack-checker.transforms and
! compiler.tree.propagation.call-effect
<PRIVATE
: call-effect-unsafe ( quot effect -- ) drop call ;
@ -17,7 +21,7 @@ M: object throw
PRIVATE>
ERROR: wrong-values quot effect ;
ERROR: wrong-values quot call-site ;
! We can't USE: effects here so we forward reference slots instead
SLOT: in

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

@ -166,7 +166,13 @@ HELP: create-method
HELP: (call-next-method)
{ $values { "method" method } }
{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
{ $notes
"The " { $link POSTPONE: call-next-method } " word parses into this word. The following are equivalent:"
{ $code
"M: class generic call-next-method ;"
"M: class generic M\\ class generic (call-next-method) ;"
}
} ;
HELP: no-next-method
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }

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

@ -339,7 +339,7 @@ IN: parser.tests
] unit-test
[ t ] [
"foo?" "parser.tests" lookup word eq?
"foo" "parser.tests" lookup word eq?
] unit-test
[ ] [

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

@ -792,6 +792,10 @@ $nl
{ $code "TUPLE: person" "{ age integer initial: 0 }" "{ department string initial: \"Marketing\" }" "manager ;" }
} ;
HELP: final
{ $syntax "TUPLE: ... ; final" }
{ $description "Declares the most recently defined word as a final tuple class which cannot be subclassed. Attempting to subclass a final class raises a " { $link bad-superclass } " error." } ;
HELP: initial:
{ $syntax "TUPLE: ... { slot initial: value } ... ;" }
{ $values { "slot" "a slot name" } { "value" "any literal" } }

4
core/syntax/syntax.factor
View File

@ -204,6 +204,10 @@ IN: bootstrap.syntax
parse-tuple-definition define-tuple-class
] define-core-syntax
"final" [
word make-final
] define-core-syntax
"SLOT:" [
scan define-protocol-slot
] define-core-syntax

4
extra/benchmark/tuple-arrays/tuple-arrays.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2009 Slava Pestov.
! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.functions tuple-arrays accessors fry sequences
prettyprint ;
IN: benchmark.tuple-arrays
TUPLE: point { x float } { y float } { z float } ;
TUPLE: point { x float } { y float } { z float } ; final
TUPLE-ARRAY: point

4
extra/gpu/gpu.factor Normal file → Executable file
View File

@ -9,10 +9,12 @@ TUPLE: gpu-object < identity-tuple handle ;
VARIANT: gpu-api
opengl-2 opengl-3 ;
SYMBOL: has-vertex-array-objects?
: set-gpu-api ( -- )
"2.0" require-gl-version
"3.0" { { "GL_ARB_vertex_array_object" "GL_APPLE_vertex_array_object" } }
require-gl-version-or-extensions
has-gl-version-or-extensions? has-vertex-array-objects? set-global
"3.0" has-gl-version? opengl-3 opengl-2 ? gpu-api set-global ;
HOOK: init-gpu-api gpu-api ( -- )

5
extra/gpu/render/render.factor Normal file → Executable file
View File

@ -520,9 +520,6 @@ SYNTAX: UNIFORM-TUPLE:
<PRIVATE
: bind-vertex-array ( vertex-array -- )
handle>> glBindVertexArray ;
: bind-unnamed-output-attachments ( framebuffer attachments -- )
[ gl-attachment ] with map
dup length 1 =
@ -567,7 +564,7 @@ UNION: transform-feedback-output buffer buffer-range POSTPONE: f ;
TUPLE: render-set
{ primitive-mode primitive-mode read-only }
{ vertex-array vertex-array read-only }
{ vertex-array vertex-array initial: T{ vertex-array-collection } read-only }
{ uniforms uniform-tuple read-only }
{ indexes vertex-indexes initial: T{ index-range } read-only }
{ instances ?integer initial: f read-only }

80
extra/gpu/shaders/shaders.factor Normal file → Executable file
View File

@ -2,9 +2,9 @@
USING: accessors alien alien.c-types alien.data alien.strings
arrays assocs byte-arrays classes.mixin classes.parser
classes.singleton classes.struct combinators combinators.short-circuit
definitions destructors fry generic.parser gpu gpu.buffers hashtables
images io.encodings.ascii io.files io.pathnames kernel lexer
literals locals math math.parser memoize multiline namespaces
definitions destructors fry generic.parser gpu gpu.buffers gpu.private
gpu.state hashtables images io.encodings.ascii io.files io.pathnames
kernel lexer literals locals math math.parser memoize multiline namespaces
opengl opengl.gl opengl.shaders parser quotations sequences
specialized-arrays splitting strings tr ui.gadgets.worlds
variants vectors vocabs vocabs.loader vocabs.parser words
@ -319,11 +319,18 @@ SYNTAX: VERTEX-FORMAT:
SYNTAX: VERTEX-STRUCT:
CREATE-CLASS scan-word define-vertex-struct ;
TUPLE: vertex-array < gpu-object
TUPLE: vertex-array-object < gpu-object
{ program-instance program-instance read-only }
{ vertex-buffers sequence read-only } ;
M: vertex-array dispose
TUPLE: vertex-array-collection
{ vertex-formats sequence read-only }
{ program-instance program-instance read-only } ;
UNION: vertex-array
vertex-array-object vertex-array-collection ;
M: vertex-array-object dispose
[ [ delete-vertex-array ] when* f ] change-handle drop ;
: ?>buffer-ptr ( buffer/ptr -- buffer-ptr )
@ -331,26 +338,73 @@ M: vertex-array dispose
: ?>buffer ( buffer/ptr -- buffer )
dup buffer? [ buffer>> ] unless ; inline
:: <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
<PRIVATE
: normalize-vertex-formats ( vertex-formats -- vertex-formats' )
[ first2 [ ?>buffer-ptr ] dip 2array ] map ; inline
: (bind-vertex-array) ( vertex-formats program-instance -- )
'[ _ swap first2 bind-vertex-format ] each ; inline
: (reset-vertex-array) ( -- )
GL_MAX_VERTEX_ATTRIBS get-gl-int iota [ glDisableVertexAttribArray ] each ; inline
:: <multi-vertex-array-object> ( vertex-formats program-instance -- vertex-array )
gen-vertex-array :> handle
handle glBindVertexArray
vertex-formats [ program-instance swap first2 [ ?>buffer-ptr ] dip bind-vertex-format ] each
handle program-instance vertex-formats [ first ?>buffer ] map
vertex-array boa window-resource ; inline
vertex-formats normalize-vertex-formats program-instance (bind-vertex-array)
:: <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
handle program-instance vertex-formats [ first ?>buffer ] map
vertex-array-object boa window-resource ; inline
: <multi-vertex-array-collection> ( vertex-formats program-instance -- vertex-array )
[ normalize-vertex-formats ] dip vertex-array-collection boa ; inline
:: <vertex-array-object> ( vertex-buffer program-instance format -- vertex-array )
gen-vertex-array :> handle
handle glBindVertexArray
program-instance vertex-buffer ?>buffer-ptr format bind-vertex-format
handle program-instance vertex-buffer ?>buffer 1array
vertex-array boa window-resource ; inline
vertex-array-object boa window-resource ; inline
: <vertex-array-collection> ( vertex-buffer program-instance format -- vertex-array )
swap [ [ ?>buffer-ptr ] dip 2array 1array ] dip <multi-vertex-array-collection> ; inline
PRIVATE>
GENERIC: bind-vertex-array ( vertex-array -- )
M: vertex-array-object bind-vertex-array
handle>> glBindVertexArray ; inline
M: vertex-array-collection bind-vertex-array
(reset-vertex-array)
[ vertex-formats>> ] [ program-instance>> ] bi (bind-vertex-array) ; inline
: <multi-vertex-array> ( vertex-formats program-instance -- vertex-array )
has-vertex-array-objects? get
[ <multi-vertex-array-object> ]
[ <multi-vertex-array-collection> ] if ; inline
: <vertex-array*> ( vertex-buffer program-instance format -- vertex-array )
has-vertex-array-objects? get
[ <vertex-array-object> ]
[ <vertex-array-collection> ] if ; inline
: <vertex-array> ( vertex-buffer program-instance -- vertex-array )
dup program>> vertex-formats>> first <vertex-array*> ; inline
TYPED: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
vertex-buffers>> first ;
GENERIC: vertex-array-buffers ( vertex-array -- buffers )
M: vertex-array-object vertex-array-buffers
vertex-buffers>> ; inline
M: vertex-array-collection vertex-array-buffers
vertex-formats>> [ first buffer>> ] map ; inline
: vertex-array-buffer ( vertex-array: vertex-array -- vertex-buffer: buffer )
vertex-array-buffers first ; inline
TUPLE: compile-shader-error shader log ;
TUPLE: link-program-error program log ;

4
extra/gpu/state/state.factor Normal file → Executable file
View File

@ -415,8 +415,6 @@ M: mask-state set-gpu-state*
[ [ set-gpu-state* ] each ]
[ set-gpu-state* ] if ; inline
<PRIVATE
: get-gl-bool ( enum -- value )
0 <uchar> [ glGetBooleanv ] keep *uchar c-bool> ;
: get-gl-int ( enum -- value )
@ -437,8 +435,6 @@ M: mask-state set-gpu-state*
: gl-enabled? ( enum -- ? )
glIsEnabled c-bool> ;
PRIVATE>
TYPED: get-viewport-state ( -- viewport-state: viewport-state )
GL_VIEWPORT get-gl-rect <viewport-state> ;

2
extra/morse/morse.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008, 2009 Alex Chapman, 2009 Diego Martinelli
! See http://factorcode.org/license.txt for BSD license.
USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal parser sequences splitting strings synth synth.buffers ;
USING: accessors ascii assocs biassocs combinators hashtables kernel lists literals math namespaces make multiline openal openal.alut parser sequences splitting strings synth synth.buffers ;
IN: morse
ERROR: no-morse-ch ch ;

103
extra/openal/alut/alut.factor Executable file
View File

@ -0,0 +1,103 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors arrays alien system combinators
alien.syntax namespaces alien.c-types sequences vocabs.loader
shuffle openal openal.alut.backend alien.libraries generalizations
specialized-arrays alien.destructors ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: uint
IN: openal.alut
<< "alut" {
{ [ os windows? ] [ "alut.dll" ] }
{ [ os macosx? ] [
"/System/Library/Frameworks/OpenAL.framework/OpenAL"
] }
{ [ os unix? ] [ "libalut.so" ] }
} cond "cdecl" add-library >>
<< os macosx? [ "alut" deploy-library ] unless >>
LIBRARY: alut
CONSTANT: ALUT_API_MAJOR_VERSION 1
CONSTANT: ALUT_API_MINOR_VERSION 1
CONSTANT: ALUT_ERROR_NO_ERROR 0
CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
CONSTANT: ALUT_LOADER_BUFFER HEX: 300
CONSTANT: ALUT_LOADER_MEMORY HEX: 301
FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
FUNCTION: ALboolean alutExit ( ) ;
FUNCTION: ALenum alutGetError ( ) ;
FUNCTION: char* alutGetErrorString ( ALenum error ) ;
FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
FUNCTION: ALint alutGetMajorVersion ( ) ;
FUNCTION: ALint alutGetMinorVersion ( ) ;
FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
SYMBOL: init
: init-openal ( -- )
init get-global expired? [
f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
1337 <alien> init set-global
] when ;
: exit-openal ( -- )
init get-global expired? [
alutExit 0 = [ "Could not close OpenAL" throw ] when
f init set-global
] unless ;
: create-buffer-from-file ( filename -- buffer )
alutCreateBufferFromFile dup AL_NONE = [
"create-buffer-from-file failed" throw
] when ;
os macosx? "openal.alut.macosx" "openal.alut.other" ? require
: create-buffer-from-wav ( filename -- buffer )
gen-buffer dup rot load-wav-file
[ alBufferData ] 4 nkeep alutUnloadWAV ;
: check-error ( -- )
alGetError dup ALUT_ERROR_NO_ERROR = [
drop
] [
alGetString throw
] if ;

0
extra/openal/backend/authors.txt → extra/openal/alut/backend/authors.txt
View File

2
extra/openal/backend/backend.factor → extra/openal/alut/backend/backend.factor Normal file → Executable file
View File

@ -1,4 +1,4 @@
USING: namespaces system ;
IN: openal.backend
IN: openal.alut.backend
HOOK: load-wav-file os ( filename -- format data size frequency )

0
extra/openal/macosx/authors.txt → extra/openal/alut/macosx/authors.txt
View File

4
extra/openal/macosx/macosx.factor → extra/openal/alut/macosx/macosx.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel alien alien.syntax shuffle
openal openal.backend namespaces system generalizations ;
IN: openal.macosx
openal openal.alut.backend namespaces system generalizations ;
IN: openal.alut.macosx
LIBRARY: alut

0
extra/openal/macosx/tags.txt → extra/openal/alut/macosx/tags.txt
View File

0
extra/openal/other/authors.txt → extra/openal/alut/other/authors.txt
View File

4
extra/openal/other/other.factor → extra/openal/alut/other/other.factor Normal file → Executable file
View File

@ -1,8 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types alien.syntax combinators generalizations
kernel openal openal.backend ;
IN: openal.other
kernel openal openal.alut.backend ;
IN: openal.alut.other
LIBRARY: alut

2
extra/openal/example/example.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar kernel openal sequences threads ;
USING: calendar kernel openal openal.alut sequences threads ;
IN: openal.example
: play-hello ( -- )

95
extra/openal/openal.factor Normal file → Executable file
View File

@ -2,20 +2,12 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors arrays alien system combinators
alien.syntax namespaces alien.c-types sequences vocabs.loader
shuffle openal.backend alien.libraries generalizations
shuffle alien.libraries generalizations
specialized-arrays alien.destructors ;
FROM: alien.c-types => float short ;
SPECIALIZED-ARRAY: uint
IN: openal
<< "alut" {
{ [ os windows? ] [ "alut.dll" ] }
{ [ os macosx? ] [
"/System/Library/Frameworks/OpenAL.framework/OpenAL"
] }
{ [ os unix? ] [ "libalut.so" ] }
} cond "cdecl" add-library >>
<< "openal" {
{ [ os windows? ] [ "OpenAL32.dll" ] }
{ [ os macosx? ] [
@ -24,7 +16,7 @@ IN: openal
{ [ os unix? ] [ "libopenal.so" ] }
} cond "cdecl" add-library >>
<< os macosx? [ "openal" deploy-library "alut" deploy-library ] unless >>
<< os macosx? [ "openal" deploy-library ] unless >>
LIBRARY: openal
@ -254,71 +246,6 @@ FUNCTION: void alcCaptureSamples ( ALCdevice* device, void* buf, ALCsizei samps
DESTRUCTOR: alcCloseDevice*
DESTRUCTOR: alcDestroyContext
LIBRARY: alut
CONSTANT: ALUT_API_MAJOR_VERSION 1
CONSTANT: ALUT_API_MINOR_VERSION 1
CONSTANT: ALUT_ERROR_NO_ERROR 0
CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200
CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201
CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202
CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203
CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204
CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205
CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206
CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207
CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208
CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209
CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A
CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B
CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C
CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D
CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E
CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F
CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210
CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211
CONSTANT: ALUT_WAVEFORM_SINE HEX: 100
CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101
CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102
CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103
CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104
CONSTANT: ALUT_LOADER_BUFFER HEX: 300
CONSTANT: ALUT_LOADER_MEMORY HEX: 301
FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ;
FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ;
FUNCTION: ALboolean alutExit ( ) ;
FUNCTION: ALenum alutGetError ( ) ;
FUNCTION: char* alutGetErrorString ( ALenum error ) ;
FUNCTION: ALuint alutCreateBufferFromFile ( char* fileName ) ;
FUNCTION: ALuint alutCreateBufferFromFileImage ( void* data, ALsizei length ) ;
FUNCTION: ALuint alutCreateBufferHelloWorld ( ) ;
FUNCTION: ALuint alutCreateBufferWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration ) ;
FUNCTION: void* alutLoadMemoryFromFile ( char* fileName, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
FUNCTION: void* alutLoadMemoryFromFileImage ( void* data, ALsizei length, ALenum* format, ALsizei* size, ALfloat* frequency ) ;
FUNCTION: void* alutLoadMemoryHelloWorld ( ALenum* format, ALsizei* size, ALfloat* frequency ) ;
FUNCTION: void* alutLoadMemoryWaveform ( ALenum waveshape, ALfloat frequency, ALfloat phase, ALfloat duration, ALenum* format, ALsizei* size, ALfloat* freq ) ;
FUNCTION: char* alutGetMIMETypes ( ALenum loader ) ;
FUNCTION: ALint alutGetMajorVersion ( ) ;
FUNCTION: ALint alutGetMinorVersion ( ) ;
FUNCTION: ALboolean alutSleep ( ALfloat duration ) ;
FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei frequency ) ;
SYMBOL: init
: init-openal ( -- )
init get-global expired? [
f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when
1337 <alien> init set-global
] when ;
: exit-openal ( -- )
init get-global expired? [
alutExit 0 = [ "Could not close OpenAL" throw ] when
f init set-global
] unless ;
: gen-sources ( size -- seq )
dup <uint-array> [ alGenSources ] keep ;
@ -327,17 +254,6 @@ SYMBOL: init
: gen-buffer ( -- buffer ) 1 gen-buffers first ;
: create-buffer-from-file ( filename -- buffer )
alutCreateBufferFromFile dup AL_NONE = [
"create-buffer-from-file failed" throw
] when ;
os macosx? "openal.macosx" "openal.other" ? require
: create-buffer-from-wav ( filename -- buffer )
gen-buffer dup rot load-wav-file
[ alBufferData ] 4 nkeep alutUnloadWAV ;
: queue-buffers ( source buffers -- )
[ length ] [ >uint-array ] bi alSourceQueueBuffers ;
@ -360,12 +276,5 @@ os macosx? "openal.macosx" "openal.other" ? require
: source-stop ( source -- ) alSourceStop ;
: check-error ( -- )
alGetError dup ALUT_ERROR_NO_ERROR = [
drop
] [
alGetString throw
] if ;
: source-playing? ( source -- bool )
AL_SOURCE_STATE get-source-param AL_PLAYING = ;

1
extra/space-invaders/space-invaders.factor Normal file → Executable file
View File

@ -18,6 +18,7 @@ USING:
math
math.order
openal
openal.alut
opengl.gl
sequences
ui

2
extra/synth/example/example.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel namespaces make openal sequences
USING: accessors arrays kernel namespaces make openal openal.alut sequences
synth synth.buffers ;
IN: synth.example

2
extra/synth/synth.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel locals math math.constants math.functions memoize openal synth.buffers sequences sequences.modified sequences.repeating ;
USING: accessors kernel locals math math.constants math.functions memoize openal openal.alut synth.buffers sequences sequences.modified sequences.repeating ;
IN: synth
MEMO: single-sine-wave ( samples/wave -- seq )