-!IF DEFINED(DEBUG)\r
-LINK_FLAGS = /nologo /DEBUG shell32.lib\r
-CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG\r
-!ELSE\r
-LINK_FLAGS = /nologo shell32.lib\r
-CL_FLAGS = /nologo /O2 /W3\r
-!ENDIF\r
-\r
-EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res\r
-\r
-DLL_OBJS = vm\os-windows-nt.obj \\r
- vm\os-windows.obj \\r
- vm\aging_collector.obj \\r
- vm\alien.obj \\r
- vm\arrays.obj \\r
- vm\bignum.obj \\r
- vm\booleans.obj \\r
- vm\byte_arrays.obj \\r
- vm\callbacks.obj \\r
- vm\callstack.obj \\r
- vm\code_blocks.obj \\r
- vm\code_heap.obj \\r
- vm\compaction.obj \\r
- vm\contexts.obj \\r
- vm\data_heap.obj \\r
- vm\data_heap_checker.obj \\r
- vm\debug.obj \\r
- vm\dispatch.obj \\r
- vm\entry_points.obj \\r
- vm\errors.obj \\r
- vm\factor.obj \\r
- vm\free_list.obj \\r
- vm\full_collector.obj \\r
- vm\gc.obj \\r
- vm\image.obj \\r
- vm\inline_cache.obj \\r
- vm\instruction_operands.obj \\r
- vm\io.obj \\r
- vm\jit.obj \\r
- vm\math.obj \\r
- vm\nursery_collector.obj \\r
- vm\object_start_map.obj \\r
- vm\objects.obj \\r
- vm\primitives.obj \\r
- vm\profiler.obj \\r
- vm\quotations.obj \\r
- vm\run.obj \\r
- vm\strings.obj \\r
- vm\to_tenured_collector.obj \\r
- vm\tuples.obj \\r
- vm\utilities.obj \\r
- vm\vm.obj \\r
- vm\words.obj\r
-\r
-.cpp.obj:\r
- cl /EHsc $(CL_FLAGS) /Fo$@ /c $<\r
-\r
-.c.obj:\r
- cl $(CL_FLAGS) /Fo$@ /c $<\r
-\r
-.rs.res:\r
- rc $<\r
-\r
-all: factor.com factor.exe\r
-\r
-libfactor-ffi-test.dll: vm/ffi_test.obj\r
- link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj\r
-\r
-factor.dll.lib: $(DLL_OBJS)\r
- link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)\r
-\r
-factor.com: $(EXE_OBJS)\r
- link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)\r
-\r
-factor.exe: $(EXE_OBJS)\r
- link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)\r
-\r
-clean:\r
- del vm\*.obj\r
- del factor.lib\r
- del factor.com\r
- del factor.exe\r
- del factor.dll\r
- del factor.dll.lib\r
-\r
-.PHONY: all clean\r
-\r
-.SUFFIXES: .rs\r
+!IF DEFINED(DEBUG)
+LINK_FLAGS = /nologo /DEBUG shell32.lib
+CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
+!ELSE
+LINK_FLAGS = /nologo shell32.lib
+CL_FLAGS = /nologo /O2 /W3
+!ENDIF
+
+EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
+
+DLL_OBJS = vm\os-windows-nt.obj \
+ vm\os-windows.obj \
+ vm\aging_collector.obj \
+ vm\alien.obj \
+ vm\arrays.obj \
+ vm\bignum.obj \
+ vm\booleans.obj \
+ vm\byte_arrays.obj \
+ vm\callbacks.obj \
+ vm\callstack.obj \
+ vm\code_blocks.obj \
+ vm\code_heap.obj \
+ vm\compaction.obj \
+ vm\contexts.obj \
+ vm\data_heap.obj \
+ vm\data_heap_checker.obj \
+ vm\debug.obj \
+ vm\dispatch.obj \
+ vm\entry_points.obj \
+ vm\errors.obj \
+ vm\factor.obj \
+ vm\free_list.obj \
+ vm\full_collector.obj \
+ vm\gc.obj \
+ vm\image.obj \
+ vm\inline_cache.obj \
+ vm\instruction_operands.obj \
+ vm\io.obj \
+ vm\jit.obj \
+ vm\math.obj \
+ vm\nursery_collector.obj \
+ vm\object_start_map.obj \
+ vm\objects.obj \
+ vm\primitives.obj \
+ vm\profiler.obj \
+ vm\quotations.obj \
+ vm\run.obj \
+ vm\strings.obj \
+ vm\to_tenured_collector.obj \
+ vm\tuples.obj \
+ vm\utilities.obj \
+ vm\vm.obj \
+ vm\words.obj
+
+.cpp.obj:
+ cl /EHsc $(CL_FLAGS) /Fo$@ /c $<
+
+.c.obj:
+ cl $(CL_FLAGS) /Fo$@ /c $<
+
+.rs.res:
+ rc $<
+
+all: factor.com factor.exe libfactor-ffi-test.dll
+
+libfactor-ffi-test.dll: vm/ffi_test.obj
+ link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
+
+factor.dll.lib: $(DLL_OBJS)
+ link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
+
+factor.com: $(EXE_OBJS)
+ link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
+
+factor.exe: $(EXE_OBJS)
+ link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
+
+clean:
+ del vm\*.obj
+ del factor.lib
+ del factor.com
+ del factor.exe
+ del factor.dll
+ del factor.dll.lib
+
+.PHONY: all clean
+
+.SUFFIXES: .rs
[ resolve-pointer-type ] [ drop void* ] if
] if ;
+M: array resolve-pointer-type
+ first resolve-pointer-type ;
+
: resolve-typedef ( name -- c-type )
dup void? [ no-c-type ] when
dup c-type-name? [ c-type ] when ;
alien.data alien.fortran alien.fortran.private alien.strings
classes.struct arrays assocs byte-arrays combinators fry
generalizations io.encodings.ascii kernel macros
-macros.expander namespaces sequences shuffle tools.test ;
+macros.expander namespaces sequences shuffle tools.test vocabs.parser ;
+QUALIFIED-WITH: alien.c-types c
IN: alien.fortran.tests
<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
LIBRARY: (alien.fortran-tests)
-STRUCT: FORTRAN_TEST_RECORD
+STRUCT: fortran_test_record
{ FOO int }
{ BAR double[2] }
{ BAS char[4] } ;
! fortran-type>c-type
- [ "short" ]
+ [ c:short ]
[ "integer*2" fortran-type>c-type ] unit-test
- [ "int" ]
+ [ c:int ]
[ "integer*4" fortran-type>c-type ] unit-test
- [ "int" ]
+ [ c:int ]
[ "INTEGER" fortran-type>c-type ] unit-test
- [ "longlong" ]
+ [ c:longlong ]
[ "iNteger*8" fortran-type>c-type ] unit-test
- [ "int[0]" ]
+ [ { c:int 0 } ]
[ "integer(*)" fortran-type>c-type ] unit-test
- [ "int[0]" ]
+ [ { c:int 0 } ]
[ "integer(3,*)" fortran-type>c-type ] unit-test
- [ "int[3]" ]
+ [ { c:int 3 } ]
[ "integer(3)" fortran-type>c-type ] unit-test
- [ "int[6]" ]
+ [ { c:int 6 } ]
[ "integer(3,2)" fortran-type>c-type ] unit-test
- [ "int[24]" ]
+ [ { c:int 24 } ]
[ "integer(4,3,2)" fortran-type>c-type ] unit-test
- [ "char" ]
+ [ c:char ]
[ "character" fortran-type>c-type ] unit-test
- [ "char" ]
+ [ c:char ]
[ "character*1" fortran-type>c-type ] unit-test
- [ "char[17]" ]
+ [ { c:char 17 } ]
[ "character*17" fortran-type>c-type ] unit-test
- [ "char[17]" ]
+ [ { c:char 17 } ]
[ "character(17)" fortran-type>c-type ] unit-test
- [ "int" ]
+ [ c:int ]
[ "logical" fortran-type>c-type ] unit-test
- [ "float" ]
+ [ c:float ]
[ "real" fortran-type>c-type ] unit-test
- [ "double" ]
+ [ c:double ]
[ "double-precision" fortran-type>c-type ] unit-test
- [ "float" ]
+ [ c:float ]
[ "real*4" fortran-type>c-type ] unit-test
- [ "double" ]
+ [ c:double ]
[ "real*8" fortran-type>c-type ] unit-test
- [ "complex-float" ]
+ [ complex-float ]
[ "complex" fortran-type>c-type ] unit-test
- [ "complex-double" ]
+ [ complex-double ]
[ "double-complex" fortran-type>c-type ] unit-test
- [ "complex-float" ]
+ [ complex-float ]
[ "complex*8" fortran-type>c-type ] unit-test
- [ "complex-double" ]
+ [ complex-double ]
[ "complex*16" fortran-type>c-type ] unit-test
- [ "fortran_test_record" ]
- [ "fortran_test_record" fortran-type>c-type ] unit-test
+ [ fortran_test_record ]
+ [
+ [
+ "alien.fortran.tests" use-vocab
+ "fortran_test_record" fortran-type>c-type
+ ] with-manifest
+ ] unit-test
! fortran-arg-type>c-type
- [ "int*" { } ]
+ [ c:void* { } ]
[ "integer" fortran-arg-type>c-type ] unit-test
- [ "int*" { } ]
+ [ c:void* { } ]
[ "integer(3)" fortran-arg-type>c-type ] unit-test
- [ "int*" { } ]
+ [ c:void* { } ]
[ "integer(*)" fortran-arg-type>c-type ] unit-test
- [ "fortran_test_record*" { } ]
- [ "fortran_test_record" fortran-arg-type>c-type ] unit-test
+ [ c:void* { } ]
+ [
+ [
+ "alien.fortran.tests" use-vocab
+ "fortran_test_record" fortran-arg-type>c-type
+ ] with-manifest
+ ] unit-test
- [ "char*" { } ]
+ [ c:char* { } ]
[ "character" fortran-arg-type>c-type ] unit-test
- [ "char*" { } ]
+ [ c:char* { } ]
[ "character(1)" fortran-arg-type>c-type ] unit-test
- [ "char*" { "long" } ]
+ [ c:char* { long } ]
[ "character(17)" fortran-arg-type>c-type ] unit-test
! fortran-ret-type>c-type
- [ "char" { } ]
+ [ c:char { } ]
[ "character(1)" fortran-ret-type>c-type ] unit-test
- [ "void" { "char*" "long" } ]
+ [ c:void { c:char* long } ]
[ "character(17)" fortran-ret-type>c-type ] unit-test
- [ "int" { } ]
+ [ c:int { } ]
[ "integer" fortran-ret-type>c-type ] unit-test
- [ "int" { } ]
+ [ c:int { } ]
[ "logical" fortran-ret-type>c-type ] unit-test
- [ "float" { } ]
+ [ c:float { } ]
[ "real" fortran-ret-type>c-type ] unit-test
- [ "void" { "float*" } ]
+ [ c:void { c:void* } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
- [ "double" { } ]
+ [ c:double { } ]
[ "double-precision" fortran-ret-type>c-type ] unit-test
- [ "void" { "complex-float*" } ]
+ [ c:void { c:void* } ]
[ "complex" fortran-ret-type>c-type ] unit-test
- [ "void" { "complex-double*" } ]
+ [ c:void { c:void* } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
- [ "void" { "int*" } ]
+ [ c:void { c:void* } ]
[ "integer(*)" fortran-ret-type>c-type ] unit-test
- [ "void" { "fortran_test_record*" } ]
- [ "fortran_test_record" fortran-ret-type>c-type ] unit-test
+ [ c:void { c:void* } ]
+ [
+ [
+ "alien.fortran.tests" use-vocab
+ "fortran_test_record" fortran-ret-type>c-type
+ ] with-manifest
+ ] unit-test
! fortran-sig>c-sig
- [ "float" { "int*" "char*" "float*" "double*" "long" } ]
+ [ c:float { c:void* c:char* c:void* c:void* c:long } ]
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
unit-test
- [ "char" { "char*" "char*" "int*" "long" } ]
+ [ c:char { c:char* c:char* c:void* c:long } ]
[ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
- [ "void" { "char*" "long" "char*" "char*" "int*" "long" } ]
+ [ c:void { c:char* c:long c:char* c:char* c:void* c:long } ]
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
- [ "void" { "complex-float*" "char*" "char*" "int*" "long" } ]
+ [ c:void { c:void* c:char* c:char* c:void* c:long } ]
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
unit-test
} 5 ncleave
! [fortran-invoke]
[
- "void" "funpack" "funtimes_"
- { "char*" "longlong*" "float*" "complex-float*" "short*" "long" }
+ c:void "funpack" "funtimes_"
+ { c:char* c:void* c:void* c:void* c:void* c:long }
alien-invoke
] 6 nkeep
! [fortran-results>]
[ { [ drop ] } spread ]
} 1 ncleave
! [fortran-invoke]
- [ "float" "funpack" "fun_times_" { "float*" } alien-invoke ]
+ [ c:float "funpack" "fun_times_" { void* } alien-invoke ]
1 nkeep
! [fortran-results>]
shuffle( reta aa -- reta aa )
[ [
! [<fortran-result>]
- [ "complex-float" <c-object> ] 1 ndip
+ [ complex-float <c-object> ] 1 ndip
! [fortran-args>c-args]
{ [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
! [fortran-invoke]
[
- "void" "funpack" "fun_times_"
- { "complex-float*" "float*" }
+ c:void "funpack" "fun_times_"
+ { void* void* }
alien-invoke
] 2 nkeep
! [fortran-results>]
[ 20 <byte-array> 20 ] 0 ndip
! [fortran-invoke]
[
- "void" "funpack" "fun_times_"
- { "char*" "long" }
+ c:void "funpack" "fun_times_"
+ { c:char* long }
alien-invoke
] 2 nkeep
! [fortran-results>]
} 3 ncleave
! [fortran-invoke]
[
- "void" "funpack" "fun_times_"
- { "char*" "long" "char*" "float*" "char*" "long" "long" }
+ c:void "funpack" "fun_times_"
+ { c:char* long c:char* c:void* c:char* c:long c:long }
alien-invoke
] 7 nkeep
! [fortran-results>]
f2c-abi fortran-abi [
- [ "char[1]" ]
+ [ { c:char 1 } ]
[ "character(1)" fortran-type>c-type ] unit-test
- [ "char*" { "long" } ]
+ [ c:char* { c:long } ]
[ "character" fortran-arg-type>c-type ] unit-test
- [ "void" { "char*" "long" } ]
+ [ c:void { c:char* c:long } ]
[ "character" fortran-ret-type>c-type ] unit-test
- [ "double" { } ]
+ [ c:double { } ]
[ "real" fortran-ret-type>c-type ] unit-test
- [ "void" { "float*" } ]
+ [ c:void { void* } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
gfortran-abi fortran-abi [
- [ "float" { } ]
+ [ c:float { } ]
[ "real" fortran-ret-type>c-type ] unit-test
- [ "void" { "float*" } ]
+ [ c:void { void* } ]
[ "real(*)" fortran-ret-type>c-type ] unit-test
- [ "complex-float" { } ]
+ [ complex-float { } ]
[ "complex" fortran-ret-type>c-type ] unit-test
- [ "complex-double" { } ]
+ [ complex-double { } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
- [ "char[1]" ]
+ [ { char 1 } ]
[ "character(1)" fortran-type>c-type ] unit-test
- [ "char*" { "long" } ]
+ [ c:char* { c:long } ]
[ "character" fortran-arg-type>c-type ] unit-test
- [ "void" { "char*" "long" } ]
+ [ c:void { c:char* c:long } ]
[ "character" fortran-ret-type>c-type ] unit-test
- [ "complex-float" { } ]
+ [ complex-float { } ]
[ "complex" fortran-ret-type>c-type ] unit-test
- [ "complex-double" { } ]
+ [ complex-double { } ]
[ "double-complex" fortran-ret-type>c-type ] unit-test
- [ "void" { "complex-double*" } ]
+ [ c:void { c:void* } ]
[ "double-complex(3)" fortran-ret-type>c-type ] unit-test
] with-variable
! (c) 2009 Joe Groff, see BSD license
-USING: accessors alien alien.c-types alien.complex alien.data grouping
-alien.strings alien.syntax arrays ascii assocs
+USING: accessors alien alien.c-types alien.complex alien.data alien.parser
+grouping alien.strings alien.syntax arrays ascii assocs
byte-arrays combinators combinators.short-circuit fry generalizations
kernel lexer macros math math.parser namespaces parser sequences
splitting stack-checker vectors vocabs.parser words locals
io.encodings.ascii io.encodings.string shuffle effects math.ranges
math.order sorting strings system alien.libraries ;
+QUALIFIED-WITH: alien.c-types c
IN: alien.fortran
SINGLETONS: f2c-abi g95-abi gfortran-abi intel-unix-abi intel-windows-abi ;
}
: append-dimensions ( base-c-type type -- c-type )
- dims>>
- [ product number>string "[" "]" surround append ] when* ;
+ dims>> [ product 2array ] when* ;
MACRO: size-case-type ( cases -- )
[ invalid-fortran-type ] suffix
GENERIC: (fortran-type>c-type) ( type -- c-type )
-M: f (fortran-type>c-type) drop "void" ;
+M: f (fortran-type>c-type) drop c:void ;
M: integer-type (fortran-type>c-type)
{
- { f [ "int" ] }
- { 1 [ "char" ] }
- { 2 [ "short" ] }
- { 4 [ "int" ] }
- { 8 [ "longlong" ] }
+ { f [ c:int ] }
+ { 1 [ c:char ] }
+ { 2 [ c:short ] }
+ { 4 [ c:int ] }
+ { 8 [ c:longlong ] }
} size-case-type ;
M: real-type (fortran-type>c-type)
{
- { f [ "float" ] }
- { 4 [ "float" ] }
- { 8 [ "double" ] }
+ { f [ c:float ] }
+ { 4 [ c:float ] }
+ { 8 [ c:double ] }
} size-case-type ;
M: real-complex-type (fortran-type>c-type)
{
- { f [ "complex-float" ] }
- { 8 [ "complex-float" ] }
- { 16 [ "complex-double" ] }
+ { f [ complex-float ] }
+ { 8 [ complex-float ] }
+ { 16 [ complex-double ] }
} size-case-type ;
M: double-precision-type (fortran-type>c-type)
- "double" simple-type ;
+ c:double simple-type ;
M: double-complex-type (fortran-type>c-type)
- "complex-double" simple-type ;
+ complex-double simple-type ;
M: misc-type (fortran-type>c-type)
- dup name>> simple-type ;
+ dup name>> parse-c-type simple-type ;
: single-char? ( character-type -- ? )
{ [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;
dup single-char? [ f >>dims ] when ;
M: character-type (fortran-type>c-type)
- fix-character-type "char" simple-type ;
+ fix-character-type c:char simple-type ;
: dimension>number ( string -- number )
dup "*" = [ drop 0 ] [ string>number ] if ;
: parse-fortran-type ( fortran-type-string/f -- type/f )
dup [ (parse-fortran-type) ] when ;
-: c-type>pointer ( c-type -- c-type* )
- "[" split1 drop "*" append ;
-
GENERIC: added-c-args ( type -- args )
M: fortran-type added-c-args drop { } ;
-M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ;
+M: character-type added-c-args fix-character-type single-char? [ { } ] [ { c:long } ] if ;
GENERIC: returns-by-value? ( type -- ? )
GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
-M: f (fortran-ret-type>c-type) drop "void" ;
+M: f (fortran-ret-type>c-type) drop c:void ;
M: fortran-type (fortran-ret-type>c-type) (fortran-type>c-type) ;
M: real-type (fortran-ret-type>c-type)
- drop real-functions-return-double? [ "double" ] [ "float" ] if ;
+ drop real-functions-return-double? [ c:double ] [ c:float ] if ;
GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
: (shuffle-map) ( return parameters -- ret par )
[
- fortran-ret-type>c-type length swap "void" = [ 1 + ] unless
+ fortran-ret-type>c-type length swap void? [ 1 + ] unless
letters swap head [ "ret" swap suffix ] map
] [
[ fortran-arg-type>c-type nip length 1 + ] map letters swap zip
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type
- [ (fortran-type>c-type) c-type>pointer ]
+ [ (fortran-type>c-type) resolve-pointer-type ]
[ added-c-args ] bi ;
: fortran-ret-type>c-type ( fortran-type -- c-type added-args )
parse-fortran-type dup returns-by-value?
[ (fortran-ret-type>c-type) { } ] [
- "void" swap
- [ added-c-args ] [ (fortran-type>c-type) c-type>pointer ] bi prefix
+ c:void swap
+ [ added-c-args ] [ (fortran-type>c-type) resolve-pointer-type ] bi prefix
] if ;
: fortran-arg-types>c-types ( fortran-types -- c-types )
:: define-fortran-function ( return library function parameters -- )
function create-in dup reset-generic
- return library function parameters return [ "void" ] unless* parse-arglist
+ return library function parameters return [ c:void ] unless* parse-arglist
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
SYNTAX: SUBROUTINE:
io.pathnames kernel kernel.private math namespaces make parser
prettyprint sequences strings sbufs vectors words quotations
assocs system layouts splitting grouping growable classes
-classes.builtin classes.tuple classes.tuple.private vocabs
-vocabs.loader source-files definitions debugger
-quotations.private combinators combinators.short-circuit
-math.order math.private accessors slots.private
-generic.single.private compiler.units compiler.constants fry
-locals bootstrap.image.syntax generalizations ;
+classes.private classes.builtin classes.tuple
+classes.tuple.private vocabs vocabs.loader source-files
+definitions debugger quotations.private combinators
+combinators.short-circuit math.order math.private accessors
+slots.private generic.single.private compiler.units
+compiler.constants fry locals bootstrap.image.syntax
+generalizations ;
IN: bootstrap.image
: arch ( os cpu -- arch )
: t, ( -- ) t t-offset fixup ;
-M: f '
- #! f is #define F RETAG(0,F_TYPE)
- drop \ f type-number ;
+M: f ' drop \ f type-number ;
: 0, ( -- ) 0 >bignum ' 0-offset fixup ;
: 1, ( -- ) 1 >bignum ' 1-offset fixup ;
: fixup-header ( -- )
heap-size data-heap-size-offset fixup ;
+: build-generics ( -- )
+ [
+ all-words
+ [ generic? ] filter
+ [ make-generic ] each
+ ] with-compilation-unit ;
+
: build-image ( -- image )
800000 <vector> image set
20000 <hashtable> objects set
emit-image-header t, 0, 1, -1,
"Building generic words..." print flush
- remake-generics
+ build-generics
"Serializing words..." print flush
emit-words
"Serializing JIT data..." print flush
! (c)Joe Groff, Daniel Ehrenberg bsd license
-USING: accessors alien alien.c-types alien.data alien.parser arrays
-byte-arrays classes classes.parser classes.tuple classes.tuple.parser
-classes.tuple.private combinators combinators.short-circuit
-combinators.smart cpu.architecture definitions functors.backend
-fry generalizations generic.parser kernel kernel.private lexer
-libc locals macros make math math.order parser quotations
-sequences slots slots.private specialized-arrays vectors words
-summary namespaces assocs vocabs.parser math.functions
+USING: accessors alien alien.c-types alien.data alien.parser
+arrays byte-arrays classes classes.private classes.parser
+classes.tuple classes.tuple.parser classes.tuple.private
+combinators combinators.short-circuit combinators.smart
+cpu.architecture definitions functors.backend fry
+generalizations generic.parser kernel kernel.private lexer libc
+locals macros make math math.order parser quotations sequences
+slots slots.private specialized-arrays vectors words summary
+namespaces assocs vocabs.parser math.functions
classes.struct.bit-accessors bit-arrays ;
QUALIFIED: math
IN: classes.struct
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test combinators.smart math kernel accessors ;
+USING: accessors arrays combinators.smart kernel math
+tools.test ;
IN: combinators.smart.tests
: test-bi ( -- 9 11 )
{ 2 0 } [ [ + ] nullary ] must-infer-as
{ 2 2 } [ [ [ + ] nullary ] preserving ] must-infer-as
+
+: smart-if-test ( a b -- b )
+ [ < ] [ swap - ] [ - ] smart-if ;
+
+[ 7 ] [ 10 3 smart-if-test ] unit-test
+[ 16 ] [ 25 41 smart-if-test ] unit-test
+
+[ { 1 2 } { 3 4 } { 5 6 } ] [ 1 2 3 4 5 6 [ 2array ] 3 smart-apply ] unit-test
+[ { 1 2 3 } { 4 5 6 } ] [ 1 2 3 4 5 6 [ 3array ] 2 smart-apply ] unit-test
dup outputs '[ @ _ ndrop ] ;
MACRO: smart-if ( pred true false -- )
- '[ _ preserving _ _ if ] ; inline
+ '[ _ preserving _ _ if ] ;
+
+MACRO: smart-apply ( quot n -- )
+ [ dup inputs ] dip '[ _ _ _ mnapply ] ;
{ (simd-select) [ emit-simd-select ] }
{ alien-vector [ emit-alien-vector ] }
{ set-alien-vector [ emit-set-alien-vector ] }
+ { assert-positive [ drop ] }
} enable-intrinsics ;
enable-simd
combinators classes.algebra alien alien.c-types
alien.strings alien.arrays alien.complex alien.libraries sets libc
continuations.private fry cpu.architecture classes classes.struct locals
-source-files.errors slots parser generic.parser
+source-files.errors slots parser generic.parser strings
compiler.errors
compiler.alien
compiler.constants
: box-return* ( node -- )
return>> [ ] [ box-return %push-stack ] if-void ;
+GENERIC# dlsym-valid? 1 ( symbols dll -- ? )
+
+M: string dlsym-valid? dlsym ;
+
+M: array dlsym-valid? '[ _ dlsym ] any? ;
+
: check-dlsym ( symbols dll -- )
dup dll-valid? [
- dupd '[ _ dlsym ] any?
+ dupd dlsym-valid?
[ drop ] [ compiling-word get no-such-symbol ] if
] [
dll-path compiling-word get no-such-library drop
] if ;
-: stdcall-mangle ( symbol params -- symbol )
- parameters>> parameter-offsets drop number>string "@" glue ;
+: stdcall-mangle ( params -- symbols )
+ [ function>> ] [ parameters>> parameter-offsets drop number>string ] bi
+ [ drop ] [ "@" glue ] [ "@" glue "_" prepend ] 2tri
+ 3array ;
: alien-invoke-dlsym ( params -- symbols dll )
- [ [ function>> dup ] keep stdcall-mangle 2array ]
- [ library>> library dup [ dll>> ] when ]
+ [ dup abi>> "stdcall" = [ stdcall-mangle ] [ function>> ] if ]
+ [ library>> load-library ]
bi 2dup check-dlsym ;
M: ##alien-invoke generate-insn
USING: accessors kernel namespaces arrays sequences io words fry
continuations vocabs assocs dlists definitions math graphs generic
generic.single combinators deques search-deques macros
-source-files.errors combinators.short-circuit
+source-files.errors combinators.short-circuit classes.algebra
stack-checker stack-checker.dependencies stack-checker.inlining
stack-checker.errors
-compiler.errors compiler.units compiler.utilities
+compiler.errors compiler.units compiler.utilities compiler.crossref
compiler.tree.builder
compiler.tree.optimizer
-compiler.crossref
-
compiler.cfg
compiler.cfg.builder
compiler.cfg.optimizer
: recompile-callers? ( word -- ? )
changed-effects get key? ;
-: recompile-callers ( words -- )
- #! If a word's stack effect changed, recompile all words that
- #! have compiled calls to it.
+: recompile-callers ( word -- )
+ #! If a word's stack effect changed, recompile all words
+ #! that have compiled calls to it.
dup recompile-callers?
- [ compiled-usage keys [ queue-compile ] each ] [ drop ] if ;
+ [ effect-dependencies-of keys [ queue-compile ] each ] [ drop ] if ;
: compiler-message ( string -- )
"trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ;
: start ( word -- )
dup name>> compiler-message
- H{ } clone dependencies set
- H{ } clone generic-dependencies set
+ init-dependencies
clear-compiler-error ;
GENERIC: no-compile? ( word -- ? )
[ compiled-unxref ]
[
dup crossref? [
- dependencies get
- generic-dependencies get
- compiled-xref
+ [ dependencies get generic-dependencies get compiled-xref ]
+ [ conditional-dependencies get set-dependency-checks ]
+ bi
] [ drop ] if
] tri ;
: deoptimize-with ( word def -- * )
#! If the word failed to infer, compile it with the
- #! non-optimizing compiler.
+ #! non-optimizing compiler.
swap [ finish ] [ compiled get set-at ] bi return ;
: not-compiled-def ( word error -- def )
SINGLETON: optimizing-compiler
+M: optimizing-compiler update-call-sites ( class generic -- words )
+ #! Words containing call sites with inferred type 'class'
+ #! which inlined a method on 'generic'
+ generic-call-sites-of swap '[
+ nip _ 2dup [ classoid? ] both?
+ [ classes-intersect? ] [ 2drop f ] if
+ ] assoc-filter keys ;
+
M: optimizing-compiler recompile ( words -- alist )
[
<hashed-dlist> compile-queue set
M: optimizing-compiler to-recompile ( -- words )
changed-definitions get compiled-usages
- changed-generics get compiled-generic-usages
+ maybe-changed get outdated-conditional-usages
append assoc-combine keys ;
M: optimizing-compiler process-forgotten-words
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes.algebra compiler.units definitions graphs
-grouping kernel namespaces sequences words
-stack-checker.dependencies ;
+USING: arrays assocs classes.algebra compiler.units definitions
+graphs grouping kernel namespaces sequences words fry
+stack-checker.dependencies combinators ;
IN: compiler.crossref
SYMBOL: compiled-crossref
compiled-crossref [ H{ } clone ] initialize
-SYMBOL: compiled-generic-crossref
+SYMBOL: generic-call-site-crossref
-compiled-generic-crossref [ H{ } clone ] initialize
+generic-call-site-crossref [ H{ } clone ] initialize
-: compiled-usage ( word -- assoc )
+: effect-dependencies-of ( word -- assoc )
compiled-crossref get at ;
-: (compiled-usages) ( word -- assoc )
- #! If the word is not flushable anymore, we have to recompile
- #! all words which flushable away a call (presumably when the
- #! word was still flushable). If the word is flushable, we
- #! don't have to recompile words that folded this away.
- [ compiled-usage ]
- [ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
- [ dependency>= nip ] curry assoc-filter ;
+: definition-dependencies-of ( word -- assoc )
+ effect-dependencies-of [ nip definition-dependency dependency>= ] assoc-filter ;
-: compiled-usages ( seq -- assocs )
+: conditional-dependencies-of ( word -- assoc )
+ effect-dependencies-of [ nip conditional-dependency dependency>= ] assoc-filter ;
+
+: compiled-usages ( assoc -- assocs )
[ drop word? ] assoc-filter
- [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
+ [ [ drop definition-dependencies-of ] { } assoc>map ] keep suffix ;
+
+: dependencies-satisfied? ( word cache -- ? )
+ [ "dependency-checks" word-prop ] dip
+ '[ _ [ satisfied? ] cache ] all? ;
+
+: outdated-conditional-usages ( assoc -- assocs )
+ H{ } clone '[
+ drop
+ conditional-dependencies-of
+ [ drop _ dependencies-satisfied? not ] assoc-filter
+ ] { } assoc>map ;
+
+: generic-call-sites-of ( word -- assoc )
+ generic-call-site-crossref get at ;
+
+: only-xref ( assoc -- assoc' )
+ [ drop crossref? ] { } assoc-filter-as ;
+
+: set-generic-call-sites ( word alist -- )
+ concat f like "generic-call-sites" set-word-prop ;
-: compiled-generic-usage ( word -- assoc )
- compiled-generic-crossref get at ;
+: split-dependencies ( assoc -- effect-deps cond-deps def-deps )
+ [ nip effect-dependency eq? ] assoc-partition
+ [ nip conditional-dependency eq? ] assoc-partition ;
-: (compiled-generic-usages) ( generic class -- assoc )
- [ compiled-generic-usage ] dip
- [
- 2dup [ valid-class? ] both?
- [ classes-intersect? ] [ 2drop f ] if nip
- ] curry assoc-filter ;
+: (store-dependencies) ( word assoc prop -- )
+ [ keys f like ] dip set-word-prop ;
-: compiled-generic-usages ( assoc -- assocs )
- [ (compiled-generic-usages) ] { } assoc>map ;
+: store-dependencies ( word assoc -- )
+ split-dependencies
+ "effect-dependencies" "conditional-dependencies" "definition-dependencies"
+ [ (store-dependencies) ] tri-curry@ tri-curry* tri ;
-: (compiled-xref) ( word dependencies word-prop variable -- )
- [ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
+: (compiled-xref) ( word dependencies generic-dependencies -- )
+ compiled-crossref generic-call-site-crossref
+ [ get add-vertex* ] bi-curry@ bi-curry* bi ;
: compiled-xref ( word dependencies generic-dependencies -- )
- [ [ drop crossref? ] { } assoc-filter-as ] bi@
- [ "compiled-uses" compiled-crossref (compiled-xref) ]
- [ "compiled-generic-uses" compiled-generic-crossref (compiled-xref) ]
- bi-curry* bi ;
+ [ only-xref ] bi@
+ [ nip set-generic-call-sites ]
+ [ drop store-dependencies ]
+ [ (compiled-xref) ]
+ 3tri ;
-: (compiled-unxref) ( word word-prop variable -- )
- [ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
- [ drop [ remove-word-prop ] curry ]
- 2bi bi ;
+: set-at-each ( keys assoc value -- )
+ '[ _ [ _ ] 2dip set-at ] each ;
+
+: join-dependencies ( effect-deps cond-deps def-deps -- assoc )
+ H{ } clone [
+ [ effect-dependency set-at-each ]
+ [ conditional-dependency set-at-each ]
+ [ definition-dependency set-at-each ] tri-curry tri*
+ ] keep ;
+
+: load-dependencies ( word -- assoc )
+ [ "effect-dependencies" word-prop ]
+ [ "conditional-dependencies" word-prop ]
+ [ "definition-dependencies" word-prop ] tri
+ join-dependencies ;
+
+: (compiled-unxref) ( word dependencies variable -- )
+ get remove-vertex* ;
+
+: generic-call-sites ( word -- alist )
+ "generic-call-sites" word-prop 2 <groups> ;
: compiled-unxref ( word -- )
- [ "compiled-uses" compiled-crossref (compiled-unxref) ]
- [ "compiled-generic-uses" compiled-generic-crossref (compiled-unxref) ]
- bi ;
+ {
+ [ dup load-dependencies compiled-crossref (compiled-unxref) ]
+ [ dup generic-call-sites generic-call-site-crossref (compiled-unxref) ]
+ [ "effect-dependencies" remove-word-prop ]
+ [ "conditional-dependencies" remove-word-prop ]
+ [ "definition-dependencies" remove-word-prop ]
+ [ "generic-call-sites" remove-word-prop ]
+ } cleave ;
: delete-compiled-xref ( word -- )
[ compiled-unxref ]
[ compiled-crossref get delete-at ]
- [ compiled-generic-crossref get delete-at ]
+ [ generic-call-site-crossref get delete-at ]
tri ;
+
+: set-dependency-checks ( word deps -- )
+ keys f like "dependency-checks" set-word-prop ;
[ ] [ stack-frame-bustage 2drop ] unit-test
+! C99 tests
+os windows? [
+
FUNCTION: complex-float ffi_test_45 ( int x ) ;
[ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test
ffi_test_48
] unit-test
+] unless
+
! Regression: calling an undefined function would raise a protection fault
FUNCTION: void this_does_not_exist ( ) ;
-USING: eval tools.test compiler.units vocabs words kernel ;
+USING: eval tools.test compiler.units vocabs words kernel
+definitions sequences math classes classes.mixin kernel.private ;
IN: compiler.tests.redefine10
-! Mixin redefinition did not recompile all necessary words.
-
-[ ] [ [ "compiler.tests.redefine10" forget-vocab ] with-compilation-unit ] unit-test
-
-[ ] [
- "USING: kernel math classes ;
- IN: compiler.tests.redefine10
- MIXIN: my-mixin
- INSTANCE: fixnum my-mixin
- : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;"
- eval( -- )
-] unit-test
-
-[ ] [
- "USE: math
- IN: compiler.tests.redefine10
- INSTANCE: float my-mixin"
- eval( -- )
-] unit-test
-
-[ 2.0 ] [
- 1.0 "my-inline" "compiler.tests.redefine10" lookup execute
-] unit-test
+! Mixin redefinition should update predicate call sites
+
+MIXIN: my-mixin
+INSTANCE: fixnum my-mixin
+: my-inline-1 ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
+: my-inline-2 ( a -- b ) dup my-mixin? [ 1 + ] when ;
+: my-inline-3 ( a -- b ) dup my-mixin? [ float? ] [ drop f ] if ;
+: my-inline-4 ( a -- b ) dup float? [ my-mixin? ] [ drop f ] if ;
+: my-inline-5 ( a -- b ) dup my-mixin? [ fixnum? ] [ drop f ] if ;
+: my-inline-6 ( a -- b ) dup fixnum? [ my-mixin? ] [ drop f ] if ;
+
+GENERIC: fake-float? ( obj -- ? )
+
+M: float fake-float? drop t ;
+M: object fake-float? drop f ;
+
+: my-fake-inline-3 ( a -- b ) dup my-mixin? [ fake-float? ] [ drop f ] if ;
+
+: my-baked-inline-3 ( a -- b ) { my-mixin } declare fake-float? ;
+
+[ f ] [ 5 my-inline-3 ] unit-test
+
+[ f ] [ 5 my-fake-inline-3 ] unit-test
+
+[ f ] [ 5 my-baked-inline-3 ] unit-test
+
+[ f ] [ 5 my-inline-4 ] unit-test
+
+[ t ] [ 5 my-inline-5 ] unit-test
+
+[ t ] [ 5 my-inline-6 ] unit-test
+
+[ ] [ [ float my-mixin add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 2.0 ] [ 1.0 my-inline-1 ] unit-test
+
+[ 2.0 ] [ 1.0 my-inline-2 ] unit-test
+
+[ t ] [ 1.0 my-inline-3 ] unit-test
+
+[ t ] [ 1.0 my-fake-inline-3 ] unit-test
+
+[ t ] [ 1.0 my-baked-inline-3 ] unit-test
+
+[ t ] [ 1.0 my-inline-4 ] unit-test
+
+[ f ] [ 1.0 my-inline-5 ] unit-test
+
+[ f ] [ 1.0 my-inline-6 ] unit-test
+
+[ ] [ [ fixnum my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ f ] [ 5 my-inline-3 ] unit-test
+
+[ f ] [ 5 my-fake-inline-3 ] unit-test
+
+[ f ] [ 5 my-baked-inline-3 ] unit-test
+
+[ f ] [ 5 my-inline-4 ] unit-test
+
+[ f ] [ 5 my-inline-5 ] unit-test
+
+[ f ] [ 5 my-inline-6 ] unit-test
+
+[ ] [ [ float my-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ 1.0 ] [ 1.0 my-inline-1 ] unit-test
+
+[ 1.0 ] [ 1.0 my-inline-2 ] unit-test
+
+[ f ] [ 1.0 my-inline-3 ] unit-test
+
+[ f ] [ 1.0 my-fake-inline-3 ] unit-test
+
+[ f ] [ 1.0 my-inline-4 ] unit-test
+
+[ f ] [ 1.0 my-inline-5 ] unit-test
+
+[ f ] [ 1.0 my-inline-6 ] unit-test
--- /dev/null
+USING: kernel tools.test eval words ;
+IN: compiler.tests.redefine18
+
+! Mixin bug found by Doug
+
+GENERIC: g1 ( a -- b )
+GENERIC: g2 ( a -- b )
+
+MIXIN: c
+SINGLETON: a
+INSTANCE: a c
+
+M: c g1 g2 ;
+M: a g2 drop a ;
+
+MIXIN: d
+INSTANCE: d c
+
+M: d g2 drop d ;
+
+[ ] [ "IN: compiler.tests.redefine18 SINGLETON: b INSTANCE: b d" eval( -- ) ] unit-test
+
+[ d ] [ "b" "compiler.tests.redefine18" lookup g1 ] unit-test
+
+[ ] [ "IN: compiler.tests.redefine18 FORGET: b" eval( -- ) ] unit-test
--- /dev/null
+USING: kernel classes.mixin compiler.units tools.test generic ;
+IN: compiler.tests.redefine19
+
+GENERIC: g ( a -- b )
+
+MIXIN: m1 M: m1 g drop 1 ;
+MIXIN: m2 M: m2 g drop 2 ;
+
+TUPLE: c ;
+
+INSTANCE: c m2
+
+: foo ( -- b ) c new g ;
+
+[ 2 ] [ foo ] unit-test
+
+[ ] [ [ c m1 add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ { m2 m1 } ] [ \ g order ] unit-test
+
+[ 1 ] [ foo ] unit-test
+
+[ ] [ [ c m1 remove-mixin-instance ] with-compilation-unit ] unit-test
--- /dev/null
+IN: compiler.tests.redefine20
+USING: kernel sequences compiler.units definitions classes.mixin
+tools.test ;
+
+GENERIC: cnm-recompile-test ( a -- b )
+
+M: object cnm-recompile-test drop object ;
+
+M: sequence cnm-recompile-test drop sequence ;
+
+TUPLE: funny ;
+
+M: funny cnm-recompile-test call-next-method ;
+
+[ object ] [ funny new cnm-recompile-test ] unit-test
+
+[ ] [ [ funny sequence add-mixin-instance ] with-compilation-unit ] unit-test
+
+[ sequence ] [ funny new cnm-recompile-test ] unit-test
+
+[ ] [ [ funny sequence remove-mixin-instance ] with-compilation-unit ] unit-test
+
+[ object ] [ funny new cnm-recompile-test ] unit-test
: sheeple-test ( -- string ) { } sheeple ;
: compiled-use? ( key word -- ? )
- "compiled-uses" word-prop 2 <groups> key? ;
+ "definition-dependencies" word-prop member-eq? ;
[ "sheeple" ] [ sheeple-test ] unit-test
[ t ] [ \ sheeple-test optimized? ] unit-test
[ f ] dip build-tree-with ;
:: build-sub-tree ( in-d out-d word/quot -- nodes/f )
- #! We don't want methods on mixins to have a declaration for that mixin.
- #! This slows down compiler.tree.propagation.inlining since then every
- #! inlined usage of a method has an inline-dependency on the mixin, and
- #! not the more specific type at the call site.
- f specialize-method? [
- [
- in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
- {
- { [ dup not ] [ ] }
- { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
- [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
- } cond
- ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
- ] with-variable ;
\ No newline at end of file
+ [
+ in-d word/quot build-tree-with unclip-last in-d>> :> in-d'
+ {
+ { [ dup not ] [ ] }
+ { [ dup ends-with-terminate? ] [ out-d [ f swap #push ] map append ] }
+ [ in-d' out-d [ [ length ] bi@ assert= ] [ #copy suffix ] 2bi ]
+ } cond
+ ] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover ;
\ No newline at end of file
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences combinators fry
classes.algebra namespaces assocs words math math.private
#! do it since the logic is a bit more involved
[ cleanup* ] map-flat ;
+! Constant folding
: cleanup-folding? ( #call -- ? )
node-output-infos
[ f ] [ [ literal?>> ] all? ] if-empty ;
-: cleanup-folding ( #call -- nodes )
+: (cleanup-folding) ( #call -- nodes )
#! Replace a #call having a known result with a #drop of its
#! inputs followed by #push nodes for the outputs.
- [ word>> inlined-dependency depends-on ]
[
[ node-output-infos ] [ out-d>> ] bi
[ [ literal>> ] dip #push ] 2map
]
[ in-d>> #drop ]
- tri prefix ;
+ bi prefix ;
+
+: record-predicate-folding ( #call -- )
+ [ node-input-infos first class>> ]
+ [ word>> "predicating" word-prop ]
+ [ node-output-infos first literal>> ] tri
+ [ depends-on-class<= ] [ depends-on-classes-disjoint ] if ;
+
+: record-folding ( #call -- )
+ dup word>> predicate?
+ [ record-predicate-folding ]
+ [ word>> depends-on-definition ]
+ if ;
+
+: cleanup-folding ( #call -- nodes )
+ [ (cleanup-folding) ] [ record-folding ] bi ;
+! Method inlining
: add-method-dependency ( #call -- )
dup method>> word? [
- [ word>> ] [ class>> ] bi depends-on-generic
+ [ [ class>> ] [ word>> ] bi depends-on-generic ]
+ [ [ class>> ] [ word>> ] [ method>> ] tri depends-on-method ]
+ bi
] [ drop ] if ;
+: record-inlining ( #call -- )
+ dup method>>
+ [ add-method-dependency ]
+ [ word>> depends-on-definition ] if ;
+
: cleanup-inlining ( #call -- nodes )
- [
- dup method>>
- [ add-method-dependency ]
- [ word>> inlined-dependency depends-on ] if
- ] [ body>> cleanup ] bi ;
+ [ record-inlining ] [ body>> cleanup ] bi ;
! Removing overflow checks
: (remove-overflow-check?) ( #call -- ? )
compiler.tree.dead-code.liveness ;
IN: compiler.tree.dead-code.simple
-GENERIC: flushable? ( word -- ? )
-
-M: predicate flushable? drop t ;
-
-M: word flushable? "flushable" word-prop ;
-
-M: method-body flushable? "method-generic" word-prop flushable? ;
-
: flushable-call? ( #call -- ? )
dup word>> dup flushable? [
"input-classes" word-prop dup [
] [ drop f ] if ;
: remove-flushable-call ( #call -- node )
- [ word>> flushed-dependency depends-on ]
+ [ word>> depends-on-flushable ]
[ in-d>> #drop remove-dead-code* ]
bi ;
[ ] [ "IN: compiler.tree.propagation.call-effect.tests USE: math : call(-redefine-test ( a -- c ) 1 + ;" eval( -- ) ] unit-test
[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f (( a b -- c )) } = ] must-fail-with
+
+! See if redefining a tuple class bumps effect counter
+TUPLE: my-tuple a b c ;
+
+: my-quot ( -- quot ) [ my-tuple boa ] ;
+
+: my-word ( a b c q -- result ) call( a b c -- result ) ;
+
+[ T{ my-tuple f 1 2 3 } ] [ 1 2 3 my-quot my-word ] unit-test
+
+[ ] [ "IN: compiler.tree.propagation.call-effect.tests TUPLE: my-tuple a b ;" eval( -- ) ] unit-test
+
+[ 1 2 3 my-quot my-word ] [ wrong-values? ] must-fail-with
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators combinators.private effects
fry kernel kernel.private make sequences continuations
-quotations words math stack-checker combinators.short-circuit
-stack-checker.transforms compiler.tree.propagation.info
+quotations words math stack-checker stack-checker.dependencies
+combinators.short-circuit stack-checker.transforms
+compiler.tree.propagation.info
compiler.tree.propagation.inlining compiler.units ;
IN: compiler.tree.propagation.call-effect
! call( and execute( have complex expansions.
-! call( uses the following strategy:
+! If the input quotation is a literal, or built up from curry and
+! compose with terminal quotations literal, it is inlined at the
+! call site.
+
+! For dynamic call sites, call( uses the following strategy:
! - Inline caching. If the quotation is the same as last time, just call it unsafely
! - Effect inference. Infer quotation's effect, caching it in the cached-effect slot,
! and compare it with declaration. If matches, call it unsafely.
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
: safe-infer ( quot -- effect )
- [ infer ] [ 2drop +unknown+ ] recover ;
+ [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ;
: cached-effect-valid? ( quot -- ? )
cache-counter>> effect-counter eq? ; inline
dup literal>> class?
[
literal>>
- [ inlined-dependency depends-on ]
+ [ depends-on-conditionally ]
[ predicate-output-infos ]
bi
] [ 2drop object-info ] if
#! classes mentioned in the declaration are redefined, since
#! now we're making assumptions but their definitions.
declaration>> [
- [ inlined-dependency depends-on ]
+ [ depends-on-conditionally ]
[ <class-info> swap refine-value-info ]
bi
] assoc-each ;
#! is redefined, since now we're making assumptions but the
#! class definition itself.
[ in-d>> first value-info ]
- [ "predicating" word-prop dup inlined-dependency depends-on ] bi*
- predicate-output-infos 1array ;
+ [ "predicating" word-prop ] bi*
+ [ nip depends-on-conditionally ]
+ [ predicate-output-infos 1array ] 2bi ;
: default-output-value-infos ( #call word -- infos )
"default-output-classes" word-prop
: inline-new ( class -- quot/f )
dup tuple-class? [
- dup inlined-dependency depends-on
- [ all-slots [ initial>> literalize ] map ]
- [ tuple-layout '[ _ <tuple-boa> ] ]
- bi append >quotation
+ dup tuple-layout
+ [ depends-on-tuple-layout ]
+ [ drop all-slots [ initial>> literalize ] [ ] map-as ]
+ [ nip ]
+ 2tri
+ '[ @ _ <tuple-boa> ]
] [ drop f ] if ;
\ new [ inline-new ] 1 define-partial-eval
! calls when a C type is redefined
\ heap-size [
dup word? [
- [ inlined-dependency depends-on ] [ heap-size '[ _ ] ] bi
+ [ depends-on-definition ] [ heap-size '[ _ ] ] bi
] [ drop f ] if
] 1 define-partial-eval
dup end-of-information-code>> 1 + initial-uncompress-table >>table
dup initial-code-size>> >>code-size ;
+ERROR: code-size-zero ;
+
: <lzw-uncompress> ( input code-size class -- obj )
new
- swap >>code-size
+ swap [ code-size-zero ] when-zero >>code-size
dup code-size>> >>initial-code-size
dup code-size>> 1 - 2^ >>clear-code
dup clear-code>> 1 + >>end-of-information-code
-! Copyright (C) 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: concurrency.futures concurrency.count-downs sequences\r
-kernel macros fry combinators generalizations ;\r
-IN: concurrency.combinators\r
-\r
-<PRIVATE\r
-\r
-: (parallel-each) ( n quot -- )\r
- [ <count-down> ] dip keep await ; inline\r
-\r
-PRIVATE>\r
-\r
-: parallel-each ( seq quot -- )\r
- over length [\r
- '[ _ curry _ spawn-stage ] each\r
- ] (parallel-each) ; inline\r
-\r
-: 2parallel-each ( seq1 seq2 quot -- )\r
- 2over min-length [\r
- '[ _ 2curry _ spawn-stage ] 2each\r
- ] (parallel-each) ; inline\r
-\r
-: parallel-filter ( seq quot -- newseq )\r
- over [ selector [ parallel-each ] dip ] dip like ; inline\r
-\r
-<PRIVATE\r
-\r
-: [future] ( quot -- quot' ) '[ _ curry future ] ; inline\r
-\r
-: future-values ( futures -- futures )\r
- [ ?future ] map! ; inline\r
-\r
-PRIVATE>\r
-\r
-: parallel-map ( seq quot -- newseq )\r
- [future] map future-values ; inline\r
-\r
-: 2parallel-map ( seq1 seq2 quot -- newseq )\r
- '[ _ 2curry future ] 2map future-values ;\r
-\r
-<PRIVATE\r
-\r
-: (parallel-spread) ( n -- spread-array )\r
- [ ?future ] <repetition> ; inline\r
-\r
-: (parallel-cleave) ( quots -- quot-array spread-array )\r
- [ [future] ] map dup length (parallel-spread) ; inline\r
-\r
-PRIVATE>\r
-\r
-MACRO: parallel-cleave ( quots -- )\r
- (parallel-cleave) '[ _ cleave _ spread ] ;\r
-\r
-MACRO: parallel-spread ( quots -- )\r
- (parallel-cleave) '[ _ spread _ spread ] ;\r
-\r
-MACRO: parallel-napply ( quot n -- )\r
- [ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ;\r
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.futures concurrency.count-downs sequences
+kernel macros fry combinators generalizations ;
+IN: concurrency.combinators
+
+<PRIVATE
+
+: (parallel-each) ( n quot -- )
+ [ <count-down> ] dip keep await ; inline
+
+PRIVATE>
+
+: parallel-each ( seq quot -- )
+ over length [
+ '[ _ curry _ spawn-stage ] each
+ ] (parallel-each) ; inline
+
+: 2parallel-each ( seq1 seq2 quot -- )
+ 2over min-length [
+ '[ _ 2curry _ spawn-stage ] 2each
+ ] (parallel-each) ; inline
+
+: parallel-filter ( seq quot -- newseq )
+ over [ selector [ parallel-each ] dip ] dip like ; inline
+
+<PRIVATE
+
+: [future] ( quot -- quot' ) '[ _ curry future ] ; inline
+
+: future-values ( futures -- futures )
+ [ ?future ] map! ; inline
+
+PRIVATE>
+
+: parallel-map ( seq quot -- newseq )
+ [future] map future-values ; inline
+
+: 2parallel-map ( seq1 seq2 quot -- newseq )
+ '[ _ 2curry future ] 2map future-values ;
+
+<PRIVATE
+
+: (parallel-spread) ( n -- spread-array )
+ [ ?future ] <repetition> ; inline
+
+: (parallel-cleave) ( quots -- quot-array spread-array )
+ [ [future] ] map dup length (parallel-spread) ; inline
+
+PRIVATE>
+
+MACRO: parallel-cleave ( quots -- )
+ (parallel-cleave) '[ _ cleave _ spread ] ;
+
+MACRO: parallel-spread ( quots -- )
+ (parallel-cleave) '[ _ spread _ spread ] ;
+
+MACRO: parallel-napply ( quot n -- )
+ [ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ;
func "libm" load-library %alien-invoke
dst float-function-return ;
+: stdcall? ( params -- ? )
+ abi>> "stdcall" = ;
+
+: funny-large-struct-return? ( params -- ? )
+ #! MINGW ABI incompatibility disaster
+ [ return>> large-struct? ]
+ [ abi>> "mingw" = os windows? not or ]
+ bi and ;
+
M: x86.32 %cleanup ( params -- )
#! a) If we just called an stdcall function in Windows, it
#! cleaned up the stack frame for us. But we don't want that
#! b) If we just called a function returning a struct, we
#! have to fix ESP.
{
- {
- [ dup abi>> "stdcall" = ]
- [ drop ESP stack-frame get params>> SUB ]
- } {
- [ dup return>> large-struct? ]
- [ drop EAX PUSH ]
- }
+ { [ dup stdcall? ] [ drop ESP stack-frame get params>> SUB ] }
+ { [ dup funny-large-struct-return? ] [ drop EAX PUSH ] }
[ drop ]
} cond ;
#! b) If the callback is returning a large struct, we have
#! to fix ESP.
{
- { [ dup abi>> "stdcall" = ] [
- <alien-stack-frame>
- [ params>> ] [ return>> ] bi +
- ] }
- { [ dup return>> large-struct? ] [ drop 4 ] }
+ { [ dup stdcall? ] [ <alien-stack-frame> [ params>> ] [ return>> ] bi + ] }
+ { [ dup funny-large-struct-return? ] [ drop 4 ] }
[ drop 0 ]
} cond ;
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots arrays definitions generic hashtables summary io kernel
math namespaces make prettyprint prettyprint.config sequences assocs
M: bad-create summary drop "Bad parameters to create" ;
+M: cannot-be-inline summary drop "This type of word cannot be inlined" ;
+
M: attempt-all-error summary drop "Nothing to attempt" ;
M: already-disposed summary drop "Attempting to operate on disposed object" ;
M: invalid-slot-name summary
drop "Invalid slot name" ;
+M: bad-inheritance summary
+ drop "Circularity in inheritance chain" ;
+
M: not-in-a-method-error summary
drop "call-next-method can only be called in a method definition" ;
(eval)
with-file-vocabs
}
-"Code in the listener tool starts out with a different initial search path, with more vocabularies are available by default. Strings of code can be evaluated in this search path by using " { $link (eval) } " with a different combinator:"
+"Code in the listener tool starts out with a different initial search path, with more vocabularies available by default. Strings of code can be evaluated in this search path by using " { $link (eval) } " with a different combinator:"
{ $subsections
with-interactive-vocabs
}
HOOK: read-controller game-input-backend ( controller -- controller-state )
HOOK: calibrate-controller game-input-backend ( controller -- )
+HOOK: vibrate-controller game-input-backend ( controller motor1 motor2 -- )
HOOK: read-keyboard game-input-backend ( -- keyboard-state )
call-next-method dup buttons>> clone >>buttons ;
{
- { [ os windows? ] [ "game.input.dinput" require ] }
+ { [ os windows? ] [ "game.input.xinput" require ] }
{ [ os macosx? ] [ "game.input.iokit" require ] }
{ [ t ] [ ] }
} cond
--- /dev/null
+Erik Charlebois
--- /dev/null
+XInput backend for game.input, borrows keyboard and mouse handling from game.input.dinput
--- /dev/null
+unportable
+games
--- /dev/null
+USING: game.input math math.order kernel macros fry sequences quotations
+arrays windows.directx.xinput combinators accessors windows.types
+game.input.dinput sequences.private namespaces classes.struct
+windows.errors windows.com.syntax io.encodings.utf16n alien.strings ;
+IN: game.input.xinput
+
+SINGLETON: xinput-game-input-backend
+
+xinput-game-input-backend game-input-backend set-global
+
+<PRIVATE
+: >axis ( short -- float )
+ 32768 /f ; inline
+: >trigger ( byte -- float )
+ 255 /f ; inline
+: >vibration ( float -- short )
+ 65535 * >fixnum 0 65535 clamp ; inline
+MACRO: map-index-compose ( seq quot -- seq )
+ '[ '[ _ execute _ ] _ compose ] map-index 1quotation ;
+
+: fill-buttons ( button-bitmap -- button-array )
+ 10 0.0 <array> dup rot >fixnum
+ { XINPUT_GAMEPAD_START
+ XINPUT_GAMEPAD_BACK
+ XINPUT_GAMEPAD_LEFT_THUMB
+ XINPUT_GAMEPAD_RIGHT_THUMB
+ XINPUT_GAMEPAD_LEFT_SHOULDER
+ XINPUT_GAMEPAD_RIGHT_SHOULDER
+ XINPUT_GAMEPAD_A
+ XINPUT_GAMEPAD_B
+ XINPUT_GAMEPAD_X
+ XINPUT_GAMEPAD_Y }
+ [ [ bitand ] dip swap 0 = [ 2drop ] [ 1.0 -rot swap set-nth ] if ]
+ map-index-compose 2cleave ;
+
+ : >pov ( byte -- symbol )
+ {
+ pov-neutral
+ pov-up
+ pov-down
+ pov-neutral
+ pov-left
+ pov-up-left
+ pov-down-left
+ pov-neutral
+ pov-right
+ pov-up-right
+ pov-down-right
+ pov-neutral
+ pov-neutral
+ pov-neutral
+ pov-neutral
+ pov-neutral
+ } nth ;
+
+: fill-controller-state ( XINPUT_STATE -- controller-state )
+ Gamepad>> controller-state new dup rot
+ {
+ [ wButtons>> HEX: f bitand >pov swap (>>pov) ]
+ [ wButtons>> fill-buttons swap (>>buttons) ]
+ [ sThumbLX>> >axis swap (>>x) ]
+ [ sThumbLY>> >axis swap (>>y) ]
+ [ sThumbRX>> >axis swap (>>rx) ]
+ [ sThumbRY>> >axis swap (>>ry) ]
+ [ bLeftTrigger>> >trigger swap (>>z) ]
+ [ bRightTrigger>> >trigger swap (>>rz) ]
+ } 2cleave ;
+PRIVATE>
+
+M: xinput-game-input-backend (open-game-input)
+ TRUE XInputEnable
+ create-dinput
+ create-device-change-window
+ find-keyboard
+ find-mouse
+ add-wm-devicechange ;
+
+M: xinput-game-input-backend (close-game-input)
+ remove-wm-devicechange
+ release-mouse
+ release-keyboard
+ close-device-change-window
+ delete-dinput
+ FALSE XInputEnable ;
+
+M: xinput-game-input-backend (reset-game-input)
+ global [
+ {
+ +dinput+ +keyboard-device+ +keyboard-state+
+ +controller-devices+ +controller-guids+
+ +device-change-window+ +device-change-handle+
+ } [ off ] each
+ ] bind ;
+
+M: xinput-game-input-backend get-controllers
+ { 0 1 2 3 } ;
+
+M: xinput-game-input-backend product-string
+ dup number?
+ [ drop "Controller (Xbox 360 Wireless Receiver for Windows)" ]
+ [ handle>> device-info tszProductName>> utf16n alien>string ]
+ if ;
+
+M: xinput-game-input-backend product-id
+ dup number?
+ [ drop GUID: {02a1045e-0000-0000-0000-504944564944} ]
+ [ handle>> device-info guidProduct>> ]
+ if ;
+
+M: xinput-game-input-backend instance-id
+ dup number?
+ [ drop GUID: {c6075b30-fbca-11de-8001-444553540000} ]
+ [ handle>> device-guid ]
+ if ;
+
+M: xinput-game-input-backend read-controller
+ XINPUT_STATE <struct> [ XInputGetState ] keep
+ swap drop fill-controller-state ;
+
+M: xinput-game-input-backend calibrate-controller drop ;
+
+M: xinput-game-input-backend vibrate-controller
+ [ >vibration ] bi@ XINPUT_VIBRATION <struct-boa> XInputSetState drop ;
+
+M: xinput-game-input-backend read-keyboard
+ +keyboard-device+ get
+ [ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
+ [ ] [ f ] with-acquisition ;
+
+M: xinput-game-input-backend read-mouse
+ +mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
+ [ fill-mouse-state ] [ f ] with-acquisition ;
+
+M: xinput-game-input-backend reset-mouse
+ +mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
+ [ 2drop ] [ ] with-acquisition
+ +mouse-state+ get
+ 0 >>dx
+ 0 >>dy
+ 0 >>scroll-dx
+ 0 >>scroll-dy
+ drop ;
2 1 0 -1 [ + ] [ - ] [ * ] [ / ] 4 spread-curry 4 spread*\r
] unit-test\r
\r
+[ { 1 2 } { 3 4 } { 5 6 } ]\r
+[ 1 2 3 4 5 6 [ 2array ] 2 3 mnapply ] unit-test\r
+\r
+[ { 1 2 3 } { 4 5 6 } ]\r
+[ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test\r
+\r
+[ { 1 2 3 } { 4 5 6 } ]\r
+[ 1 2 3 4 5 6 [ 3array ] [ 3array ] 3 2 nspread* ] unit-test\r
+\r
+[ ]\r
+[ [ 2array ] 2 0 mnapply ] unit-test\r
+\r
+[ ]\r
+[ 2 0 nspread* ] unit-test\r
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences sequences.private math
combinators macros math.order math.ranges quotations fry effects
-memoize.private ;
+memoize.private arrays ;
IN: generalizations
<<
MACRO: spread* ( n -- )
[ [ ] ] [
- 1 swap [a,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as
+ [1,b) [ '[ [ [ _ ndip ] curry ] dip compose ] ] map [ ] concat-as
[ call ] compose
] if-zero ;
+MACRO: nspread* ( m n -- )
+ [ drop [ ] ] [
+ [ * 0 ] [ drop neg ] 2bi
+ <range> rest >array dup length iota <reversed>
+ [
+ '[ [ [ _ ndip ] curry ] _ ndip ]
+ ] 2map dup rest-slice [ [ compose ] compose ] map! drop
+ [ ] concat-as [ call ] compose
+ ] if-zero ;
+
MACRO: cleave* ( n -- )
[ [ ] ]
[ 1 - [ [ [ keep ] curry ] dip compose ] n*quot [ call ] compose ]
: napply ( quot n -- )
[ dupn ] [ spread* ] bi ; inline
+: mnapply ( quot m n -- )
+ [ nip dupn ] [ nspread* ] 2bi ; inline
+
: apply-curry ( ...a quot n -- )
[ [curry] ] dip napply ; inline
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
sequences.private accessors fry ;
<PRIVATE
-TUPLE: chunking-seq { seq read-only } { n read-only } ;
-
-: check-groups ( n -- n )
- dup 0 <= [ "Invalid group count" throw ] when ; inline
-
-: new-groups ( seq n class -- groups )
- [ check-groups ] dip boa ; inline
+MIXIN: chunking
+INSTANCE: chunking sequence
GENERIC: group@ ( n groups -- from to seq )
-M: chunking-seq set-nth group@ <slice> 0 swap copy ;
-
-M: chunking-seq like drop { } like ; inline
-
-INSTANCE: chunking-seq sequence
+M: chunking set-nth group@ <slice> 0 swap copy ;
+M: chunking like drop { } like ; inline
MIXIN: subseq-chunking
+INSTANCE: subseq-chunking chunking
+INSTANCE: subseq-chunking sequence
M: subseq-chunking nth group@ subseq ; inline
MIXIN: slice-chunking
+INSTANCE: slice-chunking chunking
+INSTANCE: slice-chunking sequence
M: slice-chunking nth group@ <slice> ; inline
-
M: slice-chunking nth-unsafe group@ slice boa ; inline
-TUPLE: abstract-groups < chunking-seq ;
+MIXIN: abstract-groups
+INSTANCE: abstract-groups sequence
M: abstract-groups length
[ seq>> length ] [ n>> ] bi [ + 1 - ] keep /i ; inline
M: abstract-groups group@
[ n>> [ * dup ] keep + ] [ seq>> ] bi [ length min ] keep ; inline
-TUPLE: abstract-clumps < chunking-seq ;
+MIXIN: abstract-clumps
+INSTANCE: abstract-clumps sequence
M: abstract-clumps length
[ seq>> length 1 + ] [ n>> ] bi [-] ; inline
M: abstract-clumps group@
[ n>> over + ] [ seq>> ] bi ; inline
+TUPLE: chunking-seq { seq read-only } { n read-only } ;
+
+: check-groups ( n -- n )
+ dup 0 <= [ "Invalid group count" throw ] when ; inline
+
+: new-groups ( seq n class -- groups )
+ [ check-groups ] dip boa ; inline
+
PRIVATE>
-TUPLE: groups < abstract-groups ;
+TUPLE: groups < chunking-seq ;
+INSTANCE: groups subseq-chunking
+INSTANCE: groups abstract-groups
: <groups> ( seq n -- groups )
groups new-groups ; inline
-INSTANCE: groups subseq-chunking
-
-TUPLE: sliced-groups < abstract-groups ;
+TUPLE: sliced-groups < chunking-seq ;
+INSTANCE: sliced-groups slice-chunking
+INSTANCE: sliced-groups abstract-groups
: <sliced-groups> ( seq n -- groups )
sliced-groups new-groups ; inline
-INSTANCE: sliced-groups slice-chunking
-
-TUPLE: clumps < abstract-clumps ;
+TUPLE: clumps < chunking-seq ;
+INSTANCE: clumps subseq-chunking
+INSTANCE: clumps abstract-clumps
: <clumps> ( seq n -- clumps )
clumps new-groups ; inline
-INSTANCE: clumps subseq-chunking
-
-TUPLE: sliced-clumps < abstract-clumps ;
+TUPLE: sliced-clumps < chunking-seq ;
+INSTANCE: sliced-clumps slice-chunking
+INSTANCE: sliced-clumps abstract-clumps
: <sliced-clumps> ( seq n -- clumps )
sliced-clumps new-groups ; inline
-INSTANCE: sliced-clumps slice-chunking
-
: group ( seq n -- array ) <groups> { } like ;
: clump ( seq n -- array ) <clumps> { } like ;
: specialize-quot ( quot specializer -- quot' )
[ drop ] [ specializer-cases ] 2bi alist>quot ;
-! compiler.tree.propagation.inlining sets this to f
-SYMBOL: specialize-method?
-
-t specialize-method? set-global
-
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
[ "method-class" word-prop ]
bi prefix [ declare ] curry [ ] like ;
: specialize-method ( quot method -- quot' )
- [ specialize-method? get [ method-declaration prepend ] [ drop ] if ]
+ [ method-declaration prepend ]
[ "method-generic" word-prop ] bi
specializer [ specialize-quot ] when* ;
! Copyright (C) 2009 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel accessors sequences math arrays ;
+USING: combinators kernel locals accessors sequences math arrays ;
IN: images
SINGLETONS:
<PRIVATE
-: pixel@ ( x y image -- start end bitmap )
- [ dim>> first * + ]
- [ bytes-per-pixel [ * dup ] keep + ]
- [ bitmap>> ] tri ;
+:: pixel@ ( x y w image -- start end bitmap )
+ image dim>> first y * x + :> start
+ start w [ image bytes-per-pixel * ] bi@ :> ( start' w' )
+ start' start' w' + image bitmap>> ; inline
: set-subseq ( new-value from to victim -- )
<slice> 0 swap copy ; inline
PRIVATE>
+: pixel-row-at ( x y w image -- pixels )
+ pixel@ subseq ; inline
+
+: pixel-row-slice-at ( x y w image -- pixels )
+ pixel@ <slice> ; inline
+
+: set-pixel-row-at ( pixel x y w image -- )
+ pixel@ set-subseq ; inline
+
: pixel-at ( x y image -- pixel )
- pixel@ subseq ;
+ [ 1 ] dip pixel-row-at ; inline
+
+: pixel-slice-at ( x y image -- pixels )
+ [ 1 ] dip pixel-row-slice-at ; inline
: set-pixel-at ( pixel x y image -- )
- pixel@ set-subseq ;
+ [ 1 ] dip set-pixel-row-at ; inline
+
: decode-macroblock ( -- blocks )
jpeg> components>>
[
- [ mb-dim first2 * iota ]
+ [ mb-dim first2 * ]
[ [ decode-block ] curry replicate ] bi
] map concat ;
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors images images.loader io io.binary kernel
+locals math sequences io.encodings.ascii io.encodings.string
+calendar math.ranges math.parser colors arrays hashtables
+ui.pixel-formats combinators continuations ;
+IN: images.tga
+
+SINGLETON: tga-image
+"tga" tga-image register-image-class
+
+ERROR: bad-tga-header ;
+ERROR: bad-tga-footer ;
+ERROR: bad-tga-extension-size ;
+ERROR: bad-tga-timestamp ;
+ERROR: bad-tga-unsupported ;
+
+: read-id-length ( -- byte )
+ 1 read le> ; inline
+
+: read-color-map-type ( -- byte )
+ 1 read le> dup
+ { 0 1 } member? [ bad-tga-header ] unless ;
+
+: read-image-type ( -- byte )
+ 1 read le> dup
+ { 0 1 2 3 9 10 11 } member? [ bad-tga-header ] unless ; inline
+
+: read-color-map-first ( -- short )
+ 2 read le> ; inline
+
+: read-color-map-length ( -- short )
+ 2 read le> ; inline
+
+: read-color-map-entry-size ( -- byte )
+ 1 read le> ; inline
+
+: read-x-origin ( -- short )
+ 2 read le> ; inline
+
+: read-y-origin ( -- short )
+ 2 read le> ; inline
+
+: read-image-width ( -- short )
+ 2 read le> ; inline
+
+: read-image-height ( -- short )
+ 2 read le> ; inline
+
+: read-pixel-depth ( -- byte )
+ 1 read le> ; inline
+
+: read-image-descriptor ( -- alpha-bits pixel-order )
+ 1 read le>
+ [ 7 bitand ] [ 24 bitand -3 shift ] bi ; inline
+
+: read-image-id ( length -- image-id )
+ read ; inline
+
+: read-color-map ( type length elt-size -- color-map )
+ pick 1 = [ 8 align 8 / * read ] [ 2drop f ] if swap drop ; inline
+
+: read-image-data ( width height depth -- image-data )
+ 8 align 8 / * * read ; inline
+
+: read-extension-area-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-developer-directory-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-signature ( -- )
+ 18 read ascii decode "TRUEVISION-XFILE.\0" = [ bad-tga-footer ] unless ; inline
+
+: read-extension-size ( -- )
+ 2 read le> 495 = [ bad-tga-extension-size ] unless ; inline
+
+: read-author-name ( -- string )
+ 41 read ascii decode [ 0 = ] trim ; inline
+
+: read-author-comments ( -- string )
+ 4 iota [ drop 81 read ascii decode [ 0 = ] trim ] map concat ; inline
+
+: read-date-timestamp ( -- timestamp )
+ timestamp new
+ 2 read le> dup 12 [1,b] member? [ bad-tga-timestamp ] unless >>month
+ 2 read le> dup 31 [1,b] member? [ bad-tga-timestamp ] unless >>day
+ 2 read le> >>year
+ 2 read le> dup 23 [0,b] member? [ bad-tga-timestamp ] unless >>hour
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
+
+: read-job-name ( -- string )
+ 41 read ascii decode [ 0 = ] trim ; inline
+
+: read-job-time ( -- duration )
+ duration new
+ 2 read le> >>hour
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
+ 2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
+
+: read-software-id ( -- string )
+ 41 read ascii decode [ 0 = ] trim ; inline
+
+: read-software-version ( -- string )
+ 2 read le> 100 /f number>string
+ 1 read ascii decode append [ " " = ] trim ; inline
+
+:: read-key-color ( -- color )
+ 1 read le> 255 /f :> alpha
+ 1 read le> 255 /f
+ 1 read le> 255 /f
+ 1 read le> 255 /f
+ alpha <rgba> ; inline
+
+: read-pixel-aspect-ratio ( -- aspect-ratio )
+ 2 read le> 2 read le> /f ; inline
+
+: read-gamma-value ( -- gamma-value )
+ 2 read le> 2 read le> /f ; inline
+
+: read-color-correction-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-postage-stamp-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-scan-line-offset ( -- offset )
+ 4 read le> ; inline
+
+: read-premultiplied-alpha ( -- boolean )
+ 1 read le> 4 = ; inline
+
+: read-scan-line-table ( height -- scan-offsets )
+ iota [ drop 4 read le> ] map ; inline
+
+: read-postage-stamp-image ( depth -- postage-data )
+ 8 align 8 / 1 read le> 1 read le> * * read ; inline
+
+:: read-color-correction-table ( -- correction-table )
+ 256 iota
+ [
+ drop
+ 4 iota
+ [
+ drop
+ 2 read le> 65535 /f :> alpha
+ 2 read le> 65535 /f
+ 2 read le> 65535 /f
+ 2 read le> 65535 /f
+ alpha <rgba>
+ ] map
+ ] map ; inline
+
+: read-developer-directory ( -- developer-directory )
+ 2 read le> iota
+ [
+ drop
+ 2 read le>
+ 4 read le>
+ 4 read le>
+ 3array
+ ] map ; inline
+
+: read-developer-areas ( developer-directory -- developer-area-map )
+ [
+ [ first ]
+ [ dup third second seek-absolute seek-input read ] bi 2array
+ ] map >hashtable ; inline
+
+:: read-tga ( -- image )
+ #! Read header
+ read-id-length :> id-length
+ read-color-map-type :> map-type
+ read-image-type :> image-type
+ read-color-map-first :> map-first
+ read-color-map-length :> map-length
+ read-color-map-entry-size :> map-entry-size
+ read-x-origin :> x-origin
+ read-y-origin :> y-origin
+ read-image-width :> image-width
+ read-image-height :> image-height
+ read-pixel-depth :> pixel-depth
+ read-image-descriptor :> ( alpha-bits pixel-order )
+ id-length read-image-id :> image-id
+ map-type map-length map-entry-size read-color-map :> color-map-data
+ image-width image-height pixel-depth read-image-data :> image-data
+
+ [
+ #! Read optional footer
+ 26 seek-end seek-input
+ read-extension-area-offset :> extension-offset
+ read-developer-directory-offset :> directory-offset
+ read-signature
+
+ #! Read optional extension section
+ extension-offset 0 =
+ [
+ extension-offset seek-absolute seek-input
+ read-extension-size
+ read-author-name :> author-name
+ read-author-comments :> author-comments
+ read-date-timestamp :> date-timestamp
+ read-job-name :> job-name
+ read-job-time :> job-time
+ read-software-id :> software-id
+ read-software-version :> software-version
+ read-key-color :> key-color
+ read-pixel-aspect-ratio :> aspect-ratio
+ read-gamma-value :> gamma-value
+ read-color-correction-offset :> color-correction-offset
+ read-postage-stamp-offset :> postage-stamp-offset
+ read-scan-line-offset :> scan-line-offset
+ read-premultiplied-alpha :> premultiplied-alpha
+
+ color-correction-offset 0 =
+ [
+ color-correction-offset seek-absolute seek-input
+ read-color-correction-table :> color-correction-table
+ ] unless
+
+ postage-stamp-offset 0 =
+ [
+ postage-stamp-offset seek-absolute seek-input
+ pixel-depth read-postage-stamp-image :> postage-data
+ ] unless
+
+ scan-line-offset seek-absolute seek-input
+ image-height read-scan-line-table :> scan-offsets
+
+ #! Read optional developer section
+ directory-offset 0 =
+ [ f ]
+ [
+ directory-offset seek-absolute seek-input
+ read-developer-directory read-developer-areas
+ ] if :> developer-areas
+ ] unless
+ ] ignore-errors
+
+ #! Only 24-bit uncompressed RGB and 32-bit uncompressed ARGB are supported.
+ #! Other formats would need to be converted to work within the image class.
+ map-type 0 = [ bad-tga-unsupported ] unless
+ image-type 2 = [ bad-tga-unsupported ] unless
+ pixel-depth { 24 32 } member? [ bad-tga-unsupported ] unless
+ pixel-order { 0 2 } member? [ bad-tga-unsupported ] unless
+
+ #! Create image instance
+ image new
+ alpha-bits 0 = [ RGB ] [ ARGB ] if >>component-order
+ { image-width image-height } >>dim
+ pixel-order 0 = >>upside-down?
+ image-data >>bitmap
+ ubyte-components >>component-type ;
+
+M: tga-image stream>image
+ drop [ read-tga ] with-input-stream ;
+
+M: tga-image image>stream
+ drop
+ [
+ component-order>> { RGB ARGB } member? [ bad-tga-unsupported ] unless
+ ] keep
+
+ B{ 0 } write #! id-length
+ B{ 0 } write #! map-type
+ B{ 2 } write #! image-type
+ B{ 0 0 0 0 0 } write #! color map first, length, entry size
+ B{ 0 0 0 0 } write #! x-origin, y-origin
+ {
+ [ dim>> first 2 >le write ]
+ [ dim>> second 2 >le write ]
+ [ component-order>>
+ {
+ { RGB [ B{ 24 } write ] }
+ { ARGB [ B{ 32 } write ] }
+ } case
+ ]
+ [
+ dup component-order>>
+ {
+ { RGB [ 0 ] }
+ { ARGB [ 8 ] }
+ } case swap
+ upside-down?>> [ 0 ] [ 2 ] if 3 shift bitor
+ 1 >le write
+ ]
+ [ bitmap>> write ]
+ } cleave ;
+
} ;
ARTICLE: "delete-move-copy" "Deleting, moving, and copying files"
-"Operations for deleting and copying files come in two forms:"
-{ $list
- { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." }
- { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." }
-}
"The operations for moving and copying files come in three flavors:"
{ $list
{ "A word named " { $snippet { $emphasis "operation" } } " which takes a source and destination path." }
"On most operating systems, files can only be moved within the same file system. To move files between file systems, use " { $link copy-file } " followed by " { $link delete-file } " on the old name." ;
ARTICLE: "io.directories" "Directory manipulation"
-"The " { $vocab-link "io.directories" } " vocabulary defines words for inspecting and manipulating directory trees."
+"The " { $vocab-link "io.directories" } " vocabulary defines words for inspecting and manipulating directories."
{ $subsections
home
"current-directory"
ARTICLE: "io.directories.hierarchy" "Directory hierarchy manipulation"
"The " { $vocab-link "io.directories.hierarchy" } " vocabulary defines words for operating on directory hierarchies recursively."
$nl
+"There is a naming scheme used by " { $vocab-link "io.directories" } " and " { $vocab-link "io.directories.hierarchy" } ". Operations for deleting and copying files come in two forms:"
+{ $list
+ { "Words named " { $snippet { $emphasis "operation" } "-file" } " which work on regular files only." }
+ { "Words named " { $snippet { $emphasis "operation" } "-tree" } " works on directory trees recursively, and also accepts regular files." }
+}
"Deleting directory trees recursively:"
{ $subsections delete-tree }
"Copying directory trees recursively:"
-! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
+! Copyright (C) 2007, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays continuations io
io.backend.windows io.pipes.windows.nt io.pathnames libc
io.launcher kernel sequences windows.errors splitting system
threads init strings combinators io.backend accessors
concurrency.flags io.files assocs io.files.private windows
-destructors classes classes.struct specialized-arrays ;
+destructors classes classes.struct specialized-arrays
+debugger prettyprint ;
SPECIALIZED-ARRAY: ushort
SPECIALIZED-ARRAY: void*
IN: io.launcher.windows
M: windows current-process-handle ( -- handle )
GetCurrentProcessId ;
+ERROR: launch-error process error ;
+
+M: launch-error error.
+ "Launching failed with error:" print
+ dup error>> error. nl
+ "Launch descriptor:" print nl
+ process>> . ;
+
M: windows run-process* ( process -- handle )
[
- current-directory get absolute-path cd
-
- dup make-CreateProcess-args
- [ fill-redirection ] keep
- dup call-CreateProcess
- lpProcessInformation>>
- ] with-destructors ;
+ [
+ current-directory get absolute-path cd
+
+ dup make-CreateProcess-args
+ [ fill-redirection ] keep
+ dup call-CreateProcess
+ lpProcessInformation>>
+ ] with-destructors
+ ] [ launch-error ] recover ;
M: windows kill-process* ( handle -- )
hProcess>> 255 TerminateProcess win32-error=0/f ;
{ $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." }
{ $examples
{ $code
- "10 ["
+ "10 iota ["
" \"Hello world\\n\""
" swap 10 / 1 <gray> foreground associate format"
"] each"
{ $description "Character style. An instance of " { $link color } ". See " { $link "colors" } "." }
{ $examples
{ $code
- "10 ["
+ "10 iota ["
" \"Hello world\\n\""
- " swap 10 / 1 1 over - over 1 <rgba>"
+ " swap 10 / 1 over - over 1 <rgba>"
" background associate format nl"
"] each"
}
: with-interactive-vocabs ( quot -- )
[
- <manifest> manifest set
"scratchpad" set-current-vocab
interactive-vocabs get only-use-vocabs
call
- ] with-scope ; inline
+ ] with-manifest ; inline
: listener ( -- )
- [ [ { } (listener) ] with-interactive-vocabs ] with-return ;
+ [ [ { } (listener) ] with-return ] with-interactive-vocabs ;
MAIN: listener
HELP: :>
{ $syntax ":> var" ":> var!" ":> ( var-1 var-2 ... )" }
-{ $description "Binds one or more new lexical variables. In the " { $snippet ":> var" } " form, the value on the top of the datastack to a new lexical variable named " { $snippet "var" } " and scoped to the enclosing quotation, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: :: } " definition."
+{ $description "Binds one or more new lexical variables. In the " { $snippet ":> var" } " form, the value on the top of the datastack is bound to a new lexical variable named " { $snippet "var" } " and is scoped to the enclosing quotation, " { $link POSTPONE: [let } " form, or " { $link POSTPONE: :: } " definition."
$nl
-"The " { $snippet ":> ( var-1 ... )" } " form binds multiple variables to the top values off the datastack in left to right order. These two snippets have the same effect:"
+"The " { $snippet ":> ( var-1 ... )" } " form binds multiple variables to the top values of the datastack in right to left order, with the last variable bound to the top of the datastack. These two snippets have the same effect:"
{ $code ":> c :> b :> a" }
{ $code ":> ( a b c )" }
$nl
$nl
{ $heading "Mutable bindings" }
-"This next example demonstrates closures and mutable variable bindings. The " { $snippet "make-counter" } " word outputs a tuple containing a pair of quotations that respectively increment and decrement an internal counter in the mutable " { $snippet "value" } " variable and then return the new value. The quotations close over the counter, so each invocation of the word gives new quotations with a new internal counter."
+"This next example demonstrates closures and mutable variable bindings. The " { $snippet "<counter>" } " word outputs a tuple containing a pair of quotations that respectively increment and decrement an internal counter in the mutable " { $snippet "value" } " variable and then return the new value. The quotations close over the counter, so each invocation of the word gives new quotations with a new internal counter."
{ $example
"""USING: locals kernel math ;
IN: scratchpad
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
+[ ] [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ;" eval( -- ) ] unit-test
+ [ "IN: macros.tests USE: macros MACRO: foo ( -- x ) [ ] ; inline" eval( -- ) ] must-fail
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser kernel sequences words effects combinators assocs
definitions quotations namespaces memoize accessors
PREDICATE: macro < word "macro" word-prop >boolean ;
+M: macro make-inline cannot-be-inline ;
+
M: macro definer drop \ MACRO: \ ; ;
M: macro definition "macro" word-prop ;
M: macro reset-word
[ call-next-method ] [ f "macro" set-word-prop ] bi ;
-M: macro bump-effect-counter* drop t ;
+M: macro always-bump-effect-counter? drop t ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts math math.order namespaces sequences
sequences.private accessors classes.tuple arrays ;
M: range nth-unsafe ( n range -- obj ) [ step>> * ] keep from>> + ; inline
-! For ranges with many elements, the default element-wise methods
-! sequences define are unsuitable because they're O(n)
-M: range equal? over range? [ tuple= ] [ 2drop f ] if ;
-
+! We want M\ tuple hashcode, not M\ sequence hashcode here!
+! sequences hashcode is O(n) in number of elements
M: range hashcode* tuple-hashcode ;
INSTANCE: range immutable-sequence
: [1,b] ( b -- range ) 1 swap [a,b] ; inline
: [0,b) ( b -- range ) 0 swap [a,b) ; inline
+
+: [1,b) ( b -- range ) 1 swap [a,b) ; inline
}
{ $description "Takes " { $snippet "n" } " samples at random without replacement from a sequence. Throws an error if " { $snippet "n" } " is longer than the sequence." }
{ $examples
- { $unchecked-example "USING: random prettyprint ; { 1 2 3 } 2 sample ."
- "{ 3 2 }"
+ { $unchecked-example "USING: random prettyprint ;"
+ "{ 1 2 3 } 2 sample ."
+ "{ 3 2 }"
}
} ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types assocs byte-arrays byte-vectors
-combinators fry io.backend io.binary kernel locals math
-math.bitwise math.constants math.functions math.ranges
-namespaces sequences sets summary system vocabs.loader ;
+USING: accessors alien.c-types arrays assocs byte-arrays
+byte-vectors combinators fry io.backend io.binary kernel locals
+math math.bitwise math.constants math.functions math.order
+math.ranges namespaces sequences sets summary system
+vocabs.loader ;
IN: random
SYMBOL: system-random-generator
: random-32 ( -- n ) random-generator get random-32* ;
-: randomize ( seq -- seq )
- dup length [ dup 1 > ]
+: randomize-n-last ( seq n -- seq )
+ [ dup length dup ] dip - 1 max '[ dup _ > ]
[ [ random ] [ 1 - ] bi [ pick exchange ] keep ]
while drop ;
-ERROR: too-many-samples seq n ;
-
-<PRIVATE
+: randomize ( seq -- seq )
+ dup length randomize-n-last ;
-:: next-sample ( length n seq hashtable -- elt )
- n hashtable key? [
- length n 1 + length mod seq hashtable next-sample
- ] [
- n hashtable conjoin
- n seq nth
- ] if ;
-
-PRIVATE>
+ERROR: too-many-samples seq n ;
: sample ( seq n -- seq' )
2dup [ length ] dip < [ too-many-samples ] when
- swap [ length ] [ ] bi H{ } clone
- '[ _ dup random _ _ next-sample ] replicate ;
+ [ [ length iota >array ] dip [ randomize-n-last ] keep tail-slice* ]
+ [ drop ] 2bi nths ;
: delete-random ( seq -- elt )
[ length random-integer ] keep [ nth ] 2keep remove-nth! drop ;
: <sfmt-array> ( sfmt -- uint-array uint-4-array )
state>>
- [ n>> 4 * 1 swap [a,b] >uint-array ] [ seed>> ] bi
+ [ n>> 4 * [1,b] >uint-array ] [ seed>> ] bi
[
[
[ -30 shift ] [ ] bi bitxor
USING: accessors alien.c-types alien.data byte-arrays
combinators.short-circuit continuations destructors init kernel
locals namespaces random windows.advapi32 windows.errors
-windows.kernel32 windows.types math.bitwise ;
+windows.kernel32 windows.types math.bitwise sequences fry
+literals ;
IN: random.windows
TUPLE: windows-rng provider type ;
[ CryptGenRandom win32-error=0/f ] keep
] with-destructors ;
+ERROR: no-windows-crypto-provider error ;
+
+: try-crypto-providers ( seq -- windows-rng )
+ [ first2 <windows-rng> ] attempt-all
+ dup windows-rng? [ no-windows-crypto-provider ] unless ;
+
[
- MS_DEF_PROV
- PROV_RSA_FULL <windows-rng> system-random-generator set-global
+ {
+ ${ MS_ENHANCED_PROV PROV_RSA_FULL }
+ ${ MS_DEF_PROV PROV_RSA_FULL }
+ } try-crypto-providers
+ system-random-generator set-global
- [ MS_STRONG_PROV PROV_RSA_FULL <windows-rng> ]
- [ drop MS_ENH_RSA_AES_PROV PROV_RSA_AES <windows-rng> ] recover
- secure-random-generator set-global
+ {
+ ${ MS_STRONG_PROV PROV_RSA_FULL }
+ ${ MS_ENH_RSA_AES_PROV PROV_RSA_AES }
+ } try-crypto-providers secure-random-generator set-global
] "random.windows" add-startup-hook
[
M: wrapper apply-object
wrapped>>
- [ dup word? [ called-dependency depends-on ] [ drop ] if ]
+ [ dup word? [ depends-on-effect ] [ drop ] if ]
[ push-literal ]
bi ;
-IN: stack-checker.dependencies.tests
-USING: tools.test stack-checker.dependencies words kernel namespaces
-definitions ;
-: computing-dependencies ( quot -- dependencies )
- H{ } clone [ dependencies rot with-variable ] keep ;
- inline
-
-SYMBOL: a
-SYMBOL: b
-
-[ ] [ a called-dependency depends-on ] unit-test
-
-[ H{ { a called-dependency } } ] [
- [ a called-dependency depends-on ] computing-dependencies
-] unit-test
-
-[ H{ { a called-dependency } { b inlined-dependency } } ] [
- [
- a called-dependency depends-on b inlined-dependency depends-on
- ] computing-dependencies
-] unit-test
-
-[ H{ { a inlined-dependency } { b inlined-dependency } } ] [
- [
- a inlined-dependency depends-on
- a called-dependency depends-on
- b inlined-dependency depends-on
- ] computing-dependencies
-] unit-test
-
-[ flushed-dependency ] [ f flushed-dependency strongest-dependency ] unit-test
-[ flushed-dependency ] [ flushed-dependency f strongest-dependency ] unit-test
-[ inlined-dependency ] [ flushed-dependency inlined-dependency strongest-dependency ] unit-test
-[ inlined-dependency ] [ called-dependency inlined-dependency strongest-dependency ] unit-test
-[ flushed-dependency ] [ called-dependency flushed-dependency strongest-dependency ] unit-test
-[ called-dependency ] [ called-dependency f strongest-dependency ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: assocs classes.algebra fry kernel math namespaces
-sequences words ;
+USING: assocs accessors classes.algebra fry generic kernel math
+namespaces sequences words sets combinators.short-circuit ;
+FROM: classes.tuple.private => tuple-layout ;
IN: stack-checker.dependencies
! Words that the current quotation depends on
SYMBOL: dependencies
-SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
+SYMBOLS: effect-dependency conditional-dependency definition-dependency ;
: index>= ( obj1 obj2 seq -- ? )
[ index ] curry bi@ >= ;
: dependency>= ( how1 how2 -- ? )
- { called-dependency flushed-dependency inlined-dependency }
+ { effect-dependency conditional-dependency definition-dependency }
index>= ;
: strongest-dependency ( how1 how2 -- how )
- [ called-dependency or ] bi@ [ dependency>= ] most ;
+ [ effect-dependency or ] bi@ [ dependency>= ] most ;
: depends-on ( word how -- )
over primitive? [ 2drop ] [
] [ 3drop ] if
] if ;
+: depends-on-effect ( word -- )
+ effect-dependency depends-on ;
+
+: depends-on-conditionally ( word -- )
+ conditional-dependency depends-on ;
+
+: depends-on-definition ( word -- )
+ definition-dependency depends-on ;
+
! Generic words that the current quotation depends on
SYMBOL: generic-dependencies
-: ?class-or ( class/f class -- class' )
- swap [ class-or ] when* ;
+: ?class-or ( class class/f -- class' )
+ [ class-or ] when* ;
-: depends-on-generic ( generic class -- )
+: depends-on-generic ( class generic -- )
generic-dependencies get dup
- [ swap '[ _ ?class-or ] change-at ] [ 3drop ] if ;
+ [ [ ?class-or ] change-at ] [ 3drop ] if ;
+
+! Conditional dependencies are re-evaluated when classes change;
+! if any fail, the word is recompiled
+SYMBOL: conditional-dependencies
+
+GENERIC: satisfied? ( dependency -- ? )
+
+: add-conditional-dependency ( ... class -- )
+ boa conditional-dependencies get
+ dup [ conjoin ] [ 2drop ] if ; inline
+
+TUPLE: depends-on-class<= class1 class2 ;
+
+: depends-on-class<= ( class1 class2 -- )
+ \ depends-on-class<= add-conditional-dependency ;
+
+M: depends-on-class<= satisfied?
+ {
+ [ class1>> classoid? ]
+ [ class2>> classoid? ]
+ [ [ class1>> ] [ class2>> ] bi class<= ]
+ } 1&& ;
+
+TUPLE: depends-on-classes-disjoint class1 class2 ;
+
+: depends-on-classes-disjoint ( class1 class2 -- )
+ \ depends-on-classes-disjoint add-conditional-dependency ;
+
+M: depends-on-classes-disjoint satisfied?
+ {
+ [ class1>> classoid? ]
+ [ class2>> classoid? ]
+ [ [ class1>> ] [ class2>> ] bi classes-intersect? not ]
+ } 1&& ;
+
+TUPLE: depends-on-next-method class generic next-method ;
+
+: depends-on-next-method ( class generic next-method -- )
+ over depends-on-conditionally
+ \ depends-on-next-method add-conditional-dependency ;
+
+M: depends-on-next-method satisfied?
+ {
+ [ class>> classoid? ]
+ [ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
+ } 1&& ;
+
+TUPLE: depends-on-method class generic method ;
+
+: depends-on-method ( class generic method -- )
+ over depends-on-conditionally
+ \ depends-on-method add-conditional-dependency ;
+
+M: depends-on-method satisfied?
+ {
+ [ class>> classoid? ]
+ [ [ [ class>> ] [ generic>> ] bi method-for-class ] [ method>> ] bi eq? ]
+ } 1&& ;
+
+TUPLE: depends-on-tuple-layout class layout ;
+
+: depends-on-tuple-layout ( class layout -- )
+ [ drop depends-on-conditionally ]
+ [ \ depends-on-tuple-layout add-conditional-dependency ] 2bi ;
+
+M: depends-on-tuple-layout satisfied?
+ [ class>> tuple-layout ] [ layout>> ] bi eq? ;
+
+TUPLE: depends-on-flushable word ;
+
+: depends-on-flushable ( word -- )
+ [ depends-on-conditionally ]
+ [ \ depends-on-flushable add-conditional-dependency ] bi ;
+
+M: depends-on-flushable satisfied?
+ word>> flushable? ;
+
+: init-dependencies ( -- )
+ H{ } clone dependencies set
+ H{ } clone generic-dependencies set
+ H{ } clone conditional-dependencies set ;
+
+: without-dependencies ( quot -- )
+ [
+ dependencies off
+ generic-dependencies off
+ conditional-dependencies off
+ call
+ ] with-scope ; inline
: inline-word ( word -- )
commit-literals
- [ inlined-dependency depends-on ]
+ [ depends-on-definition ]
[
dup inline-recursive-label [
call-recursive-inline-word
\ clear t "no-compile" set-word-prop
: non-inline-word ( word -- )
- dup called-dependency depends-on
+ dup depends-on-effect
{
{ [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
{ [ dup "special" word-prop ] [ infer-special ] }
"The following code now passes the stack checker; it would fail were " { $snippet "twice" } " not declared " { $link POSTPONE: inline } ":"
{ $unchecked-example "USE: math.functions" "[ [ sqrt ] twice ] infer." "( x -- x )" }
{ $subheading "Defining a combinator for unknown quotations" }
-"In the next example, " { $link POSTPONE: call( } " must be used because the quotation the result of calling a runtime accessor, and the compiler cannot make any static assumptions about this quotation at all:"
+"In the next example, " { $link POSTPONE: call( } " must be used because the quotation is the result of calling a runtime accessor, and the compiler cannot make any static assumptions about this quotation at all:"
{ $code
"TUPLE: action name quot ;"
": perform ( value action -- result ) quot>> call( value -- result ) ;"
HELP: define-transform
{ $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } }
-{ $description "Defines a compiler transform for the optimizing compiler."
- "When a call to " { $snippet "word" } " is being compiled, the compiler first checks that the top " { $snippet "n" } " stack values are literal, and if so, calls the quotation with those inputs at compile time. The quotation can output a new quotation, or " { $link f } "."
+{ $description "Defines a compiler transform for the optimizing compiler. When a call to " { $snippet "word" } " is being compiled, the compiler first checks that the top " { $snippet "n" } " stack values are literal, and if so, calls the quotation with those inputs at compile time. The quotation can output a new quotation, or " { $link f } "."
$nl
"If the quotation outputs " { $link f } ", or if not all inputs are literal, a call to the word is compiled as usual, or compilation fails if the word does not have a static stack effect."
$nl
\ 3|| t "no-compile" set-word-prop
+: add-next-method-dependency ( method -- )
+ [ "method-class" word-prop ]
+ [ "method-generic" word-prop ] bi
+ 2dup next-method
+ depends-on-next-method ;
+
\ (call-next-method) [
- [
- [ "method-class" word-prop ]
- [ "method-generic" word-prop ] bi
- [ inlined-dependency depends-on ] bi@
- ] [
- [ next-method-quot ]
- [ '[ _ no-next-method ] ] bi or
- ] bi
+ [ add-next-method-dependency ]
+ [ [ next-method-quot ] [ '[ _ no-next-method ] ] bi or ] bi
] 1 define-transform
\ (call-next-method) t "no-compile" set-word-prop
! Constructors
\ boa [
dup tuple-class? [
- dup inlined-dependency depends-on
- [ "boa-check" word-prop [ ] or ]
- [ tuple-layout '[ _ <tuple-boa> ] ]
- bi append
+ dup tuple-layout
+ [ depends-on-tuple-layout ]
+ [ [ "boa-check" word-prop [ ] or ] dip ] 2bi
+ '[ @ _ <tuple-boa> ]
] [ drop f ] if
] 1 define-transform
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors io.backend io.streams.c init fry
namespaces math make assocs kernel parser parser.notes lexer
generic.single tools.deploy.config combinators classes
classes.builtin slots.private grouping command-line ;
QUALIFIED: bootstrap.stage2
+QUALIFIED: classes.private
QUALIFIED: compiler.crossref
QUALIFIED: compiler.errors
QUALIFIED: continuations
"boa-check"
"coercer"
"combination"
- "compiled-generic-uses"
- "compiled-uses"
+ "generic-call-sites"
+ "effect-dependencies"
+ "definition-dependencies"
+ "conditional-dependencies"
+ "dependency-checks"
"constant"
"constraints"
"custom-inlining"
"members"
"memo-quot"
"methods"
- "mixin"
"method-class"
"method-generic"
"modular-arithmetic"
{
gensym
name>char-hook
- next-method-quot-cache
- class-and-cache
- class-not-cache
- class-or-cache
- class<=-cache
- classes-intersect-cache
- implementors-map
- update-map
+ classes.private:next-method-quot-cache
+ classes.private:class-and-cache
+ classes.private:class-not-cache
+ classes.private:class-or-cache
+ classes.private:class<=-cache
+ classes.private:classes-intersect-cache
+ classes.private:implementors-map
+ classes.private:update-map
main-vocab-hook
compiler.crossref:compiled-crossref
- compiler.crossref:compiled-generic-crossref
+ compiler.crossref:generic-call-site-crossref
compiler-impl
compiler.errors:compiler-errors
lexer-factory
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors words sequences math prettyprint kernel arrays
io io.styles namespaces assocs kernel.private strings
: profiler-usage ( word -- words )
[ smart-usage [ word? ] filter ]
- [ compiled-generic-usage keys ]
- [ compiled-usage keys ]
+ [ generic-call-sites-of keys ]
+ [ effect-dependencies-of keys ]
tri 3append prune ;
: usage-counters ( word -- alist )
>>
+PRIVATE>
+
: run-test-file ( path -- )
dup file [
test-failures get file get +test-failure+ delete-file-errors
'[ _ run-file ] [ file-failure ] recover
] with-variable ;
+<PRIVATE
+
: run-vocab-tests ( vocab -- )
- dup vocab source-loaded?>> [
- vocab-tests [ run-test-file ] each
+ vocab dup [
+ dup source-loaded?>> [
+ vocab-tests [ run-test-file ] each
+ ] [ drop ] if
] [ drop ] if ;
PRIVATE>
math kernel kernel.private namespaces parser quotations
sequences slots words locals
locals.parser macros stack-checker.dependencies ;
+FROM: classes.tuple.private => tuple-layout ;
IN: typed
ERROR: type-mismatch-error word expected-types ;
: (unboxer) ( type -- quot )
dup unboxable-tuple-class? [
+ dup dup tuple-layout depends-on-tuple-layout
all-slots [
[ name>> reader-word 1quotation ]
[ class>> (unboxer) ] bi compose
: (unboxed-types) ( type -- types )
dup unboxable-tuple-class?
- [ all-slots [ class>> (unboxed-types) ] map concat ]
+ [
+ dup dup tuple-layout depends-on-tuple-layout
+ all-slots [ class>> (unboxed-types) ] map concat
+ ]
[ 1array ] if ;
: unboxed-types ( types -- types' )
: boxer ( type -- quot )
dup unboxable-tuple-class?
- [ [ all-slots [ class>> ] map make-boxer ] [ [ boa ] curry ] bi compose ]
+ [
+ dup dup tuple-layout depends-on-tuple-layout
+ [ all-slots [ class>> ] map make-boxer ]
+ [ [ boa ] curry ]
+ bi compose
+ ]
[ drop [ ] ] if ;
: make-boxer ( types -- quot )
! defining typed words
-: (depends-on) ( types -- types )
- dup [ inlined-dependency depends-on ] each ; inline
-
MACRO: (typed) ( word def effect -- quot )
[ swap ] dip
[
- nip effect-in-types (depends-on) swap
+ nip effect-in-types swap
[ [ unboxed-types ] [ make-boxer ] bi ] dip
'[ _ declare @ @ ]
]
[
- effect-out-types (depends-on)
+ effect-out-types
dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
] 2bi ;
[ 2nip ] 3tri define-declared ;
MACRO: typed ( quot word effect -- quot' )
- [ effect-in-types (depends-on) dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
+ [ effect-in-types dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
[
- nip effect-out-types (depends-on) dup typed-stack-effect?
+ nip effect-out-types dup typed-stack-effect?
[ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
] 2bi ;
tri
] with-pprint ;
+: filter-interesting ( seq -- seq' )
+ [ [ vocab? ] [ extra-words? ] bi or not ] filter ;
+
PRIVATE>
: (pprint-manifest ( manifest -- quots )
[
[ search-vocabs>> [ '[ _ pprint-using ] , ] unless-empty ]
- [ qualified-vocabs>> [ extra-words? not ] filter [ '[ _ pprint-qualified ] , ] each ]
+ [ qualified-vocabs>> filter-interesting [ '[ _ pprint-qualified ] , ] each ]
[ current-vocab>> [ '[ _ pprint-in ] , ] when* ]
tri
] { } make ;
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax parser namespaces
kernel math windows.types generalizations math.bitwise
-classes.struct literals windows.kernel32 ;
+classes.struct literals windows.kernel32 system accessors ;
IN: windows.user32
! HKL for ActivateKeyboardLayout
CONSTANT: MF_RIGHTJUSTIFY HEX: 4000
CONSTANT: MF_MOUSESELECT HEX: 8000
+TYPEDEF: HANDLE HRAWINPUT
+: GET_RAWINPUT_CODE_WPARAM ( wParam -- n ) HEX: ff bitand ; inline
+
+CONSTANT: RIM_INPUT 0
+CONSTANT: RIM_INPUTSINK 1
+
+CONSTANT: RIM_TYPEMOUSE 0
+CONSTANT: RIM_TYPEKEYBOARD 1
+CONSTANT: RIM_TYPEHID 2
+
+STRUCT: RAWINPUTHEADER
+ { dwType DWORD }
+ { dwSize DWORD }
+ { hDevice HANDLE }
+ { wParam WPARAM } ;
+TYPEDEF: RAWINPUTHEADER* PRAWINPUTHEADER
+TYPEDEF: RAWINPUTHEADER* LPRAWINPUTHEADER
+STRUCT: RAWMOUSE_BUTTONS_USBUTTONS
+ { usButtonFlags USHORT }
+ { usButtonData USHORT } ;
+
+UNION-STRUCT: RAWMOUSE_BUTTONS
+ { ulButtons ULONG }
+ { usButtons RAWMOUSE_BUTTONS_USBUTTONS } ;
+STRUCT: RAWMOUSE
+ { usFlags USHORT }
+ { uButtons RAWMOUSE_BUTTONS }
+ { ulRawButtons ULONG }
+ { lLastX LONG }
+ { lLastY LONG }
+ { ulExtraInformation ULONG } ;
+TYPEDEF: RAWMOUSE* PRAWMOUSE
+TYPEDEF: RAWMOUSE* LPRAWMOUSE
+
+CONSTANT: RI_MOUSE_LEFT_BUTTON_DOWN HEX: 0001
+CONSTANT: RI_MOUSE_LEFT_BUTTON_UP HEX: 0002
+CONSTANT: RI_MOUSE_RIGHT_BUTTON_DOWN HEX: 0004
+CONSTANT: RI_MOUSE_RIGHT_BUTTON_UP HEX: 0008
+CONSTANT: RI_MOUSE_MIDDLE_BUTTON_DOWN HEX: 0010
+CONSTANT: RI_MOUSE_MIDDLE_BUTTON_UP HEX: 0020
+
+: RI_MOUSE_BUTTON_1_DOWN ( -- n ) RI_MOUSE_LEFT_BUTTON_DOWN ; inline
+: RI_MOUSE_BUTTON_1_UP ( -- n ) RI_MOUSE_LEFT_BUTTON_UP ; inline
+: RI_MOUSE_BUTTON_2_DOWN ( -- n ) RI_MOUSE_RIGHT_BUTTON_DOWN ; inline
+: RI_MOUSE_BUTTON_2_UP ( -- n ) RI_MOUSE_RIGHT_BUTTON_UP ; inline
+: RI_MOUSE_BUTTON_3_DOWN ( -- n ) RI_MOUSE_MIDDLE_BUTTON_DOWN ; inline
+: RI_MOUSE_BUTTON_3_UP ( -- n ) RI_MOUSE_MIDDLE_BUTTON_UP ; inline
+
+CONSTANT: RI_MOUSE_BUTTON_4_DOWN HEX: 0040
+CONSTANT: RI_MOUSE_BUTTON_4_UP HEX: 0080
+CONSTANT: RI_MOUSE_BUTTON_5_DOWN HEX: 0100
+CONSTANT: RI_MOUSE_BUTTON_5_UP HEX: 0200
+CONSTANT: RI_MOUSE_WHEEL HEX: 0400
+
+CONSTANT: MOUSE_MOVE_RELATIVE 0
+CONSTANT: MOUSE_MOVE_ABSOLUTE 1
+CONSTANT: MOUSE_VIRTUAL_DESKTOP HEX: 02
+CONSTANT: MOUSE_ATTRIBUTES_CHANGED HEX: 04
+CONSTANT: MOUSE_MOVE_NOCOALESCE HEX: 08
+
+STRUCT: RAWKEYBOARD
+ { MakeCode USHORT }
+ { Flags USHORT }
+ { Reserved USHORT }
+ { VKey USHORT }
+ { Message UINT }
+ { ExtraInformation ULONG } ;
+TYPEDEF: RAWKEYBOARD* PRAWKEYBOARD
+TYPEDEF: RAWKEYBOARD* LPRAWKEYBOARD
+
+CONSTANT: KEYBOARD_OVERRUN_MAKE_CODE HEX: FF
+
+CONSTANT: RI_KEY_MAKE 0
+CONSTANT: RI_KEY_BREAK 1
+CONSTANT: RI_KEY_E0 2
+CONSTANT: RI_KEY_E1 4
+CONSTANT: RI_KEY_TERMSRV_SET_LED 8
+CONSTANT: RI_KEY_TERMSRV_SHADOW HEX: 10
+
+STRUCT: RAWHID
+ { dwSizeHid DWORD }
+ { dwCount DWORD }
+ { bRawData BYTE[1] } ;
+TYPEDEF: RAWHID* PRAWHID
+TYPEDEF: RAWHID* LPRAWHID
+
+UNION-STRUCT: RAWINPUT_UNION
+ { mouse RAWMOUSE }
+ { keyboard RAWKEYBOARD }
+ { hid RAWHID } ;
+STRUCT: RAWINPUT
+ { header RAWINPUTHEADER }
+ { data RAWINPUT_UNION } ;
+TYPEDEF: RAWINPUT* PRAWINPUT
+TYPEDEF: RAWINPUT* LPRAWINPUT
+
+: RAWINPUT_ALIGN ( x -- y )
+ cpu x86.32 = [ 4 ] [ 8 ] if align ; inline
+: NEXTRAWINPUTBLOCK ( struct -- next-struct )
+ dup header>> dwSize>> swap <displaced-alien> RAWINPUT_ALIGN RAWINPUT memory>struct ; inline
+
+CONSTANT: RID_INPUT HEX: 10000003
+CONSTANT: RID_HEADER HEX: 10000005
+CONSTANT: RIDI_PREPARSEDDATA HEX: 20000005
+CONSTANT: RIDI_DEVICENAME HEX: 20000007
+CONSTANT: RIDI_DEVICEINFO HEX: 2000000b
+
+STRUCT: RID_DEVICE_INFO_MOUSE
+ { dwId DWORD }
+ { dwNumberOfButtons DWORD }
+ { dwSampleRate DWORD }
+ { fHasHorizontalWheel BOOL } ;
+TYPEDEF: RID_DEVICE_INFO_MOUSE* PRID_DEVICE_INFO_MOUSE
+
+STRUCT: RID_DEVICE_INFO_KEYBOARD
+ { dwType DWORD }
+ { dwSubType DWORD }
+ { dwKeyboardMode DWORD }
+ { dwNumberOfFunctionKeys DWORD }
+ { dwNumberOfIndicators DWORD }
+ { dwNumberOfKeysTotal DWORD } ;
+TYPEDEF: RID_DEVICE_INFO_KEYBOARD* PRID_DEVICE_INFO_KEYBOARD
+
+STRUCT: RID_DEVICE_INFO_HID
+ { dwVendorId DWORD }
+ { dwProductId DWORD }
+ { dwVersionNumber DWORD }
+ { usUsagePage USHORT }
+ { usUsage USHORT } ;
+TYPEDEF: RID_DEVICE_INFO_HID* PRID_DEVICE_INFO_HID
+
+UNION-STRUCT: RID_DEVICE_INFO_UNION
+ { mouse RID_DEVICE_INFO_MOUSE }
+ { keyboard RID_DEVICE_INFO_KEYBOARD }
+ { hid RID_DEVICE_INFO_HID } ;
+STRUCT: RID_DEVICE_INFO
+ { cbSize DWORD }
+ { dwType DWORD }
+ { data RID_DEVICE_INFO_UNION } ;
+TYPEDEF: RID_DEVICE_INFO* PRID_DEVICE_INFO
+TYPEDEF: RID_DEVICE_INFO* LPRID_DEVICE_INFO
+
+STRUCT: RAWINPUTDEVICE
+ { usUsagePage USHORT }
+ { usUsage USHORT }
+ { dwFlags DWORD }
+ { hwndTarget HWND } ;
+TYPEDEF: RAWINPUTDEVICE* PRAWINPUTDEVICE
+TYPEDEF: RAWINPUTDEVICE* LPRAWINPUTDEVICE
+TYPEDEF: RAWINPUTDEVICE* PCRAWINPUTDEVICE
+
+CONSTANT: RIDEV_REMOVE HEX: 00000001
+CONSTANT: RIDEV_EXCLUDE HEX: 00000010
+CONSTANT: RIDEV_PAGEONLY HEX: 00000020
+CONSTANT: RIDEV_NOLEGACY HEX: 00000030
+CONSTANT: RIDEV_INPUTSINK HEX: 00000100
+CONSTANT: RIDEV_CAPTUREMOUSE HEX: 00000200
+CONSTANT: RIDEV_NOHOTKEYS HEX: 00000200
+CONSTANT: RIDEV_APPKEYS HEX: 00000400
+CONSTANT: RIDEV_EXINPUTSINK HEX: 00001000
+CONSTANT: RIDEV_DEVNOTIFY HEX: 00002000
+CONSTANT: RIDEV_EXMODEMASK HEX: 000000F0
+
+: RIDEV_EXMODE ( mode -- x ) RIDEV_EXMODEMASK bitand ; inline
+
+CONSTANT: GIDC_ARRIVAL 1
+CONSTANT: GIDC_REMOVAL 2
+
+: GET_DEVICE_CHANGE_WPARAM ( wParam -- x ) HEX: ffff bitand ; inline
+
+STRUCT: RAWINPUTDEVICELIST
+ { hDevice HANDLE }
+ { dwType DWORD } ;
+TYPEDEF: RAWINPUTDEVICELIST* PRAWINPUTDEVICELIST
+
LIBRARY: user32
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
! FUNCTION: DefFrameProcW
! FUNCTION: DefMDIChildProcA
! FUNCTION: DefMDIChildProcW
-! FUNCTION: DefRawInputProc
+FUNCTION: LRESULT DefRawInputProc ( PRAWINPUT* paRawInput, INT nInput, UINT cbSizeHeader ) ;
FUNCTION: LRESULT DefWindowProcW ( HWND hWnd, UINT Msg, WPARAM wParam, LPARAM lParam ) ;
ALIAS: DefWindowProc DefWindowProcW
! FUNCTION: DeleteMenu
! FUNCTION: GetPropA
! FUNCTION: GetPropW
! FUNCTION: GetQueueStatus
-! FUNCTION: GetRawInputBuffer
-! FUNCTION: GetRawInputData
-! FUNCTION: GetRawInputDeviceInfoA
-! FUNCTION: GetRawInputDeviceInfoW
-! FUNCTION: GetRawInputDeviceList
+FUNCTION: UINT GetRawInputBuffer ( PRAWINPUT pData, PUINT pcbSize, UINT cbSizeHeader ) ;
+FUNCTION: UINT GetRawInputData ( HRAWINPUT hRawInput, UINT uiCommand, LPVOID pData, PUINT pcbSize, UINT cbSizeHeader ) ;
+FUNCTION: UINT GetRawInputDeviceInfoA ( HANDLE hDevice, UINT uiCommand, LPVOID pData, PUINT pcbSize ) ;
+FUNCTION: UINT GetRawInputDeviceInfoW ( HANDLE hDevice, UINT uiCommand, LPVOID pData, PUINT pcbSize ) ;
+ALIAS: GetRawInputDeviceInfo GetRawInputDeviceInfoW
+FUNCTION: UINT GetRawInputDeviceList ( PRAWINPUTDEVICELIST pRawInputDeviceList, PUINT puiNumDevices, UINT cbSize ) ;
+FUNCTION: UINT GetRegisteredRawInputDevices ( PRAWINPUTDEVICE pRawInputDevices, PUINT puiNumDevices, UINT cbSize ) ;
! FUNCTION: GetReasonTitleFromReasonCode
-! FUNCTION: GetRegisteredRawInputDevices
! FUNCTION: GetScrollBarInfo
! FUNCTION: GetScrollInfo
! FUNCTION: GetScrollPos
! FUNCTION: RegisterHotKey
! FUNCTION: RegisterLogonProcess
! FUNCTION: RegisterMessagePumpHook
-! FUNCTION: RegisterRawInputDevices
+FUNCTION: BOOL RegisterRawInputDevices ( PCRAWINPUTDEVICE pRawInputDevices, UINT uiNumDevices, UINT cbSize ) ;
! FUNCTION: RegisterServicesProcess
! FUNCTION: RegisterShellHookWindow
! FUNCTION: RegisterSystemThread
{ $see-also at* assoc-size } ;
ARTICLE: "assocs-values" "Transposed assoc operations"
-"default Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:"
+"Most assoc words take a key and find the corresponding value. The following words take a value and find the corresponding key:"
{ $subsections
value-at
value-at*
USING: alien alien.strings arrays byte-arrays generic hashtables
hashtables.private io io.encodings.ascii kernel math
math.private math.order namespaces make parser sequences strings
-vectors words quotations assocs layouts classes classes.builtin
-classes.tuple classes.tuple.private kernel.private vocabs
-vocabs.loader source-files definitions slots classes.union
-classes.intersection classes.predicate compiler.units
-bootstrap.image.private io.files accessors combinators ;
+vectors words quotations assocs layouts classes classes.private
+classes.builtin classes.tuple classes.tuple.private
+kernel.private vocabs vocabs.loader source-files definitions
+slots classes.union classes.intersection classes.predicate
+compiler.units bootstrap.image.private io.files accessors
+combinators ;
IN: bootstrap.primitives
"Creating primitives and basic runtime structures..." print flush
! Now we have ( syntax-quot arch-quot layouts-quot ) on the stack
! Bring up a bare cross-compiling vocabulary.
-"syntax" vocab vocab-words bootstrap-syntax set {
- dictionary
- new-classes
- changed-definitions changed-generics changed-effects
- outdated-generics forgotten-definitions
- root-cache source-files update-map implementors-map
-} [ H{ } clone swap set ] each
+"syntax" vocab vocab-words bootstrap-syntax set
-init-caches
+H{ } clone dictionary set
+H{ } clone root-cache set
+H{ } clone source-files set
+H{ } clone update-map set
+H{ } clone implementors-map set
-! Vocabulary for slot accessors
-"accessors" create-vocab drop
+init-caches
-dummy-compiler compiler-impl set
+bootstrapping? on
call( -- )
call( -- )
-call( -- )
+
+! Vocabulary for slot accessors
+"accessors" create-vocab drop
! After we execute bootstrap/layouts
num-types get f <array> builtins set
-bootstrapping? on
-
[
+call( -- )
+
! Create some empty vocabs where the below primitives and
! classes will go
{
prepare-slots make-slots 1 finalize-slots
[ "slots" set-word-prop ] [ define-accessors ] 2bi ;
+: define-builtin-predicate ( class -- )
+ dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
+
: define-builtin ( symbol slotspec -- )
[ [ define-builtin-predicate ] keep ] dip define-builtin-slots ;
-USING: help.markup help.syntax kernel classes words\r
+USING: help.markup help.syntax kernel classes classes.private words\r
checksums checksums.crc32 sequences math ;\r
IN: classes.algebra\r
\r
-USING: alien arrays definitions generic assocs hashtables io\r
-kernel math namespaces parser prettyprint sequences strings\r
-tools.test words quotations classes classes.algebra\r
-classes.private classes.union classes.mixin classes.predicate\r
-vectors source-files compiler.units growable random\r
-stack-checker effects kernel.private sbufs math.order\r
-classes.tuple accessors generic.private ;\r
-IN: classes.algebra.tests\r
-\r
-TUPLE: first-one ;\r
-TUPLE: second-one ;\r
-UNION: both first-one union-class ;\r
-\r
-PREDICATE: no-docs < word "documentation" word-prop not ;\r
-\r
-UNION: no-docs-union no-docs integer ;\r
-\r
-TUPLE: a ;\r
-TUPLE: b ;\r
-UNION: c a b ;\r
-\r
-TUPLE: tuple-example ;\r
-\r
-TUPLE: a1 ;\r
-TUPLE: b1 ;\r
-TUPLE: c1 ;\r
-\r
-UNION: x1 a1 b1 ;\r
-UNION: y1 a1 c1 ;\r
-UNION: z1 b1 c1 ;\r
-\r
-SINGLETON: sa\r
-SINGLETON: sb\r
-SINGLETON: sc\r
-\r
-INTERSECTION: empty-intersection ;\r
-\r
-INTERSECTION: generic-class generic class ;\r
-\r
-UNION: union-with-one-member a ;\r
-\r
-MIXIN: mixin-with-one-member\r
-INSTANCE: union-with-one-member mixin-with-one-member\r
-\r
-! class<=\r
-[ t ] [ \ fixnum \ integer class<= ] unit-test\r
-[ t ] [ \ fixnum \ fixnum class<= ] unit-test\r
-[ f ] [ \ integer \ fixnum class<= ] unit-test\r
-[ t ] [ \ integer \ object class<= ] unit-test\r
-[ f ] [ \ integer \ null class<= ] unit-test\r
-[ t ] [ \ null \ object class<= ] unit-test\r
-\r
-[ t ] [ \ generic \ word class<= ] unit-test\r
-[ f ] [ \ word \ generic class<= ] unit-test\r
-\r
-[ f ] [ \ reversed \ slice class<= ] unit-test\r
-[ f ] [ \ slice \ reversed class<= ] unit-test\r
-\r
-[ t ] [ no-docs no-docs-union class<= ] unit-test\r
-[ f ] [ no-docs-union no-docs class<= ] unit-test\r
-\r
-[ t ] [ \ c \ tuple class<= ] unit-test\r
-[ f ] [ \ tuple \ c class<= ] unit-test\r
-\r
-[ t ] [ \ tuple-class \ class class<= ] unit-test\r
-[ f ] [ \ class \ tuple-class class<= ] unit-test\r
-\r
-[ t ] [ \ null \ tuple-example class<= ] unit-test\r
-[ f ] [ \ object \ tuple-example class<= ] unit-test\r
-[ f ] [ \ object \ tuple-example class<= ] unit-test\r
-[ t ] [ \ tuple-example \ tuple class<= ] unit-test\r
-[ f ] [ \ tuple \ tuple-example class<= ] unit-test\r
-\r
-[ f ] [ z1 x1 y1 class-and class<= ] unit-test\r
-\r
-[ t ] [ x1 y1 class-and a1 class<= ] unit-test\r
-\r
-[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test\r
-\r
-[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test\r
-\r
-[ t ] [ growable tuple sequence class-and class<= ] unit-test\r
-\r
-[ t ] [ growable assoc class-and tuple class<= ] unit-test\r
-\r
-[ t ] [ object \ f \ f class-not class-or class<= ] unit-test\r
-\r
-[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test\r
-\r
-[ t ] [ array number class-not class<= ] unit-test\r
-\r
-[ f ] [ bignum number class-not class<= ] unit-test\r
-\r
-[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not integer class-and array class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not integer class<= ] unit-test\r
-\r
-[ f ] [ number class-not array class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not array class<= ] unit-test\r
-\r
-[ t ] [ number class-not integer class-not class<= ] unit-test\r
-\r
-[ f ] [ fixnum class-not integer class<= ] unit-test\r
-\r
-[ t ] [ object empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection object class<= ] unit-test\r
-[ t ] [ \ f class-not empty-intersection class<= ] unit-test\r
-[ f ] [ empty-intersection \ f class-not class<= ] unit-test\r
-[ t ] [ \ number empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection class-not null class<= ] unit-test\r
-[ t ] [ null empty-intersection class-not class<= ] unit-test\r
-\r
-[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test\r
-[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test\r
-\r
-[ t ] [ object \ f class-not \ f class-or class<= ] unit-test\r
-\r
-[ t ] [\r
- fixnum class-not\r
- fixnum fixnum class-not class-or\r
- class<=\r
-] unit-test\r
-\r
-[ t ] [ generic-class generic class<= ] unit-test\r
-[ t ] [ generic-class \ class class<= ] unit-test\r
-\r
-[ t ] [ a union-with-one-member class<= ] unit-test\r
-[ f ] [ union-with-one-member class-not integer class<= ] unit-test\r
-\r
-! class-and\r
-: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;\r
-\r
-[ t ] [ object object object class-and* ] unit-test\r
-[ t ] [ fixnum object fixnum class-and* ] unit-test\r
-[ t ] [ object fixnum fixnum class-and* ] unit-test\r
-[ t ] [ fixnum fixnum fixnum class-and* ] unit-test\r
-[ t ] [ fixnum integer fixnum class-and* ] unit-test\r
-[ t ] [ integer fixnum fixnum class-and* ] unit-test\r
-\r
-[ t ] [ vector fixnum null class-and* ] unit-test\r
-[ t ] [ number object number class-and* ] unit-test\r
-[ t ] [ object number number class-and* ] unit-test\r
-[ t ] [ slice reversed null class-and* ] unit-test\r
-[ t ] [ \ f class-not \ f null class-and* ] unit-test\r
-\r
-[ t ] [ vector virtual-sequence null class-and* ] unit-test\r
-\r
-[ t ] [ vector array class-not vector class-and* ] unit-test\r
-\r
-! class-or\r
-: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;\r
-\r
-[ t ] [ \ f class-not \ f object class-or* ] unit-test\r
-\r
-! class-not\r
-[ vector ] [ vector class-not class-not ] unit-test\r
-\r
-! classes-intersect?\r
-[ t ] [ both tuple classes-intersect? ] unit-test\r
-[ f ] [ vector virtual-sequence classes-intersect? ] unit-test\r
-\r
-[ t ] [ number vector class-or sequence classes-intersect? ] unit-test\r
-\r
-[ f ] [ number vector class-and sequence classes-intersect? ] unit-test\r
-\r
-[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test\r
-\r
-[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test\r
-\r
-[ f ] [ integer integer class-not classes-intersect? ] unit-test\r
-\r
-[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test\r
-\r
-[ t ] [ \ word generic-class classes-intersect? ] unit-test\r
-[ f ] [ number generic-class classes-intersect? ] unit-test\r
-\r
-[ f ] [ sa sb classes-intersect? ] unit-test\r
-\r
-[ t ] [ a union-with-one-member classes-intersect? ] unit-test\r
-[ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test\r
-[ t ] [ object union-with-one-member classes-intersect? ] unit-test\r
-\r
-[ t ] [ union-with-one-member a classes-intersect? ] unit-test\r
-[ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test\r
-[ t ] [ union-with-one-member object classes-intersect? ] unit-test\r
-\r
-[ t ] [ a mixin-with-one-member classes-intersect? ] unit-test\r
-[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test\r
-[ t ] [ object mixin-with-one-member classes-intersect? ] unit-test\r
-\r
-[ t ] [ mixin-with-one-member a classes-intersect? ] unit-test\r
-[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test\r
-[ t ] [ mixin-with-one-member object classes-intersect? ] unit-test\r
-\r
-! class=\r
-[ t ] [ null class-not object class= ] unit-test\r
-\r
-[ t ] [ object class-not null class= ] unit-test\r
-\r
-[ f ] [ object class-not object class= ] unit-test\r
-\r
-[ f ] [ null class-not null class= ] unit-test\r
-\r
-! class<=>\r
-\r
-[ +lt+ ] [ sequence object class<=> ] unit-test\r
-[ +gt+ ] [ object sequence class<=> ] unit-test\r
-[ +eq+ ] [ integer integer class<=> ] unit-test\r
-\r
-! smallest-class etc\r
-[ real ] [ { real sequence } smallest-class ] unit-test\r
-[ real ] [ { sequence real } smallest-class ] unit-test\r
-\r
-: min-class ( class classes -- class/f )\r
- interesting-classes smallest-class ;\r
-\r
-[ f ] [ fixnum { } min-class ] unit-test\r
-\r
-[ string ] [\r
- \ string\r
- [ integer string array reversed sbuf\r
- slice vector quotation ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ fixnum ] [\r
- \ fixnum\r
- [ fixnum integer object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ integer ] [\r
- \ fixnum\r
- [ integer float object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ object ] [\r
- \ word\r
- [ integer float object ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ reversed ] [\r
- \ reversed\r
- [ integer reversed slice ]\r
- sort-classes min-class\r
-] unit-test\r
-\r
-[ f ] [ null { number fixnum null } min-class ] unit-test\r
-\r
-! Test for hangs?\r
-: random-class ( -- class ) classes random ;\r
-\r
-: random-op ( -- word )\r
- {\r
- class-and\r
- class-or\r
- class-not\r
- } random ;\r
-\r
-10 [\r
- [ ] [\r
- 20 [ random-op ] [ ] replicate-as\r
- [ infer in>> length [ random-class ] times ] keep\r
- call\r
- drop\r
- ] unit-test\r
-] times\r
-\r
-: random-boolean ( -- ? )\r
- { t f } random ;\r
-\r
-: boolean>class ( ? -- class )\r
- object null ? ;\r
-\r
-: random-boolean-op ( -- word )\r
- {\r
- and\r
- or\r
- not\r
- xor\r
- } random ;\r
-\r
-: class-xor ( cls1 cls2 -- cls3 )\r
- [ class-or ] 2keep class-and class-not class-and ;\r
-\r
-: boolean-op>class-op ( word -- word' )\r
- {\r
- { and class-and }\r
- { or class-or }\r
- { not class-not }\r
- { xor class-xor }\r
- } at ;\r
-\r
-20 [\r
- [ t ] [\r
- 20 [ random-boolean-op ] [ ] replicate-as dup .\r
- [ infer in>> length [ random-boolean ] replicate dup . ] keep\r
- \r
- [ [ [ ] each ] dip call ] 2keep\r
- \r
- [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=\r
- \r
- =\r
- ] unit-test\r
-] times\r
-\r
-SINGLETON: xxx\r
-UNION: yyy xxx ;\r
-\r
-[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test\r
-[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test\r
-\r
-[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test\r
-[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test\r
-\r
-TUPLE: xa ;\r
-TUPLE: xb ;\r
-TUPLE: xc < xa ;\r
-TUPLE: xd < xb ;\r
-TUPLE: xe ;\r
-TUPLE: xf < xb ;\r
-TUPLE: xg < xb ;\r
-TUPLE: xh < xb ;\r
-\r
-[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test\r
-\r
-[ H{ { word word } } ] [ \r
- generic-class flatten-class\r
-] unit-test\r
-\r
-[ sa ] [ sa { sa sb sc } min-class ] unit-test\r
-\r
-[ \ + flatten-class ] must-fail\r
+USING: alien arrays definitions generic assocs hashtables io
+kernel math namespaces parser prettyprint sequences strings
+tools.test words quotations classes classes.algebra
+classes.private classes.union classes.mixin classes.predicate
+vectors source-files compiler.units growable random
+stack-checker effects kernel.private sbufs math.order
+classes.tuple accessors generic.private ;
+IN: classes.algebra.tests
+
+TUPLE: first-one ;
+TUPLE: second-one ;
+UNION: both first-one union-class ;
+
+PREDICATE: no-docs < word "documentation" word-prop not ;
+
+UNION: no-docs-union no-docs integer ;
+
+TUPLE: a ;
+TUPLE: b ;
+UNION: c a b ;
+
+TUPLE: tuple-example ;
+
+TUPLE: a1 ;
+TUPLE: b1 ;
+TUPLE: c1 ;
+
+UNION: x1 a1 b1 ;
+UNION: y1 a1 c1 ;
+UNION: z1 b1 c1 ;
+
+SINGLETON: sa
+SINGLETON: sb
+SINGLETON: sc
+
+INTERSECTION: empty-intersection ;
+
+INTERSECTION: generic-class generic class ;
+
+UNION: union-with-one-member a ;
+
+MIXIN: mixin-with-one-member
+INSTANCE: union-with-one-member mixin-with-one-member
+
+! class<=
+[ t ] [ \ fixnum \ integer class<= ] unit-test
+[ t ] [ \ fixnum \ fixnum class<= ] unit-test
+[ f ] [ \ integer \ fixnum class<= ] unit-test
+[ t ] [ \ integer \ object class<= ] unit-test
+[ f ] [ \ integer \ null class<= ] unit-test
+[ t ] [ \ null \ object class<= ] unit-test
+
+[ t ] [ \ generic \ word class<= ] unit-test
+[ f ] [ \ word \ generic class<= ] unit-test
+
+[ f ] [ \ reversed \ slice class<= ] unit-test
+[ f ] [ \ slice \ reversed class<= ] unit-test
+
+[ t ] [ no-docs no-docs-union class<= ] unit-test
+[ f ] [ no-docs-union no-docs class<= ] unit-test
+
+[ t ] [ \ c \ tuple class<= ] unit-test
+[ f ] [ \ tuple \ c class<= ] unit-test
+
+[ t ] [ \ tuple-class \ class class<= ] unit-test
+[ f ] [ \ class \ tuple-class class<= ] unit-test
+
+[ t ] [ \ null \ tuple-example class<= ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
+[ f ] [ \ object \ tuple-example class<= ] unit-test
+[ t ] [ \ tuple-example \ tuple class<= ] unit-test
+[ f ] [ \ tuple \ tuple-example class<= ] unit-test
+
+[ f ] [ z1 x1 y1 class-and class<= ] unit-test
+
+[ t ] [ x1 y1 class-and a1 class<= ] unit-test
+
+[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
+
+[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
+
+[ f ] [ growable tuple sequence class-and class<= ] unit-test
+
+[ f ] [ growable assoc class-and tuple class<= ] unit-test
+
+[ t ] [ object \ f \ f class-not class-or class<= ] unit-test
+
+[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
+
+[ t ] [ array number class-not class<= ] unit-test
+
+[ f ] [ bignum number class-not class<= ] unit-test
+
+[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test
+
+[ f ] [ fixnum class-not integer class-and array class<= ] unit-test
+
+[ f ] [ fixnum class-not integer class<= ] unit-test
+
+[ f ] [ number class-not array class<= ] unit-test
+
+[ f ] [ fixnum class-not array class<= ] unit-test
+
+[ t ] [ number class-not integer class-not class<= ] unit-test
+
+[ f ] [ fixnum class-not integer class<= ] unit-test
+
+[ t ] [ object empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection object class<= ] unit-test
+[ t ] [ \ f class-not empty-intersection class<= ] unit-test
+[ f ] [ empty-intersection \ f class-not class<= ] unit-test
+[ t ] [ \ number empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection class-not null class<= ] unit-test
+[ t ] [ null empty-intersection class-not class<= ] unit-test
+
+[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
+[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
+
+[ t ] [ object \ f class-not \ f class-or class<= ] unit-test
+
+[ t ] [
+ fixnum class-not
+ fixnum fixnum class-not class-or
+ class<=
+] unit-test
+
+[ t ] [ generic-class generic class<= ] unit-test
+[ t ] [ generic-class \ class class<= ] unit-test
+
+[ t ] [ a union-with-one-member class<= ] unit-test
+[ f ] [ union-with-one-member class-not integer class<= ] unit-test
+
+MIXIN: empty-mixin
+
+[ f ] [ empty-mixin class-not null class<= ] unit-test
+[ f ] [ empty-mixin null class<= ] unit-test
+
+[ t ] [ array sequence vector class-not class-and class<= ] unit-test
+[ f ] [ vector sequence vector class-not class-and class<= ] unit-test
+
+! class-and
+: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
+
+[ t ] [ object object object class-and* ] unit-test
+[ t ] [ fixnum object fixnum class-and* ] unit-test
+[ t ] [ object fixnum fixnum class-and* ] unit-test
+[ t ] [ fixnum fixnum fixnum class-and* ] unit-test
+[ t ] [ fixnum integer fixnum class-and* ] unit-test
+[ t ] [ integer fixnum fixnum class-and* ] unit-test
+
+[ t ] [ vector fixnum null class-and* ] unit-test
+[ t ] [ number object number class-and* ] unit-test
+[ t ] [ object number number class-and* ] unit-test
+[ t ] [ slice reversed null class-and* ] unit-test
+[ t ] [ \ f class-not \ f null class-and* ] unit-test
+
+[ t ] [ vector array class-not vector class-and* ] unit-test
+
+! class-or
+: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
+
+[ t ] [ \ f class-not \ f object class-or* ] unit-test
+
+! class-not
+[ vector ] [ vector class-not class-not ] unit-test
+
+! classes-intersect?
+[ t ] [ both tuple classes-intersect? ] unit-test
+
+[ f ] [ vector virtual-sequence classes-intersect? ] unit-test
+
+[ t ] [ number vector class-or sequence classes-intersect? ] unit-test
+
+[ f ] [ number vector class-and sequence classes-intersect? ] unit-test
+
+[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
+
+[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
+
+[ f ] [ integer integer class-not classes-intersect? ] unit-test
+
+[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
+
+[ t ] [ \ word generic-class classes-intersect? ] unit-test
+[ f ] [ number generic-class classes-intersect? ] unit-test
+
+[ f ] [ sa sb classes-intersect? ] unit-test
+
+[ t ] [ a union-with-one-member classes-intersect? ] unit-test
+[ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test
+[ t ] [ object union-with-one-member classes-intersect? ] unit-test
+
+[ t ] [ union-with-one-member a classes-intersect? ] unit-test
+[ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test
+[ t ] [ union-with-one-member object classes-intersect? ] unit-test
+
+[ t ] [ a mixin-with-one-member classes-intersect? ] unit-test
+[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test
+[ t ] [ object mixin-with-one-member classes-intersect? ] unit-test
+
+[ t ] [ mixin-with-one-member a classes-intersect? ] unit-test
+[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test
+[ t ] [ mixin-with-one-member object classes-intersect? ] unit-test
+
+! class=
+[ t ] [ null class-not object class= ] unit-test
+
+[ t ] [ object class-not null class= ] unit-test
+
+[ f ] [ object class-not object class= ] unit-test
+
+[ f ] [ null class-not null class= ] unit-test
+
+! class<=>
+
+[ +lt+ ] [ sequence object class<=> ] unit-test
+[ +gt+ ] [ object sequence class<=> ] unit-test
+[ +eq+ ] [ integer integer class<=> ] unit-test
+
+! smallest-class etc
+[ real ] [ { real sequence } smallest-class ] unit-test
+[ real ] [ { sequence real } smallest-class ] unit-test
+
+: min-class ( class classes -- class/f )
+ interesting-classes smallest-class ;
+
+[ f ] [ fixnum { } min-class ] unit-test
+
+[ string ] [
+ \ string
+ [ integer string array reversed sbuf
+ slice vector quotation ]
+ sort-classes min-class
+] unit-test
+
+[ fixnum ] [
+ \ fixnum
+ [ fixnum integer object ]
+ sort-classes min-class
+] unit-test
+
+[ integer ] [
+ \ fixnum
+ [ integer float object ]
+ sort-classes min-class
+] unit-test
+
+[ object ] [
+ \ word
+ [ integer float object ]
+ sort-classes min-class
+] unit-test
+
+[ reversed ] [
+ \ reversed
+ [ integer reversed slice ]
+ sort-classes min-class
+] unit-test
+
+[ f ] [ null { number fixnum null } min-class ] unit-test
+
+! Test for hangs?
+: random-class ( -- class ) classes random ;
+
+: random-op ( -- word )
+ {
+ class-and
+ class-or
+ class-not
+ } random ;
+
+10 [
+ [ ] [
+ 20 [ random-op ] [ ] replicate-as
+ [ infer in>> length [ random-class ] times ] keep
+ call
+ drop
+ ] unit-test
+] times
+
+: random-boolean ( -- ? )
+ { t f } random ;
+
+: boolean>class ( ? -- class )
+ object null ? ;
+
+: random-boolean-op ( -- word )
+ {
+ and
+ or
+ not
+ xor
+ } random ;
+
+: class-xor ( cls1 cls2 -- cls3 )
+ [ class-or ] 2keep class-and class-not class-and ;
+
+: boolean-op>class-op ( word -- word' )
+ {
+ { and class-and }
+ { or class-or }
+ { not class-not }
+ { xor class-xor }
+ } at ;
+
+20 [
+ [ t ] [
+ 20 [ random-boolean-op ] [ ] replicate-as dup .
+ [ infer in>> length [ random-boolean ] replicate dup . ] keep
+
+ [ [ [ ] each ] dip call ] 2keep
+
+ [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=
+
+ =
+ ] unit-test
+] times
+
+SINGLETON: xxx
+UNION: yyy xxx ;
+
+[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test
+[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test
+
+[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test
+[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
+
+TUPLE: xa ;
+TUPLE: xb ;
+TUPLE: xc < xa ;
+TUPLE: xd < xb ;
+TUPLE: xe ;
+TUPLE: xf < xb ;
+TUPLE: xg < xb ;
+TUPLE: xh < xb ;
+
+[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
+
+[ H{ { word word } } ] [
+ generic-class flatten-class
+] unit-test
+
+[ sa ] [ sa { sa sb sc } min-class ] unit-test
+
+[ \ + flatten-class ] must-fail
-! Copyright (C) 2004, 2008 Slava Pestov.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: kernel classes combinators accessors sequences arrays\r
-vectors assocs namespaces words sorting layouts math hashtables\r
-kernel.private sets math.order ;\r
-IN: classes.algebra\r
-\r
-<PRIVATE\r
-\r
-TUPLE: anonymous-union { members read-only } ;\r
-\r
-: <anonymous-union> ( members -- class )\r
- [ null eq? not ] filter prune\r
- dup length 1 = [ first ] [ anonymous-union boa ] if ;\r
-\r
-TUPLE: anonymous-intersection { participants read-only } ;\r
-\r
-: <anonymous-intersection> ( participants -- class )\r
- prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;\r
-\r
-TUPLE: anonymous-complement { class read-only } ;\r
-\r
-C: <anonymous-complement> anonymous-complement\r
-\r
-DEFER: (class<=)\r
-\r
-DEFER: (class-not)\r
-\r
-GENERIC: (classes-intersect?) ( first second -- ? )\r
-\r
-DEFER: (class-and)\r
-\r
-DEFER: (class-or)\r
-\r
-GENERIC: (flatten-class) ( class -- )\r
-\r
-: normalize-class ( class -- class' )\r
- {\r
- { [ dup members ] [ members <anonymous-union> normalize-class ] }\r
- { [ dup participants ] [ participants <anonymous-intersection> normalize-class ] }\r
- [ ]\r
- } cond ;\r
-\r
-PRIVATE>\r
-\r
-GENERIC: valid-class? ( obj -- ? )\r
-\r
-M: class valid-class? drop t ;\r
-M: anonymous-union valid-class? members>> [ valid-class? ] all? ;\r
-M: anonymous-intersection valid-class? participants>> [ valid-class? ] all? ;\r
-M: anonymous-complement valid-class? class>> valid-class? ;\r
-M: word valid-class? drop f ;\r
-\r
-: class<= ( first second -- ? )\r
- class<=-cache get [ (class<=) ] 2cache ;\r
-\r
-: class< ( first second -- ? )\r
- {\r
- { [ 2dup class<= not ] [ 2drop f ] }\r
- { [ 2dup swap class<= not ] [ 2drop t ] }\r
- [ [ rank-class ] bi@ < ]\r
- } cond ;\r
-\r
-: class<=> ( first second -- ? )\r
- {\r
- { [ 2dup class<= not ] [ 2drop +gt+ ] }\r
- { [ 2dup swap class<= not ] [ 2drop +lt+ ] }\r
- [ [ rank-class ] bi@ <=> ]\r
- } cond ;\r
-\r
-: class= ( first second -- ? )\r
- [ class<= ] [ swap class<= ] 2bi and ;\r
-\r
-: class-not ( class -- complement )\r
- class-not-cache get [ (class-not) ] cache ;\r
-\r
-: classes-intersect? ( first second -- ? )\r
- classes-intersect-cache get [\r
- normalize-class (classes-intersect?)\r
- ] 2cache ;\r
-\r
-: class-and ( first second -- class )\r
- class-and-cache get [ (class-and) ] 2cache ;\r
-\r
-: class-or ( first second -- class )\r
- class-or-cache get [ (class-or) ] 2cache ;\r
-\r
-<PRIVATE\r
-\r
-: superclass<= ( first second -- ? )\r
- swap superclass dup [ swap class<= ] [ 2drop f ] if ;\r
-\r
-: left-anonymous-union<= ( first second -- ? )\r
- [ members>> ] dip [ class<= ] curry all? ;\r
-\r
-: right-anonymous-union<= ( first second -- ? )\r
- members>> [ class<= ] with any? ;\r
-\r
-: left-anonymous-intersection<= ( first second -- ? )\r
- [ participants>> ] dip [ class<= ] curry any? ;\r
-\r
-: right-anonymous-intersection<= ( first second -- ? )\r
- participants>> [ class<= ] with all? ;\r
-\r
-: anonymous-complement<= ( first second -- ? )\r
- [ class>> ] bi@ swap class<= ;\r
-\r
-: normalize-complement ( class -- class' )\r
- class>> normalize-class {\r
- { [ dup anonymous-union? ] [\r
- members>>\r
- [ class-not normalize-class ] map\r
- <anonymous-intersection> \r
- ] }\r
- { [ dup anonymous-intersection? ] [\r
- participants>>\r
- [ class-not normalize-class ] map\r
- <anonymous-union>\r
- ] }\r
- [ <anonymous-complement> ]\r
- } cond ;\r
-\r
-: left-anonymous-complement<= ( first second -- ? )\r
- [ normalize-complement ] dip class<= ;\r
-\r
-PREDICATE: nontrivial-anonymous-complement < anonymous-complement\r
- class>> {\r
- [ anonymous-union? ]\r
- [ anonymous-intersection? ]\r
- [ members ]\r
- [ participants ]\r
- } cleave or or or ;\r
-\r
-PREDICATE: empty-union < anonymous-union members>> empty? ;\r
-\r
-PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;\r
-\r
-: (class<=) ( first second -- ? )\r
- 2dup eq? [ 2drop t ] [\r
- [ normalize-class ] bi@\r
- 2dup superclass<= [ 2drop t ] [\r
- {\r
- { [ 2dup eq? ] [ 2drop t ] }\r
- { [ dup empty-intersection? ] [ 2drop t ] }\r
- { [ over empty-union? ] [ 2drop t ] }\r
- { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }\r
- { [ over anonymous-union? ] [ left-anonymous-union<= ] }\r
- { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }\r
- { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }\r
- { [ dup anonymous-union? ] [ right-anonymous-union<= ] }\r
- { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }\r
- { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }\r
- [ 2drop f ]\r
- } cond\r
- ] if\r
- ] if ;\r
-\r
-M: anonymous-union (classes-intersect?)\r
- members>> [ classes-intersect? ] with any? ;\r
-\r
-M: anonymous-intersection (classes-intersect?)\r
- participants>> [ classes-intersect? ] with all? ;\r
-\r
-M: anonymous-complement (classes-intersect?)\r
- class>> class<= not ;\r
-\r
-: anonymous-union-and ( first second -- class )\r
- members>> [ class-and ] with map <anonymous-union> ;\r
-\r
-: anonymous-intersection-and ( first second -- class )\r
- participants>> swap suffix <anonymous-intersection> ;\r
-\r
-: (class-and) ( first second -- class )\r
- {\r
- { [ 2dup class<= ] [ drop ] }\r
- { [ 2dup swap class<= ] [ nip ] }\r
- { [ 2dup classes-intersect? not ] [ 2drop null ] }\r
- [\r
- [ normalize-class ] bi@ {\r
- { [ dup anonymous-union? ] [ anonymous-union-and ] }\r
- { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }\r
- { [ over anonymous-union? ] [ swap anonymous-union-and ] }\r
- { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }\r
- [ 2array <anonymous-intersection> ]\r
- } cond\r
- ]\r
- } cond ;\r
-\r
-: anonymous-union-or ( first second -- class )\r
- members>> swap suffix <anonymous-union> ;\r
-\r
-: ((class-or)) ( first second -- class )\r
- [ normalize-class ] bi@ {\r
- { [ dup anonymous-union? ] [ anonymous-union-or ] }\r
- { [ over anonymous-union? ] [ swap anonymous-union-or ] }\r
- [ 2array <anonymous-union> ]\r
- } cond ;\r
-\r
-: anonymous-complement-or ( first second -- class )\r
- 2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;\r
-\r
-: (class-or) ( first second -- class )\r
- {\r
- { [ 2dup class<= ] [ nip ] }\r
- { [ 2dup swap class<= ] [ drop ] }\r
- { [ dup anonymous-complement? ] [ anonymous-complement-or ] }\r
- { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }\r
- [ ((class-or)) ]\r
- } cond ;\r
-\r
-: (class-not) ( class -- complement )\r
- {\r
- { [ dup anonymous-complement? ] [ class>> ] }\r
- { [ dup object eq? ] [ drop null ] }\r
- { [ dup null eq? ] [ drop object ] }\r
- [ <anonymous-complement> ]\r
- } cond ;\r
-\r
-M: anonymous-union (flatten-class)\r
- members>> [ (flatten-class) ] each ;\r
-\r
-PRIVATE>\r
-\r
-ERROR: topological-sort-failed ;\r
-\r
-: largest-class ( seq -- n elt )\r
- dup [ [ class< ] with any? not ] curry find-last\r
- [ topological-sort-failed ] unless* ;\r
-\r
-: sort-classes ( seq -- newseq )\r
- [ name>> ] sort-with >vector\r
- [ dup empty? not ]\r
- [ dup largest-class [ swap remove-nth! ] dip ]\r
- produce nip ;\r
-\r
-: smallest-class ( classes -- class/f )\r
- [ f ] [\r
- natural-sort <reversed>\r
- [ ] [ [ class<= ] most ] map-reduce\r
- ] if-empty ;\r
-\r
-: flatten-class ( class -- assoc )\r
- [ (flatten-class) ] H{ } make-assoc ;\r
+! Copyright (C) 2004, 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel classes classes.private combinators accessors
+sequences arrays vectors assocs namespaces words sorting layouts
+math hashtables kernel.private sets math.order ;
+IN: classes.algebra
+
+<PRIVATE
+
+TUPLE: anonymous-union { members read-only } ;
+
+: <anonymous-union> ( members -- class )
+ [ null eq? not ] filter prune
+ dup length 1 = [ first ] [ anonymous-union boa ] if ;
+
+TUPLE: anonymous-intersection { participants read-only } ;
+
+: <anonymous-intersection> ( participants -- class )
+ prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
+
+TUPLE: anonymous-complement { class read-only } ;
+
+C: <anonymous-complement> anonymous-complement
+
+DEFER: (class<=)
+
+DEFER: (class-not)
+
+GENERIC: (classes-intersect?) ( first second -- ? )
+
+DEFER: (class-and)
+
+DEFER: (class-or)
+
+GENERIC: (flatten-class) ( class -- )
+
+GENERIC: normalize-class ( class -- class' )
+
+M: object normalize-class ;
+
+PRIVATE>
+
+GENERIC: classoid? ( obj -- ? )
+
+M: word classoid? class? ;
+M: anonymous-union classoid? members>> [ classoid? ] all? ;
+M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;
+M: anonymous-complement classoid? class>> classoid? ;
+
+: class<= ( first second -- ? )
+ class<=-cache get [ (class<=) ] 2cache ;
+
+: class< ( first second -- ? )
+ {
+ { [ 2dup class<= not ] [ 2drop f ] }
+ { [ 2dup swap class<= not ] [ 2drop t ] }
+ [ [ rank-class ] bi@ < ]
+ } cond ;
+
+: class<=> ( first second -- ? )
+ {
+ { [ 2dup class<= not ] [ 2drop +gt+ ] }
+ { [ 2dup swap class<= not ] [ 2drop +lt+ ] }
+ [ [ rank-class ] bi@ <=> ]
+ } cond ;
+
+: class= ( first second -- ? )
+ [ class<= ] [ swap class<= ] 2bi and ;
+
+: class-not ( class -- complement )
+ class-not-cache get [ (class-not) ] cache ;
+
+: classes-intersect? ( first second -- ? )
+ classes-intersect-cache get [
+ normalize-class (classes-intersect?)
+ ] 2cache ;
+
+: class-and ( first second -- class )
+ class-and-cache get [ (class-and) ] 2cache ;
+
+: class-or ( first second -- class )
+ class-or-cache get [ (class-or) ] 2cache ;
+
+<PRIVATE
+
+: superclass<= ( first second -- ? )
+ swap superclass dup [ swap class<= ] [ 2drop f ] if ;
+
+: left-anonymous-union<= ( first second -- ? )
+ [ members>> ] dip [ class<= ] curry all? ;
+
+: right-union<= ( first second -- ? )
+ members [ class<= ] with any? ;
+
+: right-anonymous-union<= ( first second -- ? )
+ members>> [ class<= ] with any? ;
+
+: left-anonymous-intersection<= ( first second -- ? )
+ [ participants>> ] dip [ class<= ] curry any? ;
+
+: right-anonymous-intersection<= ( first second -- ? )
+ participants>> [ class<= ] with all? ;
+
+: anonymous-complement<= ( first second -- ? )
+ [ class>> ] bi@ swap class<= ;
+
+: normalize-complement ( class -- class' )
+ class>> normalize-class {
+ { [ dup anonymous-union? ] [
+ members>>
+ [ class-not normalize-class ] map
+ <anonymous-intersection>
+ ] }
+ { [ dup anonymous-intersection? ] [
+ participants>>
+ [ class-not normalize-class ] map
+ <anonymous-union>
+ ] }
+ [ drop object ]
+ } cond ;
+
+: left-anonymous-complement<= ( first second -- ? )
+ [ normalize-complement ] dip class<= ;
+
+PREDICATE: nontrivial-anonymous-complement < anonymous-complement
+ class>> {
+ [ anonymous-union? ]
+ [ anonymous-intersection? ]
+ [ members ]
+ [ participants ]
+ } cleave or or or ;
+
+PREDICATE: empty-union < anonymous-union members>> empty? ;
+
+PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
+
+: (class<=) ( first second -- ? )
+ 2dup eq? [ 2drop t ] [
+ [ normalize-class ] bi@
+ 2dup superclass<= [ 2drop t ] [
+ {
+ { [ 2dup eq? ] [ 2drop t ] }
+ { [ dup empty-intersection? ] [ 2drop t ] }
+ { [ over empty-union? ] [ 2drop t ] }
+ { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
+ { [ over anonymous-union? ] [ left-anonymous-union<= ] }
+ { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
+ { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
+ { [ dup members ] [ right-union<= ] }
+ { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
+ { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
+ { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
+ [ 2drop f ]
+ } cond
+ ] if
+ ] if ;
+
+M: anonymous-union (classes-intersect?)
+ members>> [ classes-intersect? ] with any? ;
+
+M: anonymous-intersection (classes-intersect?)
+ participants>> [ classes-intersect? ] with all? ;
+
+M: anonymous-complement (classes-intersect?)
+ class>> class<= not ;
+
+: anonymous-union-and ( first second -- class )
+ members>> [ class-and ] with map <anonymous-union> ;
+
+: anonymous-intersection-and ( first second -- class )
+ participants>> swap suffix <anonymous-intersection> ;
+
+: (class-and) ( first second -- class )
+ {
+ { [ 2dup class<= ] [ drop ] }
+ { [ 2dup swap class<= ] [ nip ] }
+ { [ 2dup classes-intersect? not ] [ 2drop null ] }
+ [
+ [ normalize-class ] bi@ {
+ { [ dup anonymous-union? ] [ anonymous-union-and ] }
+ { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
+ { [ over anonymous-union? ] [ swap anonymous-union-and ] }
+ { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
+ [ 2array <anonymous-intersection> ]
+ } cond
+ ]
+ } cond ;
+
+: anonymous-union-or ( first second -- class )
+ members>> swap suffix <anonymous-union> ;
+
+: ((class-or)) ( first second -- class )
+ [ normalize-class ] bi@ {
+ { [ dup anonymous-union? ] [ anonymous-union-or ] }
+ { [ over anonymous-union? ] [ swap anonymous-union-or ] }
+ [ 2array <anonymous-union> ]
+ } cond ;
+
+: anonymous-complement-or ( first second -- class )
+ 2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;
+
+: (class-or) ( first second -- class )
+ {
+ { [ 2dup class<= ] [ nip ] }
+ { [ 2dup swap class<= ] [ drop ] }
+ { [ dup anonymous-complement? ] [ anonymous-complement-or ] }
+ { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
+ [ ((class-or)) ]
+ } cond ;
+
+: (class-not) ( class -- complement )
+ {
+ { [ dup anonymous-complement? ] [ class>> ] }
+ { [ dup object eq? ] [ drop null ] }
+ { [ dup null eq? ] [ drop object ] }
+ [ <anonymous-complement> ]
+ } cond ;
+
+M: anonymous-union (flatten-class)
+ members>> [ (flatten-class) ] each ;
+
+PRIVATE>
+
+ERROR: topological-sort-failed ;
+
+: largest-class ( seq -- n elt )
+ dup [ [ class< ] with any? not ] curry find-last
+ [ topological-sort-failed ] unless* ;
+
+: sort-classes ( seq -- newseq )
+ [ name>> ] sort-with >vector
+ [ dup empty? not ]
+ [ dup largest-class [ swap remove-nth! ] dip ]
+ produce nip ;
+
+: smallest-class ( classes -- class/f )
+ [ f ] [
+ natural-sort <reversed>
+ [ ] [ [ class<= ] most ] map-reduce
+ ] if-empty ;
+
+: flatten-class ( class -- assoc )
+ [ (flatten-class) ] H{ } make-assoc ;
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes classes.algebra classes.algebra.private
-words kernel kernel.private namespaces sequences math
-math.private combinators assocs quotations ;
+USING: accessors classes classes.private classes.algebra
+classes.algebra.private words kernel kernel.private namespaces
+sequences math math.private combinators assocs quotations ;
IN: classes.builtin
SYMBOL: builtins
M: builtin-class rank-class drop 0 ;
-GENERIC: define-builtin-predicate ( class -- )
-
-M: builtin-class define-builtin-predicate
- dup class>type [ eq? ] curry [ tag ] prepend define-predicate ;
-
M: builtin-class instance? [ tag ] [ class>type ] bi* eq? ;
M: builtin-class (flatten-class) dup set ;
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions assocs kernel kernel.private
slots.private namespaces make sequences strings words words.symbol
vocabs sets ;
IN: classes
+ERROR: bad-inheritance class superclass ;
+
+PREDICATE: class < word "class" word-prop ;
+
+<PRIVATE
+
SYMBOL: class<=-cache
SYMBOL: class-not-cache
SYMBOL: classes-intersect-cache
SYMBOL: implementors-map
-PREDICATE: class < word "class" word-prop ;
+GENERIC: rank-class ( class -- n )
+
+GENERIC: reset-class ( class -- )
+
+M: class reset-class
+ {
+ "class"
+ "metaclass"
+ "superclass"
+ "members"
+ "participants"
+ "predicate"
+ } reset-props ;
+
+M: word reset-class drop ;
+
+PRIVATE>
: classes ( -- seq ) implementors-map get keys ;
-: predicate-word ( word -- predicate )
+: create-predicate-word ( word -- predicate )
[ name>> "?" append ] [ vocabulary>> ] bi create ;
+: predicate-word ( word -- predicate )
+ "predicate" word-prop first ;
+
PREDICATE: predicate < word "predicating" word-prop >boolean ;
+M: predicate flushable? drop t ;
+
M: predicate forget*
[ call-next-method ] [ f "predicating" set-word-prop ] bi ;
[ call-next-method ] [ f "predicating" set-word-prop ] bi ;
: define-predicate ( class quot -- )
- [ "predicate" word-prop first ] dip
- (( object -- ? )) define-declared ;
+ [ predicate-word ] dip (( object -- ? )) define-declared ;
: superclass ( class -- super )
#! Output f for non-classes to work with algebra code
: superclasses ( class -- supers )
[ superclass ] follow reverse ;
+: superclass-of? ( class superclass -- ? )
+ superclasses member-eq? ;
+
: subclass-of? ( class superclass -- ? )
- swap superclasses member? ;
+ swap superclass-of? ;
: members ( class -- seq )
#! Output f for non-classes to work with algebra code
#! Output f for non-classes to work with algebra code
dup class? [ "participants" word-prop ] [ drop f ] if ;
-GENERIC: rank-class ( class -- n )
-
-GENERIC: reset-class ( class -- )
-
-M: class reset-class
- {
- "class"
- "metaclass"
- "superclass"
- "members"
- "participants"
- "predicate"
- } reset-props ;
-
-M: word reset-class drop ;
-
GENERIC: implementors ( class/classes -- seq )
! update-map
: class-usages ( class -- seq ) [ class-usage ] closure keys ;
+M: class implementors implementors-map get at keys ;
+
+M: sequence implementors [ implementors ] gather ;
+
<PRIVATE
: update-map+ ( class -- )
: update-map- ( class -- )
dup class-uses update-map get remove-vertex ;
-M: class implementors implementors-map get at keys ;
-
-M: sequence implementors [ implementors ] gather ;
-
: implementors-map+ ( class -- )
- H{ } clone swap implementors-map get set-at ;
+ [ H{ } clone ] dip implementors-map get set-at ;
: implementors-map- ( class -- )
implementors-map get delete-at ;
} spread
] H{ } make-assoc ;
+GENERIC: metaclass-changed ( use class -- )
+
+: ?metaclass-changed ( class usages/f -- )
+ dup [ [ metaclass-changed ] with each ] [ 2drop ] if ;
+
+: check-metaclass ( class metaclass -- usages/f )
+ over class? [
+ over "metaclass" word-prop eq?
+ [ drop f ] [ class-usage keys ] if
+ ] [ 2drop f ] if ;
+
: ?define-symbol ( word -- )
dup deferred? [ define-symbol ] [ drop ] if ;
: (define-class) ( word props -- )
- [
- {
- [ dup class? [ drop ] [ [ implementors-map+ ] [ new-class ] bi ] if ]
- [ reset-class ]
- [ ?define-symbol ]
- [ changed-definition ]
- [ ]
- } cleave
- ] dip [ assoc-union ] curry change-props
- dup predicate-word
- [ 1quotation "predicate" set-word-prop ]
- [ swap "predicating" set-word-prop ]
- [ drop t "class" set-word-prop ]
- 2tri ;
-
-PRIVATE>
+ reset-caches
+ 2dup "metaclass" swap at check-metaclass
+ {
+ [ 2drop update-map- ]
+ [ 2drop dup class? [ reset-class ] [ implementors-map+ ] if ]
+ [ 2drop ?define-symbol ]
+ [ drop [ assoc-union ] curry change-props drop ]
+ [
+ 2drop
+ dup create-predicate-word
+ [ 1quotation "predicate" set-word-prop ]
+ [ swap "predicating" set-word-prop ]
+ 2bi
+ ]
+ [ 2drop t "class" set-word-prop ]
+ [ 2drop update-map+ ]
+ [ nip ?metaclass-changed ]
+ } 3cleave ;
GENERIC: update-class ( class -- )
dup class-usages
[ nip [ update-class ] each ] [ update-methods ] 2bi ;
+: check-inheritance ( subclass superclass -- )
+ 2dup superclass-of? [ bad-inheritance ] [ 2drop ] if ;
+
: define-class ( word superclass members participants metaclass -- )
- #! If it was already a class, update methods after.
- reset-caches
- make-class-props
- [ drop update-map- ]
- [ (define-class) ]
- [ drop update-map+ ]
- 2tri ;
+ [ 2dup check-inheritance ] 3dip
+ make-class-props [ (define-class) ] [ drop changed-definition ] 2bi ;
: forget-predicate ( class -- )
dup "predicate" word-prop
GENERIC: forget-methods ( class -- )
-GENERIC: class-forgotten ( use class -- )
+PRIVATE>
: forget-class ( class -- )
- {
- [ dup class-usage keys [ class-forgotten ] with each ]
- [ forget-predicate ]
- [ forget-methods ]
- [ implementors-map- ]
- [ update-map- ]
- [ reset-class ]
- } cleave
- reset-caches ;
-
-M: class class-forgotten
- nip forget-class ;
+ dup f check-metaclass {
+ [ drop forget-predicate ]
+ [ drop forget-methods ]
+ [ drop implementors-map- ]
+ [ drop update-map- ]
+ [ drop reset-class ]
+ [ 2drop reset-caches ]
+ [ ?metaclass-changed ]
+ } 2cleave ;
+
+M: class metaclass-changed
+ swap class? [ drop ] [ forget-class ] if ;
M: class forget* ( class -- )
[ call-next-method ] [ forget-class ] bi ;
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: words accessors sequences kernel assocs combinators classes
-classes.algebra classes.algebra.private classes.builtin
-namespaces arrays math quotations ;
+USING: words accessors sequences kernel assocs combinators
+classes classes.private classes.algebra classes.algebra.private
+classes.builtin namespaces arrays math quotations ;
IN: classes.intersection
PREDICATE: intersection-class < class
"metaclass" word-prop intersection-class eq? ;
+<PRIVATE
+
: intersection-predicate-quot ( members -- quot )
[
[ drop t ]
M: intersection-class update-class define-intersection-predicate ;
-: define-intersection-class ( class participants -- )
- [ [ f f ] dip intersection-class define-class ]
- [ drop update-classes ]
- 2bi ;
-
M: intersection-class rank-class drop 2 ;
M: intersection-class instance?
"participants" word-prop [ instance? ] with all? ;
+M: intersection-class normalize-class
+ participants <anonymous-intersection> normalize-class ;
+
M: intersection-class (flatten-class)
participants <anonymous-intersection> (flatten-class) ;
[ intersect-flattened-classes ] map-reduce
[ dup set ] each
] if-empty ;
+
+PRIVATE>
+
+: define-intersection-class ( class participants -- )
+ [ [ f f ] dip intersection-class define-class ]
+ [ drop update-classes ]
+ 2bi ;
INSTANCE: integer mx1
[ t ] [ integer mx1 class<= ] unit-test
-[ t ] [ mx1 integer class<= ] unit-test
-[ t ] [ mx1 number class<= ] unit-test
+[ f ] [ mx1 integer class<= ] unit-test
+[ f ] [ mx1 number class<= ] unit-test
"IN: classes.mixin.tests USE: arrays INSTANCE: array mx1" eval( -- )
TUPLE: a-class ;
[ [ \ a-class \ not-a-mixin add-mixin-instance ] with-compilation-unit ] must-fail
+
+! Changing a mixin member's metaclass should not remove it from the mixin
+MIXIN: metaclass-change-mixin
+TUPLE: metaclass-change ;
+INSTANCE: metaclass-change metaclass-change-mixin
+
+GENERIC: metaclass-change-generic ( a -- b )
+
+M: metaclass-change-mixin metaclass-change-generic ;
+
+[ T{ metaclass-change } ] [ T{ metaclass-change } metaclass-change-generic ] unit-test
+
+[ ] [ "IN: classes.mixin.tests USE: math UNION: metaclass-change integer ;" eval( -- ) ] unit-test
+
+[ 0 ] [ 0 metaclass-change-generic ] unit-test
+
+! Forgetting a mixin member class should remove it from the mixin
+[ ] [ [ metaclass-change forget-class ] with-compilation-unit ] unit-test
+
+[ t ] [ metaclass-change-mixin members empty? ] unit-test
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.union words kernel sequences
-definitions combinators arrays assocs generic accessors ;
+USING: classes classes.private classes.algebra
+classes.algebra.private classes.union classes.union.private
+words kernel sequences definitions combinators arrays assocs
+generic accessors ;
IN: classes.mixin
PREDICATE: mixin-class < union-class "mixin" word-prop ;
+M: mixin-class normalize-class ;
+
+M: mixin-class (classes-intersect?)
+ members [ classes-intersect? ] with any? ;
+
M: mixin-class reset-class
[ call-next-method ] [ { "mixin" } reset-props ] bi ;
M: mixin-class rank-class drop 3 ;
-: redefine-mixin-class ( class members -- )
- [ (define-union-class) ]
- [ drop t "mixin" set-word-prop ]
- 2bi ;
-
-: define-mixin-class ( class -- )
- dup mixin-class? [
- drop
- ] [
- [ { } redefine-mixin-class ]
- [ H{ } clone "instances" set-word-prop ]
- [ update-classes ]
- tri
- ] if ;
-
TUPLE: check-mixin-class class ;
: check-mixin-class ( mixin -- mixin )
\ check-mixin-class boa throw
] unless ;
+<PRIVATE
+
+: redefine-mixin-class ( class members -- )
+ [ (define-union-class) ]
+ [ drop changed-conditionally ]
+ [ drop t "mixin" set-word-prop ]
+ 2tri ;
+
: if-mixin-member? ( class mixin true false -- )
[ check-mixin-class 2dup members member-eq? ] 2dip if ; inline
[ [ members swap bootstrap-word ] dip call ] [ drop ] 2bi
swap redefine-mixin-class ; inline
-: update-classes/new ( mixin -- )
- class-usages
- [ [ update-class ] each ]
- [ implementors [ remake-generic ] each ] bi ;
-
: (add-mixin-instance) ( class mixin -- )
- [ [ suffix ] change-mixin-class ]
- [ [ f ] 2dip "instances" word-prop set-at ]
- 2bi ;
+ #! Call update-methods before adding the member:
+ #! - Call sites of generics specializing on 'mixin'
+ #! where the inferred type is 'class' are updated,
+ #! - Call sites where the inferred type is a subtype
+ #! of 'mixin' disjoint from 'class' are not updated
+ dup class-usages {
+ [ nip update-methods ]
+ [ drop [ suffix ] change-mixin-class ]
+ [ drop [ f ] 2dip "instances" word-prop set-at ]
+ [ 2nip [ update-class ] each ]
+ } 3cleave ;
+
+: (remove-mixin-instance) ( class mixin -- )
+ #! Call update-methods after removing the member:
+ #! - Call sites of generics specializing on 'mixin'
+ #! where the inferred type is 'class' are updated,
+ #! - Call sites where the inferred type is a subtype
+ #! of 'mixin' disjoint from 'class' are not updated
+ dup class-usages {
+ [ drop [ swap remove ] change-mixin-class ]
+ [ drop "instances" word-prop delete-at ]
+ [ 2nip [ update-class ] each ]
+ [ nip update-methods ]
+ } 3cleave ;
+
+PRIVATE>
GENERIC# add-mixin-instance 1 ( class mixin -- )
M: class add-mixin-instance
- #! Note: we call update-classes on the new member, not the
- #! mixin. This ensures that we only have to update the
- #! methods whose specializer intersects the new member, not
- #! the entire mixin (since the other mixin members are not
- #! affected at all). Also, all usages of the mixin will get
- #! updated by transitivity; the mixins usages appear in
- #! class-usages of the member, now that it's been added.
- [ 2drop ] [
- [ (add-mixin-instance) ] 2keep
- [ nip ] [ [ new-class? ] either? ] 2bi
- [ update-classes/new ] [ update-classes ] if
- ] if-mixin-member? ;
-
-: (remove-mixin-instance) ( class mixin -- )
- [ [ swap remove ] change-mixin-class ]
- [ "instances" word-prop delete-at ]
- 2bi ;
+ [ 2drop ] [ (add-mixin-instance) ] if-mixin-member? ;
: remove-mixin-instance ( class mixin -- )
- #! The order of the three clauses is important here. The last
- #! one must come after the other two so that the entries it
- #! adds to changed-generics are not overwritten.
- [
- [ (remove-mixin-instance) ]
- [ nip update-classes ]
- [ class-usages update-methods ]
- 2tri
- ] [ 2drop ] if-mixin-member? ;
-
-M: mixin-class class-forgotten remove-mixin-instance ;
+ [ (remove-mixin-instance) ] [ 2drop ] if-mixin-member? ;
+
+M: mixin-class metaclass-changed
+ over class? [ 2drop ] [ remove-mixin-instance ] if ;
+
+: define-mixin-class ( class -- )
+ dup mixin-class? [
+ drop
+ ] [
+ [ { } redefine-mixin-class ]
+ [ H{ } clone "instances" set-word-prop ]
+ [ update-classes ]
+ tri
+ ] if ;
! Definition protocol implementation ensures that removing an
! INSTANCE: declaration from a source file updates the mixin.
C: <mixin-instance> mixin-instance
+<PRIVATE
+
: >mixin-instance< ( mixin-instance -- class mixin )
[ class>> ] [ mixin>> ] bi ; inline
+PRIVATE>
+
M: mixin-instance where >mixin-instance< "instances" word-prop at ;
M: mixin-instance set-where >mixin-instance< "instances" word-prop set-at ;
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser vocabs.parser words kernel classes compiler.units lexer ;
IN: classes.parser
: create-class-in ( string -- word )
current-vocab create
dup save-class-location
- dup predicate-word dup set-word save-location ;
+ dup create-predicate-word dup set-word save-location ;
: CREATE-CLASS ( -- word )
scan create-class-in ;
USING: math tools.test classes.algebra words kernel sequences assocs
-accessors eval definitions compiler.units generic ;
+accessors eval definitions compiler.units generic strings classes
+generic.single ;
IN: classes.predicate.tests
PREDICATE: negative < integer 0 < ;
[ tuple-a ] [ tuple-b new ptest' ] unit-test
[ tuple-d ] [ tuple-b new t >>slot ptest' ] unit-test
+
+PREDICATE: bad-inheritance-predicate < string ;
+[
+ "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate < bad-inheritance-predicate ;" eval( -- )
+] [ error>> bad-inheritance? ] must-fail-with
+
+PREDICATE: bad-inheritance-predicate2 < string ;
+PREDICATE: bad-inheritance-predicate3 < bad-inheritance-predicate2 ;
+[
+ "IN: classes.predicate.tests PREDICATE: bad-inheritance-predicate2 < bad-inheritance-predicate3 ;" eval( -- )
+] [ error>> bad-inheritance? ] must-fail-with
+
+! This must not fail
+PREDICATE: tup < string ;
+UNION: u tup ;
+
+[ ] [ "IN: classes.predicate.tests PREDICATE: u < tup ;" eval( -- ) ] unit-test
+
+! Changing the metaclass of the predicate superclass should work
+GENERIC: change-meta-test ( a -- b )
+
+TUPLE: change-meta-test-class length ;
+
+PREDICATE: change-meta-test-predicate < change-meta-test-class length>> 2 > ;
+
+M: change-meta-test-predicate change-meta-test length>> ;
+
+[ f ] [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test
+
+[ T{ change-meta-test-class f 0 } change-meta-test ] [ no-method? ] must-fail-with
+[ 7 ] [ T{ change-meta-test-class f 7 } change-meta-test ] unit-test
+
+[ ] [ "IN: classes.predicate.tests USE: arrays UNION: change-meta-test-class array ;" eval( -- ) ] unit-test
+
+! Should not have changed
+[ change-meta-test-class ] [ change-meta-test-predicate superclass ] unit-test
+[ { } change-meta-test ] [ no-method? ] must-fail-with
+[ 4 ] [ { 1 2 3 4 } change-meta-test ] unit-test
+
+[ ] [ [ \ change-meta-test-class forget-class ] with-compilation-unit ] unit-test
+
+[ f ] [ change-meta-test-predicate class? ] unit-test
+
+[ t ] [ \ change-meta-test "methods" word-prop assoc-empty? ] unit-test
-! Copyright (C) 2004, 2009 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: classes classes.algebra classes.algebra.private kernel
-namespaces make words sequences quotations arrays kernel.private
-assocs combinators ;
+USING: classes classes.private classes.algebra
+classes.algebra.private kernel namespaces make words sequences
+quotations arrays kernel.private assocs combinators ;
IN: classes.predicate
PREDICATE: predicate-class < class
"metaclass" word-prop predicate-class eq? ;
+<PRIVATE
+
GENERIC: predicate-quot ( class -- quot )
M: predicate-class predicate-quot
[ drop f ] , \ if ,
] [ ] make ;
+PRIVATE>
+
: define-predicate-class ( class superclass definition -- )
[ drop f f predicate-class define-class ]
[ nip "predicate-definition" set-word-prop ]
-! Copyright (C) 2008, 2009 Doug Coleman, Slava Pestov.
+! Copyright (C) 2008, 2010 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes classes.algebra classes.algebra.private
-classes.predicate kernel sequences words ;
+classes.predicate classes.predicate.private kernel sequences
+words ;
IN: classes.singleton
+<PRIVATE
+
: singleton-predicate-quot ( class -- quot ) [ eq? ] curry ;
+PRIVATE>
+
PREDICATE: singleton-class < predicate-class
[ "predicate-definition" word-prop ]
[ singleton-predicate-quot ]
[
"IN: classes.tuple.parser.tests TUPLE: bad-inheritance-tuple2 < bad-inheritance-tuple3 ;" eval( -- )
] [ error>> bad-inheritance? ] must-fail-with
+
+! This must not fail
+TUPLE: tup ;
+UNION: u tup ;
+
+[ ] [ "IN: classes.tuple.parser.tests TUPLE: u < tup ;" eval( -- ) ] unit-test
+
+[ t ] [ u new tup? ] unit-test
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel sets namespaces make sequences parser
lexer combinators words classes.parser classes.tuple arrays
-slots math assocs parser.notes classes.algebra ;
+slots math assocs parser.notes classes classes.algebra ;
IN: classes.tuple.parser
: slot-names ( slots -- seq )
: parse-tuple-slots ( -- )
";" parse-tuple-slots-delim ;
-ERROR: bad-inheritance class superclass ;
-
-: check-inheritance ( class1 class2 -- class1 class2 )
- 2dup swap class<= [ bad-inheritance ] when ;
-
: parse-tuple-definition ( -- class superclass slots )
CREATE-CLASS
- scan 2dup = [ ] when {
+ scan {
{ ";" [ tuple f ] }
- { "<" [
- scan-word check-inheritance [ parse-tuple-slots ] { } make
- ] }
+ { "<" [ scan-word [ parse-tuple-slots ] { } make ] }
[ tuple swap [ parse-slot-name [ parse-tuple-slots ] when ] { } make ]
} case
dup check-duplicate-slots
}
"The " { $vocab-link "delegate" } " library provides a language abstraction for expressing has-a relationships."
{ $heading "Anti-pattern #2: subclassing for implementation sharing only" }
-"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this properly does not hold, then subclassing should not be used."
+"Tuple subclassing purely for sharing implementations of methods is not a good idea either. If a class " { $snippet "A" } " is a subclass of a class " { $snippet "B" } ", then instances of " { $snippet "A" } " should be usable anywhere that an instance of " { $snippet "B" } " is. If this property does not hold, then subclassing should not be used."
$nl
"There are two alternatives which are preferred to subclassing in this case. The first is " { $link "mixins" } "."
$nl
"The second is to use ad-hoc slot polymorphism. If two classes define a slot with the same name, then code which uses " { $link "accessors" } " can operate on instances of both objects, assuming the values stored in that slot implement a common protocol. This allows code to be shared without creating contrieved relationships between classes."
{ $heading "Anti-pattern #3: subclassing to override a method definition" }
-"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of “monkey patching” methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document that subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
+"While method overriding is a very powerful tool, improper use can cause tight coupling of code and lead to difficulty in testing and refactoring. Subclassing should not be used as a means of “monkey patching” methods to fix bugs and add features. Only subclass from classes which were designed to be inherited from, and when writing classes of your own which are intended to be subclassed, clearly document what subclasses may and may not do. This includes construction policy; document whether subclasses should use " { $link new } ", " { $link boa } ", or a custom parametrized constructor."
{ $see-also "parametrized-constructors" } ;
ARTICLE: "tuple-subclassing" "Tuple subclassing"
tuple>array
tuple-slots
}
+"Tuples can be compared for slot equality even if the tuple class overrides " { $link equal? } ":"
+{ $subsections tuple= }
"Tuple classes can also be defined at run time:"
{ $subsections define-tuple-class }
{ $see-also "slots" "mirrors" } ;
HELP: tuple=
{ $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } }
-{ $description "Low-level tuple equality test. User code should use " { $link = } " instead." }
-{ $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ;
+{ $description "Checks if two tuples have equal slot values. This is the default behavior of " { $link = } " on tuples, unless the tuple class subclasses " { $link identity-tuple } " or implements a method on " { $link equal? } ". In cases where equality has been redefined, this word can be used to get the default semantics if needed." } ;
HELP: tuple
{ $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class."
HELP: new
{ $values { "class" tuple-class } { "tuple" tuple } }
-{ $description "Creates a new instance of " { $snippet "class" } " with all slots set to their initial values (see" { $link "tuple-declarations" } ")." }
+{ $description "Creates a new instance of " { $snippet "class" } " with all slots set to their initial values (see " { $link "tuple-declarations" } ")." }
{ $examples
{ $example
"USING: kernel prettyprint ;"
math.order namespaces parser parser.notes prettyprint
quotations random see sequences sequences.private slots
slots.private splitting strings summary threads tools.test
-vectors vocabs words words.symbol fry literals ;
+vectors vocabs words words.symbol fry literals memory ;
IN: classes.tuple.tests
TUPLE: rect x y w h ;
[ ] [
[
- \ vocab tuple { "xxx" } "slots" get append
+ \ vocab identity-tuple { "xxx" } "slots" get append
define-tuple-class
] with-compilation-unit
all-words drop
[
- \ vocab tuple "slots" get
+ \ vocab identity-tuple "slots" get
define-tuple-class
] with-compilation-unit
] unit-test
! Missing error check
[ "IN: classes.tuple.tests USE: words TUPLE: wrong-superclass < word ;" eval( -- ) ] must-fail
-! Class forget messyness
-TUPLE: subclass-forget-test ;
-
-TUPLE: subclass-forget-test-1 < subclass-forget-test ;
-TUPLE: subclass-forget-test-2 < subclass-forget-test ;
-TUPLE: subclass-forget-test-3 < subclass-forget-test-2 ;
-
-[ ] [ "IN: classes.tuple.tests FORGET: subclass-forget-test" eval( -- ) ] unit-test
-
-[ { subclass-forget-test-2 } ]
-[ subclass-forget-test-2 class-usages ]
-unit-test
-
-[ { subclass-forget-test-3 } ]
-[ subclass-forget-test-3 class-usages ]
-unit-test
-
-[ f ] [ subclass-forget-test-1 tuple-class? ] unit-test
-[ f ] [ subclass-forget-test-2 tuple-class? ] unit-test
-[ subclass-forget-test-3 new ] must-fail
-
-[ "IN: classes.tuple.tests TUPLE: subclass-forget-test-4 < subclass-forget-test-2 ;" eval( -- ) ] must-fail
-
-! More
-DEFER: subclass-reset-test
-DEFER: subclass-reset-test-1
-DEFER: subclass-reset-test-2
-DEFER: subclass-reset-test-3
-
-GENERIC: break-me ( obj -- )
-
-[ ] [ [ M\ integer break-me forget ] with-compilation-unit ] unit-test
-
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-1 < subclass-reset-test ;" eval( -- ) ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-2 < subclass-reset-test ;" eval( -- ) ] unit-test
-[ ] [ "IN: classes.tuple.tests TUPLE: subclass-reset-test-3 < subclass-reset-test-2 ;" eval( -- ) ] unit-test
-
-[ ] [ "IN: classes.tuple.tests USE: kernel M: subclass-reset-test-1 break-me drop ;" eval( -- ) ] unit-test
-
-[ ] [ "IN: classes.tuple.tests : subclass-reset-test ( -- ) ;" <string-reader> "subclass-reset-test" parse-stream drop ] unit-test
-
-[ f ] [ subclass-reset-test-1 tuple-class? ] unit-test
-[ f ] [ subclass-reset-test-2 tuple-class? ] unit-test
-[ subclass-forget-test-3 new ] must-fail
-
-[ t ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
-
-[ ] [ "IN: classes.tuple.tests USE: math USE: kernel M: integer break-me drop ;" eval( -- ) ] unit-test
-
-[ f ] [ \ break-me "methods" word-prop assoc-empty? ] unit-test
-
! Insufficient type checking
[ \ vocab tuple>array drop ] must-fail
[ "prototype" word-prop ] map
[ '[ _ hashcode drop f ] [ drop t ] recover ] filter
] unit-test
+
+! Make sure that tuple reshaping updates code heap roots
+TUPLE: code-heap-ref ;
+
+: code-heap-ref' ( -- a ) T{ code-heap-ref } ;
+
+! Push foo's literal to tenured space
+[ ] [ gc ] unit-test
+
+! Reshape!
+[ ] [ "IN: classes.tuple.tests USE: math TUPLE: code-heap-ref { x integer initial: 5 } ;" eval( -- ) ] unit-test
+
+! Code heap reference
+[ t ] [ code-heap-ref' code-heap-ref? ] unit-test
+[ 5 ] [ code-heap-ref' x>> ] unit-test
+
+! Data heap reference
+[ t ] [ \ code-heap-ref' def>> first code-heap-ref? ] unit-test
+[ 5 ] [ \ code-heap-ref' def>> first x>> ] unit-test
+
+! If the metaclass of a superclass changes into something other
+! than a tuple class, the tuple needs to have its superclass reset
+TUPLE: metaclass-change ;
+TUPLE: metaclass-change-subclass < metaclass-change ;
+
+[ metaclass-change ] [ metaclass-change-subclass superclass ] unit-test
+
+[ ] [ "IN: classes.tuple.tests MIXIN: metaclass-change" eval( -- ) ] unit-test
+
+[ t ] [ metaclass-change-subclass tuple-class? ] unit-test
+[ tuple ] [ metaclass-change-subclass superclass ] unit-test
+
+! Reshaping bug related to the above
+TUPLE: a-g ;
+TUPLE: g < a-g ;
+
+[ ] [ g new "g" set ] unit-test
+
+[ ] [ "IN: classes.tuple.tests MIXIN: a-g TUPLE: g ;" eval( -- ) ] unit-test
+
+[ t ] [ g new layout-of "g" get layout-of eq? ] unit-test
ERROR: not-a-tuple object ;
-: check-tuple ( object -- tuple )
- dup tuple? [ not-a-tuple ] unless ; inline
-
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
: tuple-size ( tuple -- size )
layout-of 3 slot { fixnum } declare ; inline
+: check-tuple ( object -- tuple )
+ dup tuple? [ not-a-tuple ] unless ; inline
+
: prepare-tuple>array ( tuple -- n tuple layout )
check-tuple [ tuple-size iota ] [ ] [ layout-of ] tri ;
] 2each
] if-bootstrapping ; inline
-PRIVATE>
-
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ initial-values over length tail append ] keep ; inline
+PRIVATE>
+
: tuple>array ( tuple -- array )
prepare-tuple>array
[ copy-tuple-slots ] dip
2drop
[
[ update-tuples-after ]
- [ changed-definition ]
+ [ changed-conditionally ]
bi
] each-subclass
]
GENERIC# (define-tuple-class) 2 ( class superclass slots -- )
+: thrower-effect ( slots -- effect )
+ [ name>> ] map { "*" } <effect> ;
+
PRIVATE>
: define-tuple-class ( class superclass slots -- )
3dup tuple-class-unchanged?
[ 2drop ?define-symbol ] [ redefine-tuple-class ] if ;
-: thrower-effect ( slots -- effect )
- [ name>> ] map { "*" } <effect> ;
-
: define-error-class ( class superclass slots -- )
[ define-tuple-class ]
[ 2drop reset-generic ]
bi
] bi ;
+M: tuple-class metaclass-changed
+ ! Our superclass is no longer a tuple class, redefine with
+ ! default superclass
+ nip tuple over "slots" word-prop define-tuple-class ;
+
M: tuple-class rank-class drop 0 ;
M: tuple-class instance?
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-classes.algebra classes.algebra.private namespaces arrays math
-quotations ;
+classes.private classes.algebra classes.algebra.private
+namespaces arrays math quotations definitions ;
IN: classes.union
PREDICATE: union-class < class
"metaclass" word-prop union-class eq? ;
+<PRIVATE
+
: union-predicate-quot ( members -- quot )
[
[ drop f ]
M: union-class update-class define-union-predicate ;
: (define-union-class) ( class members -- )
- f swap f union-class define-class ;
+ f swap f union-class make-class-props (define-class) ;
+
+PRIVATE>
: define-union-class ( class members -- )
- [ (define-union-class) ] [ drop update-classes ] 2bi ;
+ [ (define-union-class) ]
+ [ drop changed-conditionally ]
+ [ drop update-classes ]
+ 2tri ;
M: union-class rank-class drop 2 ;
M: union-class instance?
"members" word-prop [ instance? ] with any? ;
+M: union-class normalize-class
+ members <anonymous-union> normalize-class ;
+
M: union-class (flatten-class)
members <anonymous-union> (flatten-class) ;
"A generalization of the above combinators to any number of quotations can be found in " { $link "combinators" } "." ;
ARTICLE: "apply-combinators" "Apply combinators"
-"The apply combinators apply a single quotation to multiple values. The asterisk (" { $snippet "@" } ") suffixed to these words' names signifies that they are apply combinators."
-$nl
-"Two quotations:"
-{ $subsections bi@ 2bi@ }
-"Three quotations:"
-{ $subsections tri@ 2tri@ }
+"The apply combinators apply a single quotation to multiple values. The at sign (" { $snippet "@" } ") suffixed to these words' names signifies that they are apply combinators."
+{ $subsections bi@ 2bi@ tri@ 2tri@ }
"A pair of condition words built from " { $link bi@ } " to test two values:"
{ $subsections both? either? }
"All of the apply combinators are equivalent to using the corresponding " { $link "spread-combinators" } " with the same quotation supplied for every value." ;
-! Copyright (C) 2008, 2009 Slava Pestov.
+! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel continuations assocs namespaces
-sequences words vocabs definitions hashtables init sets
-math math.order classes classes.algebra classes.tuple
-classes.tuple.private generic source-files.errors
-kernel.private ;
+sequences words vocabs definitions hashtables init sets math
+math.order classes classes.private classes.algebra classes.tuple
+classes.tuple.private generic source-files.errors kernel.private ;
IN: compiler.units
SYMBOL: old-definitions
SYMBOL: compiler-impl
+HOOK: update-call-sites compiler-impl ( class generic -- words )
+
+: changed-call-sites ( class generic -- )
+ update-call-sites [ changed-definition ] each ;
+
+M: generic update-generic ( class generic -- )
+ [ changed-call-sites ]
+ [ remake-generic drop ]
+ [ changed-conditionally drop ]
+ 2tri ;
+
+M: sequence update-methods ( class seq -- )
+ implementors [ update-generic ] with each ;
+
HOOK: recompile compiler-impl ( words -- alist )
HOOK: to-recompile compiler-impl ( -- words )
: compile ( words -- ) recompile modify-code-heap ;
! Non-optimizing compiler
-M: f recompile
- [ dup def>> ] { } map>assoc ;
+M: f update-call-sites
+ 2drop { } ;
M: f to-recompile
- changed-definitions get [ drop word? ] assoc-filter
- changed-generics get assoc-union keys ;
+ changed-definitions get [ drop word? ] assoc-filter keys ;
+
+M: f recompile
+ [ dup def>> ] { } map>assoc ;
M: f process-forgotten-words drop ;
: without-optimizer ( quot -- )
[ f compiler-impl ] dip with-variable ; inline
-! Trivial compiler. We don't want to touch the code heap
-! during stage1 bootstrap, it would just waste time.
-SINGLETON: dummy-compiler
-
-M: dummy-compiler to-recompile f ;
-
-M: dummy-compiler recompile drop { } ;
-
-M: dummy-compiler process-forgotten-words drop ;
-
: <definitions> ( -- pair ) { H{ } H{ } } [ clone ] map ;
SYMBOL: definition-observers
! inline caching
: effect-counter ( -- n ) 47 special-object ; inline
-GENERIC: bump-effect-counter* ( defspec -- ? )
+GENERIC: always-bump-effect-counter? ( defspec -- ? )
-M: object bump-effect-counter* drop f ;
+M: object always-bump-effect-counter? drop f ;
<PRIVATE
dup new-definitions get first update
dup new-definitions get second update
dup changed-definitions get update
+ dup maybe-changed get update
dup dup changed-vocabs update ;
: process-forgotten-definitions ( -- )
bi ;
: bump-effect-counter? ( -- ? )
- changed-effects get new-words get assoc-diff assoc-empty? not
- changed-definitions get [ drop bump-effect-counter* ] assoc-any?
- or ;
+ changed-effects get
+ maybe-changed get
+ changed-definitions get [ drop always-bump-effect-counter? ] assoc-filter
+ 3array assoc-combine new-words get assoc-diff assoc-empty? not ;
: bump-effect-counter ( -- )
bump-effect-counter? [
[ drop ] [ notify-definition-observers notify-error-observers ] if ;
: finish-compilation-unit ( -- )
- remake-generics
- to-recompile recompile
- update-tuples
- process-forgotten-definitions
- modify-code-heap
- bump-effect-counter
- notify-observers ;
+ [ ] [
+ remake-generics
+ to-recompile recompile
+ update-tuples
+ process-forgotten-definitions
+ modify-code-heap
+ bump-effect-counter
+ notify-observers
+ ] if-bootstrapping ;
PRIVATE>
: with-nested-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
- H{ } clone changed-generics set
+ H{ } clone maybe-changed set
H{ } clone changed-effects set
H{ } clone outdated-generics set
H{ } clone outdated-tuples set
H{ } clone new-words set
- H{ } clone new-classes set
[ finish-compilation-unit ] [ ] cleanup
] with-scope ; inline
: with-compilation-unit ( quot -- )
[
H{ } clone changed-definitions set
- H{ } clone changed-generics set
+ H{ } clone maybe-changed set
H{ } clone changed-effects set
H{ } clone outdated-generics set
H{ } clone forgotten-definitions set
H{ } clone outdated-tuples set
H{ } clone new-words set
- H{ } clone new-classes set
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ] [ ] cleanup
{ $code
"USING: io sequences ;"
"IN: a"
- ": hello \"Hello\" ;"
- ": world \"world\" ;"
- ": hello-world hello " " world 3append print ;"
+ ": hello ( -- str ) \"Hello\" ;"
+ ": world ( -- str ) \"world\" ;"
+ ": hello-world ( -- ) hello \" \" world 3append print ;"
}
"The definitions for " { $snippet "hello" } ", " { $snippet "world" } ", and " { $snippet "hello-world" } " are in the dictionary."
$nl
{ $code
"USING: namespaces ;"
"IN: a"
- ": hello \"Hello\" % ;"
- ": hello-world [ hello " " % world ] \"\" make ;"
- ": world \"world\" % ;"
+ ": hello ( -- ) \"Hello\" % ;"
+ ": hello-world ( -- str ) [ hello \" \" % world ] \"\" make ;"
+ ": world ( -- ) \"world\" % ;"
}
"Note that the developer has made a mistake, placing the definition of " { $snippet "world" } " " { $emphasis "after" } " its usage in " { $snippet "hello-world" } "."
$nl
-! Copyright (C) 2006, 2009 Slava Pestov.
+! Copyright (C) 2006, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences namespaces assocs math accessors ;
IN: definitions
: changed-definition ( defspec -- )
dup changed-definitions get set-in-unit ;
-SYMBOL: changed-effects
+SYMBOL: maybe-changed
+
+: changed-conditionally ( class -- )
+ dup maybe-changed get set-in-unit ;
-SYMBOL: changed-generics
+SYMBOL: changed-effects
SYMBOL: outdated-generics
SYMBOL: new-words
-SYMBOL: new-classes
-
: new-word ( word -- )
dup new-words get set-in-unit ;
: new-word? ( word -- ? )
new-words get key? ;
-: new-class ( word -- )
- dup new-classes get set-in-unit ;
-
-: new-class? ( word -- ? )
- new-classes get key? ;
-
GENERIC: where ( defspec -- loc )
M: object where drop f ;
{ $code
"GENERIC: explain ( object -- )"
"M: object explain drop \"an object\" print ;"
- "M: generic explain drop \"a class word\" print ;"
- "M: class explain drop \"a generic word\" print ;"
+ "M: generic explain drop \"a generic word\" print ;"
+ "M: class explain drop \"a class word\" print ;"
}
"The linear order is the following, from least-specific to most-specific:"
{ $code "{ object generic class }" }
-"Neither " { $link class } " nor " { $link generic } " are subclasses of each other, and their intersection is non-empty. Calling " { $snippet "explain" } " with a word on the stack that is both a class and a generic word will print " { $snippet "a generic word" } " because " { $link class } " precedes " { $link generic } " in the class linearization order. (One example of a word which is both a class and a generic word is the class of classes, " { $link class } ", which is also a word to get the class of an object.)"
+"Neither " { $link class } " nor " { $link generic } " are subclasses of each other, and their intersection is non-empty. Calling " { $snippet "explain" } " with a word on the stack that is both a class and a generic word will print " { $snippet "a class word" } " because " { $link class } " is more specific than " { $link generic } " in the class linearization order. (One example of a word which is both a class and a generic word is the class of classes, " { $link class } ", which is also a word to get the class of an object.)"
$nl
"The " { $link order } " word can be useful to clarify method dispatch order:"
{ $subsections order } ;
ARTICLE: "generic-introspection" "Generic word introspection"
"In most cases, generic words and methods are defined at parse time with " { $link POSTPONE: GENERIC: } " (or some other parsing word) and " { $link POSTPONE: M: } "."
$nl
-"Sometimes, generic words need to be inspected defined at run time; words for performing these tasks are found in the " { $vocab-link "generic" } " vocabulary."
+"Sometimes, generic words need to be inspected or defined at run time; words for performing these tasks are found in the " { $vocab-link "generic" } " vocabulary."
$nl
"The set of generic words is a class which implements the " { $link "definition-protocol" } ":"
{ $subsections
} ;
ARTICLE: "generic" "Generic words and methods"
-"A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word executed, the method combination chooses the most appropriate method and calls its definition."
+"A " { $emphasis "generic word" } " is composed of zero or more " { $emphasis "methods" } " together with a " { $emphasis "method combination" } ". A method " { $emphasis "specializes" } " on a class; when a generic word is executed, the method combination chooses the most appropriate method and calls its definition."
$nl
"A generic word behaves roughly like a long series of class predicate conditionals in a " { $link cond } " form, however methods can be defined in independent source files, reducing coupling and increasing extensibility. The method combination determines which object the generic word will " { $emphasis "dispatch" } " on; this could be the top of the stack, or some other value."
$nl
{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
{ $notes "To define a method, pass the output value to " { $link define } "." } ;
-HELP: forget-methods
-{ $values { "class" class } }
-{ $description "Remove all method definitions which specialize on the class." } ;
-
{ sort-classes order } related-words
HELP: (call-next-method)
[ ] [ "IN: generic.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test
[ { } ] [
- \ + compiled-usage keys
- [ method-body? ] filter
+ \ + effect-dependencies-of keys [ method-body? ] filter
[ "method-generic" word-prop \ forget-test eq? ] filter
] unit-test
\ 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 outdated-generics get set-in-unit ;
: remake-generics ( -- )
outdated-generics get keys [ generic? ] filter [ make-generic ] each ;
+GENERIC: update-generic ( class generic -- )
+
: with-methods ( class generic quot -- )
- [ drop changed-generic ]
- [ [ "methods" word-prop ] dip call ]
- [ drop remake-generic drop ]
- 3tri ; inline
+ [ "methods" word-prop ] prepose [ update-generic ] 2bi ; inline
: method-word-name ( class generic -- string )
[ name>> ] bi@ "=>" glue ;
PREDICATE: method-body < word
"method-generic" word-prop >boolean ;
+M: method-body flushable?
+ "method-generic" word-prop flushable? ;
+
M: method-body stack-effect
"method-generic" word-prop stack-effect ;
[ call-next-method ] bi
] if ;
-M: sequence update-methods ( class seq -- )
- implementors [
- [ changed-generic ] [ remake-generic drop ] 2bi
- ] with each ;
-
: define-generic ( word combination effect -- )
[ nip swap set-stack-effect ]
[
[ "IN: generic.single.tests GENERIC# broken-generic# -1 ( a -- b )" eval( -- ) ]
[ error>> bad-dispatch-position? ]
must-fail-with
+
+[ ] [ "IN: generic.single.tests GENERIC: foo ( -- x )" eval( -- ) ] unit-test
+ [ "IN: generic.single.tests GENERIC: foo ( -- x ) inline" eval( -- ) ] must-fail
-! 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.algebra
combinators definitions generic hashtables kernel
PREDICATE: single-generic < generic
"combination" word-prop single-combination? ;
+M: single-generic make-inline cannot-be-inline ;
+
GENERIC: dispatch# ( word -- n )
M: generic dispatch# "combination" word-prop dispatch# ;
IN: growable
ARTICLE: "growable" "Resizable sequence implementation"
-"Resizable sequences are implementing by having a wrapper object hold a reference to an underlying sequence, together with a fill pointer indicating how many elements of the underlying sequence are occupied. When the fill pointer exceeds the underlying sequence capacity, the underlying sequence grows."
+"Resizable sequences are implemented by having a wrapper object hold a reference to an underlying sequence, together with a fill pointer indicating how many elements of the underlying sequence are occupied. When the fill pointer exceeds the underlying sequence capacity, the underlying sequence grows."
$nl
"There is a resizable sequence mixin:"
{ $subsections growable }
ARTICLE: "hashtables.keys" "Hashtable keys"
"Hashtables rely on the " { $link hashcode } " word to rapidly locate values associated with keys. The objects used as keys in a hashtable must obey certain restrictions."
$nl
-"The " { $link hashcode } " of a key is a function of the its slot values, and if the hashcode changes then the hashtable will be left in an inconsistent state. The easiest way to avoid this problem is to never mutate objects used as hashtable keys."
+"The " { $link hashcode } " of a key is a function of its slot values, and if the hashcode changes then the hashtable will be left in an inconsistent state. The easiest way to avoid this problem is to never mutate objects used as hashtable keys."
$nl
"In certain advanced applications, this cannot be avoided and the best design involves mutating hashtable keys. In this case, a custom " { $link hashcode* } " method must be defined which only depends on immutable slots."
$nl
HELP: read-until
{ $values { "seps" string } { "seq" { $or byte-array string f } } { "sep/f" "a character or " { $link f } } }
-{ $contract "Reads elements from " { $link input-stream } ". until the first occurrence of a separator, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output. In the latter case, the entire stream contents are output, along with " { $link f } "." }
+{ $contract "Reads elements from " { $link input-stream } " until the first occurrence of a separator, or stream exhaustion. In the former case, the separator character is pushed on the stack, and is not part of the output. In the latter case, the entire stream contents are output, along with " { $link f } "." }
$io-error ;
HELP: read-partial
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 <file-reader>"
- "dup stream-readln number>string over stream-read 16 group"
+ "dup stream-readln string>number over stream-read 16 group"
"swap dispose"
}
"This code has two problems: it has some unnecessary stack shuffling, and if either " { $link stream-readln } " or " { $link stream-read } " throws an I/O error, the stream is not closed because " { $link dispose } " is never reached. So we can add a call to " { $link with-disposal } " to ensure the stream is always closed:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 <file-reader> ["
- " dup stream-readln number>string over stream-read"
+ " dup stream-readln string>number over stream-read"
" 16 group"
"] with-disposal"
}
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 <file-reader> ["
- " readln number>string read 16 group"
+ " readln string>number read 16 group"
"] with-input-stream"
}
"An even better implementation that takes advantage of a utility word:"
{ $code
"USING: continuations kernel io io.files math.parser splitting ;"
"\"data.txt\" utf8 ["
- " readln number>string read 16 group"
+ " readln string>number read 16 group"
"] with-file-reader"
} ;
HELP: null
{ $class-description
"The canonical empty class with no instances."
+}
+{ $notes
+ "Unlike " { $snippet "null" } " in Java or " { $snippet "NULL" } " in C++, this is not a value signifying empty, or nothing. Use " { $link f } " for this purpose."
} ;
HELP: most
"is equivalent to"
{ $code "[ reverse ] map concat" }
{ $heading "Utilities for simple make patterns" }
-"Sometimes, an existing word already implements a specific " { $link make } " usage. For example, " { $link suffix } " is equivalent to the following, with the added caveat that the below example always outputs an array:"
+"Sometimes, an existing word already implements a specific " { $link make } " usage. For example, " { $link prefix } " is equivalent to the following, with the added caveat that the below example always outputs an array:"
{ $code "[ , % ] { } make" }
"The existing utility words can in some cases express intent better than a bunch of " { $link , } " and " { $link % } "."
{ $heading "Constructing quotations" }
"Simple quotation construction can often be accomplished using " { $link "fry" } " and " { $link "compositional-combinators" } "."
$nl
"For example,"
-{ $code "[ 2 , , \ + , ] [ ] make" }
+{ $code "[ 2 , , \\ + , ] [ ] make" }
"is better expressed as"
{ $code "'[ 2 _ + ]" } ;
HELP: next-power-of-2
{ $values { "m" "a non-negative integer" } { "n" "an integer" } }
-{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 1." } ;
+{ $description "Outputs the smallest power of 2 greater than " { $snippet "m" } ". The output value is always at least 2." } ;
HELP: power-of-2?
{ $values { "n" integer } { "?" "a boolean" } }
"Also, top-level forms run in a new dynamic scope, so using " { $link set } " to store values is almost always wrong, since the values will be lost after the top-level form completes. To save values computed by a top-level form, either use " { $link set-global } " or define a new word with the value." ;
ARTICLE: "parser" "The parser"
-"The Factor parser reading textual representations of objects and definitions, with all syntax determined by " { $link "parsing-words" } ". The parser is implemented in the " { $vocab-link "parser" } " vocabulary, with standard syntax in the " { $vocab-link "syntax" } " vocabulary. See " { $link "syntax" } " for a description of standard syntax."
+"The Factor parser reads textual representations of objects and definitions, with all syntax determined by " { $link "parsing-words" } ". The parser is implemented in the " { $vocab-link "parser" } " vocabulary, with standard syntax in the " { $vocab-link "syntax" } " vocabulary. See " { $link "syntax" } " for a description of standard syntax."
$nl
"The parser cross-references " { $link "source-files" } " and " { $link "definitions" } ". This functionality is used for improved error checking, as well as tools such as " { $link "tools.crossref" } " and " { $link "editor" } "."
$nl
: with-file-vocabs ( quot -- )
[
- <manifest> manifest set
"syntax" use-vocab
bootstrap-syntax get [ use-words ] when*
call
- ] with-scope ; inline
+ ] with-manifest ; inline
SYMBOL: print-use-hook
"Although quotations can be treated as sequences, the compiler will be unable to reason about quotations manipulated as sequences at runtime. " { $link "compositional-combinators" } " are provided for runtime partial application and composition of quotations." ;
ARTICLE: "wrappers" "Wrappers"
-"Wrappers evaluate to the object being wrapped when encountered in code. They are are used to suppress the execution of " { $link "words" } " so that they can be used as values."
+"Wrappers evaluate to the object being wrapped when encountered in code. They are used to suppress the execution of " { $link "words" } " so that they can be used as values."
{ $subsections
wrapper
literalize
definitions ;
: record-top-level-form ( quot file -- )
- (>>top-level-form) H{ } notify-definition-observers ;
+ (>>top-level-form)
+ [ ] [ H{ } notify-definition-observers ] if-bootstrapping ;
: record-checksum ( lines source-file -- )
[ crc32 checksum-lines ] dip (>>checksum) ;
$nl
"If a quotation contains a literal object, the same literal object instance is used each time the quotation executes; that is, literals are “live”."
$nl
-"Using mutable object literals in word definitions requires care, since if those objects are mutated, the actual word definition will be changed, which is in most cases not what you would expect. Literals should be " { $link clone } "d before being passed to word which may potentially mutate them."
+"Using mutable object literals in word definitions requires care, since if those objects are mutated, the actual word definition will be changed, which is in most cases not what you would expect. Literals should be " { $link clone } "d before being passed to a word which may potentially mutate them."
{ $subsections
"syntax-numbers"
"syntax-words"
{ $subsections add-vocab-root } ;
ARTICLE: "vocabs.roots" "Vocabulary roots"
-"The vocabulary loader searches for it in one of the root directories:"
+"The vocabulary loader searches for vocabularies in one of the root directories:"
{ $subsections vocab-roots }
"The default set of roots includes the following directories in the Factor source directory:"
{ $list
IN: vocabs.parser.tests
-USING: vocabs.parser tools.test eval kernel accessors ;
+USING: vocabs.parser tools.test eval kernel accessors definitions
+compiler.units words vocabs ;
[ "FROM: kernel => doesnotexist ;" eval( -- ) ]
[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
[ "RENAME: doesnotexist kernel => newname" eval( -- ) ]
[ error>> T{ no-word-in-vocab { word "doesnotexist" } { vocab "kernel" } } = ]
-must-fail-with
\ No newline at end of file
+must-fail-with
+
+: aaa ( -- ) ;
+
+[
+ [ ] [ "aaa" "vocabs.parser.tests" "uutt" add-renamed-word ] unit-test
+
+ [ ] [ "vocabs.parser.tests" dup add-qualified ] unit-test
+
+ [ aaa ] [ "uutt" search ] unit-test
+ [ aaa ] [ "vocabs.parser.tests:aaa" search ] unit-test
+
+ [ ] [ [ "bbb" "vocabs.parser.tests" create drop ] with-compilation-unit ] unit-test
+
+ [ "bbb" ] [ "vocabs.parser.tests:bbb" search name>> ] unit-test
+
+ [ ] [ [ \ aaa forget ] with-compilation-unit ] unit-test
+
+ [ ] [ [ "bbb" "vocabs.parser.tests" lookup forget ] with-compilation-unit ] unit-test
+
+ [ f ] [ "uutt" search ] unit-test
+
+ [ f ] [ "vocabs.parser.tests:aaa" search ] unit-test
+
+ [ ] [ "vocabs.parser.tests.foo" set-current-vocab ] unit-test
+
+ [ ] [ [ "bbb" current-vocab create drop ] with-compilation-unit ] unit-test
+
+ [ t ] [ "bbb" search >boolean ] unit-test
+
+ [ ] [ [ "vocabs.parser.tests.foo" forget-vocab ] with-compilation-unit ] unit-test
+
+ [ [ "bbb" current-vocab create drop ] with-compilation-unit ] [ error>> no-current-vocab? ] must-fail-with
+
+ [ begin-private ] [ error>> no-current-vocab? ] must-fail-with
+
+ [ end-private ] [ error>> no-current-vocab? ] must-fail-with
+
+ [ f ] [ "bbb" search >boolean ] unit-test
+
+] with-manifest
\ No newline at end of file
-! Copyright (C) 2007, 2009 Daniel Ehrenberg, Bruno Deferrari,
+! Copyright (C) 2007, 2010 Daniel Ehrenberg, Bruno Deferrari,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs hashtables kernel namespaces sequences
sets strings vocabs sorting accessors arrays compiler.units
-combinators vectors splitting continuations math
+combinators vectors splitting continuations math words
parser.notes ;
IN: vocabs.parser
{ search-vocab-names hashtable }
{ search-vocabs vector }
{ qualified-vocabs vector }
-{ extra-words vector }
{ auto-used vector } ;
: <manifest> ( -- manifest )
H{ } clone >>search-vocab-names
V{ } clone >>search-vocabs
V{ } clone >>qualified-vocabs
- V{ } clone >>extra-words
V{ } clone >>auto-used ;
M: manifest clone
[ clone ] change-search-vocab-names
[ clone ] change-search-vocabs
[ clone ] change-qualified-vocabs
- [ clone ] change-extra-words
[ clone ] change-auto-used ;
TUPLE: extra-words words ;
: (from) ( vocab words -- vocab words words' vocab )
2dup swap load-vocab ;
-: extract-words ( seq vocab -- assoc' )
+: extract-words ( seq vocab -- assoc )
[ words>> extract-keys dup ] [ name>> ] bi
[ swap [ 2drop ] [ no-word-in-vocab ] if ] curry assoc-each ;
+: excluding-words ( seq vocab -- assoc )
+ [ nip words>> ] [ extract-words ] 2bi assoc-diff ;
+
+: qualified-words ( prefix vocab -- assoc )
+ words>> swap [ swap [ swap ":" glue ] dip ] curry assoc-map ;
+
: (lookup) ( name assoc -- word/f )
at dup forward-reference? [ drop f ] when ;
: set-current-vocab ( name -- )
create-vocab
- [ manifest get (>>current-vocab) ]
- [ words>> <extra-words> (add-qualified) ] bi ;
+ [ manifest get (>>current-vocab) ] [ (add-qualified) ] bi ;
: with-current-vocab ( name quot -- )
manifest get clone manifest [
manifest get current-vocab>> [ no-current-vocab ] unless* ;
: begin-private ( -- )
- manifest get current-vocab>> vocab-name ".private" ?tail
+ current-vocab name>> ".private" ?tail
[ drop ] [ ".private" append set-current-vocab ] if ;
: end-private ( -- )
- manifest get current-vocab>> vocab-name ".private" ?tail
+ current-vocab name>> ".private" ?tail
[ set-current-vocab ] [ drop ] if ;
: using-vocab? ( vocab -- ? )
TUPLE: qualified vocab prefix words ;
: <qualified> ( vocab prefix -- qualified )
- 2dup
- [ load-vocab words>> ] [ CHAR: : suffix ] bi*
- [ swap [ prepend ] dip ] curry assoc-map
- qualified boa ;
+ (from) qualified-words qualified boa ;
: add-qualified ( vocab prefix -- )
<qualified> (add-qualified) ;
TUPLE: exclude vocab names words ;
: <exclude> ( vocab words -- from )
- (from) [ nip words>> ] [ extract-words ] 2bi assoc-diff exclude boa ;
+ (from) excluding-words exclude boa ;
: add-words-excluding ( vocab words -- )
<exclude> (add-qualified) ;
: search ( name -- word/f )
manifest get search-manifest ;
+
+<PRIVATE
+
+GENERIC: update ( search-path-elt -- valid? )
+
+: trim-forgotten ( qualified-vocab -- valid? )
+ [ [ nip "forgotten" word-prop not ] assoc-filter ] change-words
+ words>> assoc-empty? not ;
+
+M: from update trim-forgotten ;
+M: rename update trim-forgotten ;
+M: extra-words update trim-forgotten ;
+M: exclude update trim-forgotten ;
+
+M: qualified update
+ dup vocab>> vocab [
+ dup [ prefix>> ] [ vocab>> load-vocab ] bi qualified-words
+ >>words
+ ] [ drop f ] if ;
+
+M: vocab update dup name>> vocab eq? ;
+
+: update-manifest ( manifest -- )
+ [ dup [ name>> vocab ] when ] change-current-vocab
+ [ [ drop vocab ] assoc-filter ] change-search-vocab-names
+ dup search-vocab-names>> keys [ vocab ] V{ } map-as >>search-vocabs
+ qualified-vocabs>> [ update ] filter! drop ;
+
+M: manifest definitions-changed ( assoc manifest -- )
+ nip update-manifest ;
+
+PRIVATE>
+
+: with-manifest ( quot -- )
+ <manifest> manifest [
+ [ call ] [
+ [ manifest get add-definition-observer call ]
+ [ manifest get remove-definition-observer ]
+ [ ]
+ cleanup
+ ] if-bootstrapping
+ ] with-variable ; inline
[ { } ]
[
all-words [
- "compiled-uses" word-prop 2 <groups>
- keys [ "forgotten" word-prop ] filter
+ [ "effect-dependencies" word-prop ]
+ [ "definition-dependencies" word-prop ]
+ [ "conditional-dependencies" word-prop ] tri
+ 3append [ "forgotten" word-prop ] filter
] map harvest
] unit-test
: make-deprecated ( word -- )
t "deprecated" set-word-prop ;
-: make-inline ( word -- )
+ERROR: cannot-be-inline word ;
+
+GENERIC: make-inline ( word -- )
+
+M: word make-inline
dup inline? [ drop ] [
[ t "inline" set-word-prop ]
[ changed-effect ]
: define-inline ( word def effect -- )
[ define-declared ] [ 2drop make-inline ] 3bi ;
+GENERIC: flushable? ( word -- ? )
+
+M: word flushable? "flushable" word-prop ;
+
GENERIC: reset-word ( word -- )
M: word reset-word
+ dup flushable? [ dup changed-conditionally ] when
{
"unannotated-def" "parsing" "inline" "recursive"
"foldable" "flushable" "reading" "writing" "reader"
: create ( name vocab -- word )
check-create 2dup lookup
- dup [ 2nip ] [ drop vocab-name <word> dup reveal ] if ;
+ dup [ 2nip ] [
+ drop
+ vocab-name <word>
+ dup reveal
+ dup changed-definition
+ ] if ;
: constructor-word ( name vocab -- word )
[ "<" ">" surround ] dip create ;
HINTS: recursive fixnum ;
-: recursive-main ( -- ) 11 recursive ;
+: recursive-main ( -- ) 10 recursive ;
MAIN: recursive-main
--- /dev/null
+Erik Charlebois
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.crossref help.stylesheet help.topics help.syntax
+definitions io prettyprint summary arrays math sequences vocabs strings
+see xml.data hashtables assocs game.models.collada.private game.models.util ;
+IN: game.models.collada
+
+ABOUT: "game.models.collada"
+
+ARTICLE: "game.models.collada" "Conversion of COLLADA assets"
+"The " { $vocab-link "game.models.collada" } " vocabulary implements words for converting COLLADA assets to data suitable for use with OpenGL. See the COLLADA documentation at " { $url "http://collada.org" } "." ;
+
+HELP: source
+{ $class-description "Tuple of a vertex attribute semantic, offset in triangle index buffer and float data for a single vertex attribute." } ;
+
+HELP: up-axis
+{ $description "Dynamically-scoped variable with the up axis of the tags being read." } ;
+
+HELP: unit-ratio
+{ $description "Scaling ratio for the coordinates of the tags being read." } ;
+
+HELP: string>numbers ( string -- number-seq )
+{ $values { "string" string } { "number-seq" sequence } }
+{ $description "Splits a string on whitespace and converts the elements to a number sequence." } ;
+
+HELP: string>floats ( string -- float-seq )
+{ $values { "string" string } { "float-seq" sequence } }
+{ $description "Splits a string on whitespace and converts the elements to a float sequence." } ;
+
+HELP: x-up { $class-description "Right-handed 3D coordinate system where X is up." } ;
+HELP: y-up { $class-description "Right-handed 3D coordinate system where Y is up." } ;
+HELP: z-up { $class-description "Right-handed 3D coordinate system where Z is up." } ;
+
+HELP: >y-up-axis!
+{ $values { "seq" sequence } { "from-axis" rh-up } { "seq" sequence } }
+{ $description "Destructively swizzles the first three elements of the input sequence to a right-handed 3D coordinate system where Y is up and returns the modified sequence." } ;
+
+HELP: source>seq
+{ $values { "source-tag" tag } { "up-axis" rh-up } { "scale" number } { "sequence" sequence } }
+{ $description "Convert the " { $emphasis "float_array" } " in a " { $emphasis "source tag" } " to a sequence of number sequences according to the element stride. The values are scaled according to " { $emphasis "scale" } " and swizzled from " { $emphasis "up-axis" } " so that the Y coordinate points up." } ;
+
+HELP: source>pair
+{ $values { "source-tag" tag } { "pair" pair } }
+{ $description "Convert the source tag to an id and number sequence pair." } ;
+
+HELP: mesh>sources
+{ $values { "mesh-tag" tag } { "hashtable" pair } }
+{ $description "Convert the mesh tag's source elements to a hashtable from id to number sequence." } ;
+
+HELP: mesh>vertices
+{ $values { "mesh-tag" tag } { "pair" pair } }
+{ $description "Convert the mesh tag's vertices element to a pair for further lookup in " { $link collect-sources } ". " } ;
+
+HELP: collect-sources
+{ $values { "sources" hashtable } { "vertices" pair } { "inputs" tag sequence } { "sources" sequence } }
+{ $description "Look up the sources for these " { $emphasis "input" } " elements and return a sequence of " { $link source } " tuples." } ;
+
+HELP: group-indices
+{ $values { "index-stride" number } { "triangle-count" number } { "indices" sequence } { "grouped-indices" sequence } }
+{ $description "Groups the index sequence by triangle and then groups each triangle's indices by vertex." } ;
+
+HELP: triangles>numbers
+{ $values { "triangles-tag" tag } { "number-seq" sequence } }
+{ $description "Converts the triangle data in a triangles tag from string form to a sequence of numbers." } ;
+
+HELP: largest-offset+1
+{ $values { "source-seq" sequence } { "largest-offset+1" number } }
+{ $description "Finds the largest offset in the sequence of " { $link source } " tuples and adds 1, which is the index stride for " { $link group-indices } "." } ;
+
+HELP: pack-attributes
+{ $values { "source-indices" sequence } { "sources" sequence } { "attributes" sequence } }
+{ $description "Packs the attributes for a single vertex into a sequence from a set of source data streams." } ;
+
+HELP: soa>aos
+{ $values { "triangles-indices" sequence } { "sources" sequence } { "attribute-buffer" sequence } { "index-buffer" sequence } }
+{ $description "Swizzles the input sources from a structure of arrays form to an array of structures form and generates a new index buffer." } ;
+
+HELP: triangles>model
+{ $values { "sources" sequence } { "vertices" pair } { "triangles-tag" tag } { "model" model } }
+{ $description "Creates a " { $link model } " tuple from the given triangles tag, source set and vertices pair." } ;
+
+HELP: mesh>triangles
+{ $values { "sources" sequence } { "vertices" pair } { "mesh-tag" tag } { "models" sequence } }
+{ $description "Creates a sequence of models from the triangles in the mesh tag." } ;
+
+HELP: mesh>models
+{ $values { "mesh-tag" tag } { "models" sequence } }
+{ $description "Converts a triangle mesh to a set of models suitable for rendering with OpenGL." } ;
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs grouping hashtables kernel
+locals math math.parser sequences sequences.deep
+specialized-arrays.instances.alien.c-types.float
+specialized-arrays.instances.alien.c-types.uint splitting xml
+xml.data xml.traversal math.order
+namespaces combinators images gpu.shaders io make
+game.models.util io.encodings.ascii game.models.loader ;
+IN: game.models.collada
+
+SINGLETON: collada-models
+"dae" ascii collada-models register-models-class
+
+ERROR: missing-attr tag attr ;
+ERROR: missing-child tag child-name ;
+
+<PRIVATE
+TUPLE: source semantic offset data ;
+SYMBOLS: up-axis unit-ratio ;
+
+: string>numbers ( string -- number-seq )
+ " \t\n" split harvest [ string>number ] map ;
+
+: string>floats ( string -- float-seq )
+ " \t\n" split harvest [ string>float ] map ;
+
+: x/ ( tag child-name -- child-tag )
+ [ tag-named ]
+ [ rot dup [ drop missing-child ] unless 2nip ]
+ 2bi ; inline
+
+: x@ ( tag attr-name -- attr-value )
+ [ attr ]
+ [ rot dup [ drop missing-attr ] unless 2nip ]
+ 2bi ; inline
+
+: xt ( tag -- content ) children>string ;
+
+: x* ( tag child-name quot -- seq )
+ [ tags-named ] dip map ; inline
+
+SINGLETONS: x-up y-up z-up ;
+UNION: rh-up x-up y-up z-up ;
+
+GENERIC: >y-up-axis! ( seq from-axis -- seq )
+M: x-up >y-up-axis!
+ drop dup
+ [
+ [ 0 swap nth ]
+ [ 1 swap nth neg ]
+ [ 2 swap nth ] tri
+ swap -rot
+ ] [
+ [ 2 swap set-nth ]
+ [ 1 swap set-nth ]
+ [ 0 swap set-nth ] tri
+ ] bi ;
+M: y-up >y-up-axis! drop ;
+M: z-up >y-up-axis!
+ drop dup
+ [
+ [ 0 swap nth ]
+ [ 1 swap nth neg ]
+ [ 2 swap nth ] tri
+ swap
+ ] [
+ [ 2 swap set-nth ]
+ [ 1 swap set-nth ]
+ [ 0 swap set-nth ] tri
+ ] bi ;
+
+: source>seq ( source-tag up-axis scale -- sequence )
+ rot
+ [ "float_array" x/ xt string>floats [ * ] with map ]
+ [ nip "technique_common" x/ "accessor" x/ "stride" x@ string>number ] 2bi
+ group
+ [ swap over length 2 > [ >y-up-axis! ] [ drop ] if ] with map ;
+
+: source>pair ( source-tag -- pair )
+ [ "id" x@ ]
+ [ up-axis get unit-ratio get source>seq ] bi 2array ;
+
+: mesh>sources ( mesh-tag -- hashtable )
+ "source" [ source>pair ] x* >hashtable ;
+
+: mesh>vertices ( mesh-tag -- pair )
+ "vertices" x/
+ [ "id" x@ ]
+ [ "input"
+ [
+ [ "semantic" x@ ]
+ [ "source" x@ ] bi 2array
+ ] x*
+ ] bi 2array ;
+
+:: collect-sources ( sources vertices inputs -- sources )
+ inputs
+ [| input |
+ input "source" x@ rest vertices first =
+ [
+ vertices second [| vertex |
+ vertex first
+ input "offset" x@ string>number
+ vertex second rest sources at source boa
+ ] map
+ ]
+ [
+ input [ "semantic" x@ ]
+ [ "offset" x@ string>number ]
+ [ "source" x@ rest sources at ] tri source boa
+ ] if
+ ] map flatten ;
+
+: group-indices ( index-stride triangle-count indices -- grouped-indices )
+ dup length rot / group swap [ group ] curry map ;
+
+: triangles>numbers ( triangles-tag -- number-seq )
+ "p" x/ children>string " \t\n" split [ string>number ] map ;
+
+: largest-offset+1 ( source-seq -- largest-offset+1 )
+ [ offset>> ] [ max ] map-reduce 1 + ;
+
+VERTEX-FORMAT: collada-vertex-format
+ { "POSITION" float-components 3 f }
+ { "NORMAL" float-components 3 f }
+ { "TEXCOORD" float-components 2 f } ;
+
+: pack-attributes ( source-indices sources -- attributes )
+ [
+ [
+ [
+ [ data>> ] [ offset>> ] bi
+ rot = [ nth ] [ 2drop f ] if
+ ] with with map sift flatten ,
+ ] curry each-index
+ ] V{ } make flatten ;
+
+:: soa>aos ( triangles-indices sources -- attribute-buffer index-buffer )
+ [ triangles-indices [ [ sources pack-attributes , ] each ] each ]
+ V{ } V{ } H{ } <indexed-seq> make [ dseq>> ] [ iseq>> ] bi ;
+
+: triangles>model ( sources vertices triangles-tag -- model )
+ [ "input" tags-named collect-sources ] keep swap
+
+ [
+ largest-offset+1 swap
+ [ "count" x@ string>number ] [ triangles>numbers ] bi
+ group-indices
+ ]
+ [
+ soa>aos
+ [ flatten >float-array ]
+ [ flatten >uint-array ]
+ bi* collada-vertex-format model boa
+ ] bi ;
+
+: mesh>triangles ( sources vertices mesh-tag -- models )
+ "triangles" tags-named [ triangles>model ] with with map ;
+
+: mesh>models ( mesh-tag -- models )
+ [
+ { { up-axis y-up } { unit-ratio 1 } } [
+ mesh>sources
+ ] bind
+ ]
+ [ mesh>vertices ]
+ [ mesh>triangles ] tri ;
+PRIVATE>
+
+M: collada-models stream>models
+ drop read-xml "mesh" deep-tags-named [ mesh>models ] map flatten ;
--- /dev/null
+Conversion of COLLADA geometry assets to OpenGL vertex and index buffers
--- /dev/null
+! Copyright (C) 2010 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs byte-arrays combinators game.models
+io.encodings.ascii io.files io.pathnames io.streams.byte-array
+kernel namespaces sequences splitting
+strings unicode.case arrays io.encodings ;
+IN: game.models.loader
+
+ERROR: unknown-models-extension extension ;
+
+<PRIVATE
+
+SYMBOL: types
+types [ H{ } clone ] initialize
+
+: models-class ( path -- class )
+ file-extension >lower types get ?at
+ [ unknown-models-extension ] unless second ;
+
+: models-encoding ( path -- encoding )
+ file-extension >lower types get ?at
+ [ unknown-models-extension ] unless first ;
+
+: open-models-file ( path encoding -- stream )
+ <file-reader> ;
+
+PRIVATE>
+
+GENERIC# load-models* 2 ( obj encoding class -- models )
+
+GENERIC: stream>models ( stream class -- models )
+
+: register-models-class ( extension encoding class -- )
+ 2array swap types get set-at ;
+
+: load-models ( path -- models )
+ [ dup models-encoding open-models-file ] [ models-encoding ] [ models-class ] tri load-models* ;
+
+M: byte-array load-models*
+ [ <byte-reader> ] dip stream>models ;
+
+M: decoder load-models* nip stream>models ;
+
+M: string load-models* [ open-models-file ] dip stream>models ;
+
+M: pathname load-models* [ open-models-file ] dip stream>models ;
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.crossref help.stylesheet help.topics help.syntax
+definitions io prettyprint summary arrays math sequences vocabs strings
+see ;
+IN: game.models
+
+HELP: model
+{ $class-description "Tuple of a packed attribute buffer, index buffer and vertex format suitable for a single OpenGL draw call." } ;
--- /dev/null
+! Copyright (C) 2010 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: game.models
+
+TUPLE: model attribute-buffer index-buffer vertex-format ;
+
--- /dev/null
+! Copyright (C) 2010 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io io.encodings.ascii math.parser sequences splitting kernel
+assocs io.files combinators math.order math namespaces
+arrays sequences.deep accessors
+specialized-arrays.instances.alien.c-types.float
+specialized-arrays.instances.alien.c-types.uint
+game.models.util gpu.shaders images game.models.loader ;
+IN: game.models.obj
+
+SINGLETON: obj-models
+"obj" ascii obj-models register-models-class
+
+<PRIVATE
+SYMBOLS: v vt vn i ;
+
+VERTEX-FORMAT: obj-vertex-format
+ { "POSITION" float-components 3 f }
+ { "TEXCOORD" float-components 2 f }
+ { "NORMAL" float-components 3 f } ;
+
+: string>floats ( x -- y )
+ [ string>float ] map ;
+
+: string>faces ( x -- y )
+ [ "/" split [ string>number ] map ] map ;
+
+: 3face>aos ( x -- y )
+ dup length {
+ { 3
+ [
+ first3
+ [ 1 - v get nth ]
+ [ 1 - vt get nth ]
+ [ 1 - vn get nth ] tri* 3array flatten
+ ] }
+ { 2
+ [
+ first2
+ [ 1 - v get nth ]
+ [ 1 - vt get nth ] bi* 2array flatten
+ ] }
+ } case ;
+
+
+: 4face>aos ( x -- y z )
+ [ 3 head [ 3face>aos 1array ] map ]
+ [ [ 0 swap nth ] [ 2 swap nth ] [ 3 swap nth ] tri 3array [ 3face>aos 1array ] map ]
+ bi
+ ;
+
+: faces>aos ( x -- y )
+ dup length
+ {
+ { 3 [ [ 3face>aos 1array ] map 1array ] }
+ { 4 [ 4face>aos 2array ] }
+ } case ;
+
+: push* ( x z -- y )
+ [ push ] keep ;
+
+: line>obj ( line -- )
+ " \t\n" split harvest dup
+ length 1 >
+ [
+ [ rest ] [ first ] bi
+ {
+ { "#" [ drop ] }
+ { "v" [ string>floats 3 head v [ push* ] change ] }
+ { "vt" [ string>floats 2 head vt [ push* ] change ] }
+ { "vn" [ string>floats 3 head vn [ push* ] change ] }
+ { "f" [ string>faces faces>aos [ [ i [ push* ] change ] each ] each ] }
+ { "o" [ drop ] }
+ { "g" [ drop ] }
+ { "s" [ drop ] }
+ { "mtllib" [ drop ] }
+ { "usemtl" [ drop ] }
+ } case
+ ]
+ [ drop ] if ;
+
+PRIVATE>
+
+M: obj-models stream>models
+ drop
+ [
+ V{ }
+ [ clone v set ]
+ [ clone vt set ]
+ [ clone vn set ] tri
+ V{ } V{ } H{ } <indexed-seq> i set
+ ] H{ } make-assoc
+ [
+ [ line>obj ] each-stream-line i get
+ ] bind
+ [ dseq>> flatten >float-array ]
+ [ iseq>> flatten >uint-array ] bi obj-vertex-format model boa 1array ;
+
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.crossref help.stylesheet help.topics help.syntax
+definitions io prettyprint summary arrays math sequences vocabs strings
+see xml.data hashtables assocs ;
+IN: game.models.util
+
+HELP: indexed-seq
+{ $class-description "A sequence described by a sequence of unique elements and a sequence of indices. The sequence can only be appended to. An associative map is used as a reverse lookup table when appending." } ;
+
+HELP: <indexed-seq>
+{ $values { "dseq-exemplar" sequence } { "iseq-examplar" sequence } { "rassoc-examplar" assoc } }
+{ $class-description "Construct an " { $link indexed-seq } " using the given examplars for the underlying data structures." } ;
--- /dev/null
+USING: game.models.util tools.test make accessors kernel ;
+IN: game.models.util.tests
+
+[ V{ 1 2 3 4 } ] [
+ [ 1 , 1 , 2 , 3 , 3 , 4 , ]
+ V{ } V{ } H{ } <indexed-seq> make
+ dseq>>
+] unit-test
+
+[ V{ 0 0 1 2 2 3 } ] [
+ [ 1 , 1 , 2 , 3 , 3 , 4 , ]
+ V{ } V{ } H{ } <indexed-seq> make
+ iseq>>
+] unit-test
--- /dev/null
+! Copyright (C) 2010 Your name.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences accessors kernel locals assocs ;
+IN: game.models.util
+
+TUPLE: model attribute-buffer index-buffer vertex-format ;
+
+TUPLE: indexed-seq dseq iseq rassoc ;
+INSTANCE: indexed-seq sequence
+
+M: indexed-seq length
+ iseq>> length ; inline
+
+M: indexed-seq nth
+ [ iseq>> nth ] keep dseq>> nth ; inline
+
+M:: indexed-seq set-nth ( elt n seq -- )
+ seq dseq>> :> dseq
+ seq iseq>> :> iseq
+ seq rassoc>> :> rassoc
+ seq length n = not [ seq immutable ] when
+ elt rassoc at
+ [
+ iseq push
+ ]
+ [
+ dseq length
+ [ elt rassoc set-at ]
+ [ iseq push ] bi
+ elt dseq push
+ ] if* ; inline
+
+: <indexed-seq> ( dseq-examplar iseq-exampler rassoc-examplar -- indexed-seq )
+ indexed-seq new
+ swap clone >>rassoc
+ swap clone >>iseq
+ swap clone >>dseq ;
+
+M: indexed-seq new-resizable
+ [ dseq>> ] [ iseq>> ] [ rassoc>> ] tri <indexed-seq>
+ dup -rot
+ [ [ dseq>> new-resizable ] keep (>>dseq) ]
+ [ [ iseq>> new-resizable ] keep (>>iseq) ]
+ [ [ rassoc>> clone nip ] keep (>>rassoc) ]
+ 2tri ;
+
[ gl-type vertex-attribute [ component-type>> ] [ dim>> ] bi feedback-type= ]
} 0&& [ vertex-attribute inaccurate-feedback-attribute-error ] unless ;
+:: (bind-float-vertex-attribute) ( program-instance ptr name dim gl-type normalize? stride offset -- )
+ program-instance name attribute-index :> idx
+ idx 0 >= [
+ idx glEnableVertexAttribArray
+ idx dim gl-type normalize? stride offset ptr <displaced-alien> glVertexAttribPointer
+ ] when ; inline
+
+:: (bind-int-vertex-attribute) ( program-instance ptr name dim gl-type stride offset -- )
+ program-instance name attribute-index :> idx
+ idx 0 >= [
+ idx glEnableVertexAttribArray
+ idx dim gl-type stride offset ptr <displaced-alien> glVertexAttribIPointer
+ ] when ; inline
+
:: [bind-vertex-attribute] ( stride offset vertex-attribute -- stride offset' quot )
vertex-attribute name>> hyphens>underscores :> name
vertex-attribute component-type>> :> type
{ [ name not ] [ [ 2drop ] ] }
{
[ type unnormalized-integer-components? ]
- [
- {
- name attribute-index [ glEnableVertexAttribArray ] keep
- dim gl-type stride offset
- } >quotation :> dip-block
-
- { dip-block dip <displaced-alien> glVertexAttribIPointer } >quotation
- ]
+ [ { name dim gl-type stride offset (bind-int-vertex-attribute) } >quotation ]
}
- [
- {
- name attribute-index [ glEnableVertexAttribArray ] keep
- dim gl-type normalize? stride offset
- } >quotation :> dip-block
-
- { dip-block dip <displaced-alien> glVertexAttribPointer } >quotation
- ]
+ [ { name dim gl-type normalize? stride offset (bind-float-vertex-attribute) } >quotation ]
} cond ;
:: [bind-vertex-format] ( vertex-attributes -- quot )
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors arrays assocs byte-arrays fry images kernel
+locals math math.functions math.order math.vectors namespaces
+sequences sorting ;
+IN: images.atlas
+
+! sort rects by height/width/whatever
+! use least power of two greater than k * greatest width for atlas width
+! pack stripes(y 0):
+! place first rect at x 0
+! place rects that fit in remaining stripe
+! pack stripes(y + height)
+! if height > max height
+
+TUPLE: image-placement
+ { image read-only }
+ loc ;
+
+CONSTANT: atlas-waste-factor 1.25
+CONSTANT: atlas-padding 1
+
+ERROR: atlas-image-formats-dont-match images ;
+
+<PRIVATE
+
+: width ( dim -- width ) first atlas-padding + ; inline
+: height ( dim -- height ) second atlas-padding + ; inline
+: area ( dim -- area ) [ width ] [ height ] bi * ; inline
+
+:: (pack-stripe) ( image-placements atlas-width @y -- stripe-height/f )
+ 0 :> @x!
+ f :> stripe-height!
+ image-placements [| ip |
+ ip loc>> [
+ ip image>> dim>> :> dim
+ stripe-height [ dim height stripe-height 0 or max stripe-height! ] unless
+ dim width :> w
+ atlas-width w @x + >= [
+ ip { @x @y } >>loc drop
+ @x w + @x!
+ ] when
+ ] unless
+ ] each
+ stripe-height ;
+
+:: (pack-images) ( images atlas-width sort-quot -- placements )
+ images sort-quot inv-sort-with [ f image-placement boa ] map :> image-placements
+ 0 :> @y!
+ [ image-placements atlas-width @y (pack-stripe) dup ] [ @y + @y! ] while drop
+ image-placements ; inline
+
+: atlas-image-format ( image-placements -- component-order component-type upside-down? )
+ [ image>> ] map dup unclip '[ _
+ [ [ component-order>> ] bi@ = ]
+ [ [ component-type>> ] bi@ = ]
+ [ [ upside-down?>> ] bi@ = ] 2tri and and
+ ] all?
+ [ first [ component-order>> ] [ component-type>> ] [ upside-down?>> ] tri ]
+ [ atlas-image-formats-dont-match ] if ; inline
+
+: atlas-dim ( image-placements -- dim )
+ [ [ loc>> ] [ image>> dim>> ] bi v+ atlas-padding v+n ] [ vmax ] map-reduce
+ [ next-power-of-2 ] map ; inline
+
+:: <atlas-image> ( image-placements component-order component-type upside-down? -- atlas )
+ image-placements atlas-dim :> dim
+ <image>
+ dim >>dim
+ component-order >>component-order
+ component-type >>component-type
+ upside-down? >>upside-down?
+ dim product component-order component-type (bytes-per-pixel) * <byte-array> >>bitmap ; inline
+
+:: copy-image-into-atlas ( image-placement atlas -- )
+ image-placement image>> :> image
+ image dim>> first2 :> ( w h )
+ image-placement loc>> first2 :> ( x y )
+
+ h iota [| row |
+ 0 row w image pixel-row-slice-at
+ x y row + w atlas set-pixel-row-at
+ ] each ; inline
+
+: copy-images-into-atlas ( image-placements atlas -- )
+ '[ _ copy-image-into-atlas ] each ; inline
+
+PRIVATE>
+
+: (guess-atlas-dim) ( images -- width )
+ [ dim>> area ] [ + ] map-reduce sqrt
+ atlas-waste-factor *
+ .5 + >integer ;
+
+: guess-atlas-dim ( images -- width )
+ [ (guess-atlas-dim) ] [ [ dim>> width ] [ max ] map-reduce ] bi max next-power-of-2 ;
+
+: pack-images ( images atlas-width -- placements )
+ [ dim>> second ] (pack-images) ;
+
+: pack-atlas ( images -- image-placements )
+ dup guess-atlas-dim pack-images ;
+
+: (make-atlas) ( image-placements -- image )
+ dup dup atlas-image-format <atlas-image> [ copy-images-into-atlas ] keep ;
+
+:: image-placement>texcoords ( image-placement atlas-image -- image texcoords )
+ atlas-image dim>> first2 :> ( aw ah )
+ image-placement image>> :> image
+ image-placement loc>> first2 :> ( x y )
+ image dim>> first2 :> ( w h )
+
+ x aw /f :> left-u
+ y ah /f :> top-v
+ x w + aw /f :> right-u
+ y h + ah /f :> bottom-v
+
+ image dup upside-down?>>
+ [ left-u top-v right-u bottom-v ]
+ [ left-u bottom-v right-u top-v ] if 4array ; inline
+
+: make-atlas ( images -- image-texcoords atlas-image )
+ pack-atlas dup (make-atlas) [ '[ _ image-placement>texcoords ] H{ } map>assoc ] keep ;
+
--- /dev/null
+Tool for generating an atlas image from an array of images
IN: mason
: build-loop-error ( error -- )
- [ "Build loop error:" print flush error. flush ]
+ [ "Build loop error:" print flush error. flush :c flush ]
[ error-continuation get call>> email-error ] bi ;
: build-loop-fatal ( error -- )
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types arrays classes.struct combinators
+combinators.short-circuit game.loop game.worlds gpu gpu.buffers
+gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
+gpu.textures gpu.util grouping http.client images images.loader
+io io.encodings.ascii io.files io.files.temp kernel locals math
+math.matrices math.vectors.simd math.parser math.vectors
+method-chains namespaces sequences splitting threads ui ui.gadgets
+ui.gadgets.worlds ui.pixel-formats specialized-arrays
+specialized-vectors literals fry xml
+xml.traversal sequences.deep destructors math.bitwise opengl.gl
+game.models.obj game.models.loader game.models.collada ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-VECTOR: uint
+IN: model-viewer
+
+GLSL-SHADER: model-vertex-shader vertex-shader
+uniform mat4 mv_matrix, p_matrix;
+uniform vec3 light_position;
+
+attribute vec3 POSITION;
+attribute vec3 NORMAL;
+attribute vec2 TEXCOORD;
+
+varying vec2 texit;
+varying vec3 norm;
+
+void main()
+{
+ vec4 position = mv_matrix * vec4(POSITION, 1.0);
+ gl_Position = p_matrix * position;
+ texit = TEXCOORD;
+ norm = NORMAL;
+}
+;
+
+GLSL-SHADER: model-fragment-shader fragment-shader
+varying vec2 texit;
+varying vec3 norm;
+void main()
+{
+ gl_FragColor = vec4(texit, 0, 1) + vec4(norm, 1);
+}
+;
+
+GLSL-PROGRAM: model-program
+ model-vertex-shader model-fragment-shader ;
+
+GLSL-SHADER: debug-vertex-shader vertex-shader
+uniform mat4 mv_matrix, p_matrix;
+uniform vec3 light_position;
+
+attribute vec3 POSITION;
+attribute vec3 COLOR;
+varying vec4 color;
+
+void main()
+{
+ gl_Position = p_matrix * mv_matrix * vec4(POSITION, 1.0);
+ color = vec4(COLOR, 1);
+}
+;
+
+GLSL-SHADER: debug-fragment-shader fragment-shader
+varying vec4 color;
+void main()
+{
+ gl_FragColor = color;
+}
+;
+
+GLSL-PROGRAM: debug-program debug-vertex-shader debug-fragment-shader ;
+
+UNIFORM-TUPLE: model-uniforms < mvp-uniforms
+ { "light-position" vec3-uniform f } ;
+
+TUPLE: model-state
+ models
+ vertex-arrays
+ index-vectors ;
+
+TUPLE: model-world < wasd-world
+ { model-state model-state } ;
+
+VERTEX-FORMAT: model-vertex
+ { "POSITION" float-components 3 f }
+ { "NORMAL" float-components 3 f }
+ { "TEXCOORD" float-components 2 f } ;
+
+VERTEX-FORMAT: debug-vertex
+ { "POSITION" float-components 3 f }
+ { "COLOR" float-components 3 f } ;
+
+TUPLE: vbo vertex-buffer index-buffer index-count vertex-format ;
+
+: <model-buffers> ( models -- buffers )
+ [
+ {
+ [ attribute-buffer>> underlying>> static-upload draw-usage vertex-buffer byte-array>buffer ]
+ [ index-buffer>> underlying>> static-upload draw-usage index-buffer byte-array>buffer ]
+ [ index-buffer>> length ]
+ [ vertex-format>> ]
+ } cleave vbo boa
+ ] map ;
+
+: fill-model-state ( model-state -- )
+ dup models>> <model-buffers>
+ [
+ [
+ [ vertex-buffer>> model-program <program-instance> ]
+ [ vertex-format>> ] bi buffer>vertex-array
+ ] map >>vertex-arrays drop
+ ]
+ [
+ [
+ [ index-buffer>> ] [ index-count>> ] bi
+ '[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
+ ] map >>index-vectors drop
+ ] 2bi ;
+
+: model-files ( -- files )
+ { "C:/Users/erikc/Downloads/test2.dae"
+ "C:/Users/erikc/Downloads/Sponza.obj" } ;
+
+: <model-state> ( -- model-state )
+ model-state new
+ model-files [ load-models ] [ append ] map-reduce >>models ;
+
+M: model-world begin-game-world
+ init-gpu
+ { 0.0 0.0 2.0 } 0 0 set-wasd-view
+ <model-state> [ fill-model-state drop ] [ >>model-state drop ] 2bi ;
+
+: <model-uniforms> ( world -- uniforms )
+ [ wasd-mv-matrix ] [ wasd-p-matrix ] bi
+ { -10000.0 10000.0 10000.0 } ! light position
+ model-uniforms boa ;
+
+: draw-line ( world from to color -- )
+ [ 3 head ] tri@ dup -rot append -rot append swap append >float-array
+ underlying>> stream-upload draw-usage vertex-buffer byte-array>buffer
+ debug-program <program-instance> debug-vertex buffer>vertex-array
+
+ { 0 1 } >uint-array stream-upload draw-usage index-buffer byte-array>buffer
+ 2 '[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
+
+ rot <model-uniforms>
+
+ {
+ { "primitive-mode" [ 3drop lines-mode ] }
+ { "uniforms" [ nip nip ] }
+ { "vertex-array" [ drop drop ] }
+ { "indexes" [ drop nip ] }
+ } 3<render-set> render ;
+
+: draw-lines ( world lines -- )
+ 3 <groups> [ first3 draw-line ] with each ; inline
+
+: draw-axes ( world -- )
+ { { 0 0 0 } { 1 0 0 } { 1 0 0 }
+ { 0 0 0 } { 0 1 0 } { 0 1 0 }
+ { 0 0 0 } { 0 0 1 } { 0 0 1 } } draw-lines ;
+
+: draw-model ( world -- )
+ 0 0 0 0 glClearColor
+ 1 glClearDepth
+ HEX: ffffffff glClearStencil
+ { GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT GL_STENCIL_BUFFER_BIT } flags glClear
+
+ [
+ triangle-fill dup t <triangle-state> set-gpu-state
+ face-ccw cull-back <triangle-cull-state> set-gpu-state
+
+ cmp-less <depth-state> set-gpu-state
+ [ model-state>> vertex-arrays>> ]
+ [ model-state>> index-vectors>> ]
+ [ <model-uniforms> ]
+ tri
+ [
+ {
+ { "primitive-mode" [ 3drop triangles-mode ] }
+ { "uniforms" [ nip nip ] }
+ { "vertex-array" [ drop drop ] }
+ { "indexes" [ drop nip ] }
+ } 3<render-set> render
+ ] curry 2each
+ ]
+ [
+ cmp-always <depth-state> set-gpu-state
+ draw-axes
+ ]
+ bi ;
+
+M: model-world draw-world*
+ draw-model ;
+
+M: model-world wasd-movement-speed drop 1/4. ;
+M: model-world wasd-near-plane drop 1/32. ;
+M: model-world wasd-far-plane drop 1024.0 ;
+
+GAME: model-viewer {
+ { world-class model-world }
+ { title "Model Viewer" }
+ { pixel-format-attributes { windowed double-buffered } }
+ { grab-input? t }
+ { use-game-input? t }
+ { pref-dim { 1024 768 } }
+ { tick-interval-micros $[ 60 fps ] }
+ } ;
"MEMO" "MEMO:" "METHOD"
"SYNTAX"
"PREDICATE" "PRIMITIVE"
+ "STRUCT" "TAG" "TUPLE" "UNION-STRUCT"
"UNION"))
(defconst fuel-syntax--no-indent-def-starts '("ARTICLE"
"HELP"
"SINGLETONS"
"SYMBOLS"
- "TUPLE"
"VARS"))
(defconst fuel-syntax--indent-def-start-regex
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.syntax help.markup threads ;\r
-\r
-IN: odbc\r
-\r
-HELP: odbc-init \r
-{ $values { "env" "an ODBC environment handle" } } \r
-{ $description \r
- "Initializes the ODBC driver manager and returns the " \r
- "environment handle required by " { $link odbc-connect } "."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-connect \r
-{ $values { "env" "an ODBC environment handle" } { "dsn" "a string" } { "dbc" "an ODBC database connection handle" } } \r
-{ $description \r
- "Connects to the database identified by the ODBC data source name (DSN). " \r
- "The environment handle is usually obtained by a call to " { $link odbc-init } ". The result is the ODBC connection handle which can be used in other ODBC calls. When finished with the connection handle " { $link odbc-disconnect } " must be called on it."\r
-} \r
-{ $examples { $code "dbc get \"DSN=mydsn\" odbc-connect" } }\r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-disconnect \r
-{ $values { "dbc" "an ODBC database connection handle" } } \r
-{ $description \r
- "Disconnects from the given database." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-prepare\r
-{ $values { "dbc" "an ODBC database connection handle" } { "string" "a string containing SQL" } { "statement" "an ODBC statement handle" } } \r
-{ $description \r
- "Prepares (precompiles) the given SQL string, ready for execution with " { $link odbc-execute } ". When finished with the statement " { $link odbc-free-statement } " must be called on it." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-free-statement\r
-{ $values { "statement" "an ODBC statement handle" } } \r
-{ $description \r
- "Closes the statement handle and frees up all resources associated with it." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-execute\r
-{ $values { "statement" "an ODBC statement handle" } } \r
-{ $description \r
- "Executes the statement. Once this is done " { $link odbc-next-row } " can be called to retrieve rows." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-next-row\r
-{ $values { "statement" "an ODBC statement handle" } { "bool" "a boolean indicating success or failure" } } \r
-{ $description \r
- "Retrieves the next available row from the database. If no next row is available then " { $link f } " is returned. Once the row is retrieved " { $link odbc-number-of-columns } ", " { $link odbc-describe-column } ", " { $link odbc-get-field } " and " { $link odbc-get-row-fields } " can be used to query the data retrieved." \r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-number-of-columns\r
-{ $values { "statement" "an ODBC statement handle" } { "number" "a number" } } \r
-{ $description \r
- "Returns the number of columns of data retrieved."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-describe-column\r
-{ $values { "statement" "an ODBC statement handle" } { "n" "a column number starting from one" } { "column" "a column object" } } \r
-{ $description \r
- "Retrieves column information for the given column number from the statement. The column number must be one or greater. The " { $link <column> } " object returned provides data type, name, etc."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-get-field\r
-{ $values { "statement" "an ODBC statement handle" } { "column" "a column number starting from one or a <column> object" } { "field" "a <field> object" } } \r
-{ $description \r
- "Returns a field object which contains the data for the field in the given column in the current row. The column can be identified by a number or a <column> object. The datatype of the contents of the field depends on the type of the column itself. Note that this word can only be safely called once on each column in a given row with most ODBC drivers. Subsequent calls on the same row for the same column can fail."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-get-row-fields\r
-{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } } \r
-{ $description \r
- "Returns a sequence of all field data for the current row. Note that this isnot the <field> objects, but the data for that field. This word can only be called once on a given row. Subsequent calls on the same row may fail on some ODBC drivers."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-get-all-rows\r
-{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } } \r
-{ $description \r
- "Returns a sequence of all rows available from the statement. Effectively it is the contents of the entire query so may take some time and memory. Each element of the sequence is itself a sequence containing the data for that row. A " { $link yield } " is performed an various intervals so as to not lock up the Factor instance while it is running."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
-\r
-HELP: odbc-query\r
-{ $values { "string" "a string containing SQL" } { "dsn" "a DSN string" } { "result" "a sequence" } } \r
-{ $description \r
- "This word initializes odbc, connects to the database with the given DSN, executes the query string and returns the result as a sequence. It cleans up all resources it uses. It is an inefficient way of running multiple queries but is useful for the occasional query, testing at the REPL, or as an example of how to do it."\r
-} \r
-{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup threads ;
+
+IN: odbc
+
+HELP: odbc-init
+{ $values { "env" "an ODBC environment handle" } }
+{ $description
+ "Initializes the ODBC driver manager and returns the "
+ "environment handle required by " { $link odbc-connect } "."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-connect
+{ $values { "env" "an ODBC environment handle" } { "dsn" "a string" } { "dbc" "an ODBC database connection handle" } }
+{ $description
+ "Connects to the database identified by the ODBC data source name (DSN). "
+ "The environment handle is usually obtained by a call to " { $link odbc-init } ". The result is the ODBC connection handle which can be used in other ODBC calls. When finished with the connection handle " { $link odbc-disconnect } " must be called on it."
+}
+{ $examples { $code "dbc get \"DSN=mydsn\" odbc-connect" } }
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-disconnect
+{ $values { "dbc" "an ODBC database connection handle" } }
+{ $description
+ "Disconnects from the given database."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-prepare
+{ $values { "dbc" "an ODBC database connection handle" } { "string" "a string containing SQL" } { "statement" "an ODBC statement handle" } }
+{ $description
+ "Prepares (precompiles) the given SQL string, ready for execution with " { $link odbc-execute } ". When finished with the statement " { $link odbc-free-statement } " must be called on it."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-free-statement
+{ $values { "statement" "an ODBC statement handle" } }
+{ $description
+ "Closes the statement handle and frees up all resources associated with it."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-execute
+{ $values { "statement" "an ODBC statement handle" } }
+{ $description
+ "Executes the statement. Once this is done " { $link odbc-next-row } " can be called to retrieve rows."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-next-row
+{ $values { "statement" "an ODBC statement handle" } { "bool" "a boolean indicating success or failure" } }
+{ $description
+ "Retrieves the next available row from the database. If no next row is available then " { $link f } " is returned. Once the row is retrieved " { $link odbc-number-of-columns } ", " { $link odbc-describe-column } ", " { $link odbc-get-field } " and " { $link odbc-get-row-fields } " can be used to query the data retrieved."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-number-of-columns
+{ $values { "statement" "an ODBC statement handle" } { "number" "a number" } }
+{ $description
+ "Returns the number of columns of data retrieved."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-describe-column
+{ $values { "statement" "an ODBC statement handle" } { "n" "a column number starting from one" } { "column" "a column object" } }
+{ $description
+ "Retrieves column information for the given column number from the statement. The column number must be one or greater. The " { $link <column> } " object returned provides data type, name, etc."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-get-field
+{ $values { "statement" "an ODBC statement handle" } { "column" "a column number starting from one or a <column> object" } { "field" "a <field> object" } }
+{ $description
+ "Returns a field object which contains the data for the field in the given column in the current row. The column can be identified by a number or a <column> object. The datatype of the contents of the field depends on the type of the column itself. Note that this word can only be safely called once on each column in a given row with most ODBC drivers. Subsequent calls on the same row for the same column can fail."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-get-row-fields
+{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } }
+{ $description
+ "Returns a sequence of all field data for the current row. Note that this isnot the <field> objects, but the data for that field. This word can only be called once on a given row. Subsequent calls on the same row may fail on some ODBC drivers."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-get-all-rows
+{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } }
+{ $description
+ "Returns a sequence of all rows available from the statement. Effectively it is the contents of the entire query so may take some time and memory. Each element of the sequence is itself a sequence containing the data for that row. A " { $link yield } " is performed an various intervals so as to not lock up the Factor instance while it is running."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
+
+HELP: odbc-query
+{ $values { "string" "a string containing SQL" } { "dsn" "a DSN string" } { "result" "a sequence" } }
+{ $description
+ "This word initializes odbc, connects to the database with the given DSN, executes the query string and returns the result as a sequence. It cleans up all resources it uses. It is an inefficient way of running multiple queries but is useful for the occasional query, testing at the REPL, or as an example of how to do it."
+}
+{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
-! Copyright (C) 2007 Chris Double.\r
-! See http://factorcode.org/license.txt for BSD license.\r
-!\r
-! TODO:\r
-! based on number of channels in file.\r
-! - End of decoding is indicated by an exception when reading the stream.\r
-! How to work around this? C player example uses feof but streams don't\r
-! have that in Factor.\r
-! - Work out openal buffer method that plays nicely with streaming over\r
-! slow connections.\r
-! - Have start/stop/seek methods on the player object.\r
-!\r
-USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays\r
- sequences libc shuffle alien.c-types system openal math\r
- namespaces threads shuffle opengl arrays ui.gadgets.worlds\r
- combinators math.parser ui.gadgets ui.render opengl.gl ui\r
- continuations io.files hints combinators.lib sequences.lib\r
- io.encodings.binary debugger math.order accessors ;\r
-\r
-IN: ogg.player\r
-\r
-: audio-buffer-size ( -- number ) 128 1024 * ; inline\r
-\r
-TUPLE: player stream temp-state\r
- op oy og\r
- vo vi vd vb vc vorbis\r
- to ti tc td yuv rgb theora video-ready? video-time video-granulepos\r
- source buffers buffer-indexes start-time\r
- playing? audio-full? audio-index audio-buffer audio-granulepos\r
- gadget ;\r
-\r
-: init-vorbis ( player -- )\r
- dup oy>> ogg_sync_init drop\r
- dup vi>> vorbis_info_init\r
- vc>> vorbis_comment_init ;\r
-\r
-: init-theora ( player -- )\r
- dup ti>> theora_info_init\r
- tc>> theora_comment_init ;\r
-\r
-: init-sound ( player -- )\r
- init-openal check-error\r
- 1 gen-buffers check-error >>buffers\r
- 2 "uint" <c-array> >>buffer-indexes\r
- 1 gen-sources check-error first >>source drop ;\r
-\r
-: <player> ( stream -- player )\r
- player new\r
- swap >>stream\r
- 0 >>vorbis\r
- 0 >>theora\r
- 0 >>video-time\r
- 0 >>video-granulepos\r
- f >>video-ready?\r
- f >>audio-full?\r
- 0 >>audio-index\r
- 0 >>start-time\r
- audio-buffer-size "short" <c-array> >>audio-buffer\r
- 0 >>audio-granulepos\r
- f >>playing?\r
- "ogg_packet" malloc-object >>op\r
- "ogg_sync_state" malloc-object >>oy\r
- "ogg_page" malloc-object >>og\r
- "ogg_stream_state" malloc-object >>vo\r
- "vorbis_info" malloc-object >>vi\r
- "vorbis_dsp_state" malloc-object >>vd\r
- "vorbis_block" malloc-object >>vb\r
- "vorbis_comment" malloc-object >>vc\r
- "ogg_stream_state" malloc-object >>to\r
- "theora_info" malloc-object >>ti\r
- "theora_comment" malloc-object >>tc\r
- "theora_state" malloc-object >>td\r
- "yuv_buffer" <c-object> >>yuv\r
- "ogg_stream_state" <c-object> >>temp-state\r
- dup init-sound\r
- dup init-vorbis\r
- dup init-theora ;\r
-\r
-: num-channels ( player -- channels )\r
- vi>> vorbis_info-channels ;\r
-\r
-: al-channel-format ( player -- format )\r
- num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;\r
-\r
-: get-time ( player -- time )\r
- dup start-time>> zero? [\r
- millis >>start-time\r
- ] when\r
- start-time>> millis swap - 1000.0 /f ;\r
-\r
-: clamp ( n -- n )\r
- 255 min 0 max ; inline\r
-\r
-: stride ( line yuv -- uvy yy )\r
- [ yuv_buffer-uv_stride >fixnum swap 2/ * ] 2keep\r
- yuv_buffer-y_stride >fixnum * >fixnum ; inline\r
-\r
-: each-with4 ( obj obj obj obj seq quot -- )\r
- 4 each-withn ; inline\r
-\r
-: compute-y ( yuv uvy yy x -- y )\r
- + >fixnum nip swap yuv_buffer-y uchar-nth 16 - ; inline\r
-\r
-: compute-v ( yuv uvy yy x -- v )\r
- nip 2/ + >fixnum swap yuv_buffer-u uchar-nth 128 - ; inline\r
-\r
-: compute-u ( yuv uvy yy x -- v )\r
- nip 2/ + >fixnum swap yuv_buffer-v uchar-nth 128 - ; inline\r
-\r
-: compute-yuv ( yuv uvy yy x -- y u v )\r
- [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline\r
-\r
-: compute-blue ( y u v -- b )\r
- drop 516 * 128 + swap 298 * + -8 shift clamp ; inline\r
-\r
-: compute-green ( y u v -- g )\r
- >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ;\r
- inline\r
-\r
-: compute-red ( y u v -- g )\r
- nip 409 * swap 298 * + 128 + -8 shift clamp ; inline\r
-\r
-: compute-rgb ( y u v -- b g r )\r
- [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ;\r
- inline\r
-\r
-: store-rgb ( index rgb b g r -- index )\r
- >r\r
- >r pick 0 + >fixnum pick set-uchar-nth\r
- r> pick 1 + >fixnum pick set-uchar-nth\r
- r> pick 2 + >fixnum pick set-uchar-nth\r
- drop ; inline\r
-\r
-: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )\r
- compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline\r
-\r
-: yuv>rgb-row ( index rgb yuv y -- index )\r
- over stride\r
- pick yuv_buffer-y_width >fixnum\r
- [ yuv>rgb-pixel ] each-with4 ; inline\r
-\r
-: yuv>rgb ( rgb yuv -- )\r
- 0 -rot\r
- dup yuv_buffer-y_height >fixnum\r
- [ yuv>rgb-row ] each-with2\r
- drop ;\r
-\r
-HINTS: yuv>rgb byte-array byte-array ;\r
-\r
-: process-video ( player -- player )\r
- dup gadget>> [\r
- {\r
- [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]\r
- [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]\r
- [ gadget>> relayout-1 yield ]\r
- [ ]\r
- } cleave\r
- ] when ;\r
-\r
-: num-audio-buffers-processed ( player -- player n )\r
- dup source>> AL_BUFFERS_PROCESSED 0 <uint>\r
- [ alGetSourcei check-error ] keep *uint ;\r
-\r
-: append-new-audio-buffer ( player -- player )\r
- dup buffers>> 1 gen-buffers append >>buffers\r
- [ [ buffers>> second ] keep al-channel-format ] keep\r
- [ audio-buffer>> dup length ] keep\r
- [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
- [ source>> 1 ] keep\r
- [ buffers>> second <uint> alSourceQueueBuffers check-error ] keep ;\r
-\r
-: fill-processed-audio-buffer ( player n -- player )\r
- #! n is the number of audio buffers processed\r
- over >r >r dup source>> r> pick buffer-indexes>>\r
- [ alSourceUnqueueBuffers check-error ] keep\r
- *uint dup r> swap >r al-channel-format rot\r
- [ audio-buffer>> dup length ] keep\r
- [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
- [ source>> 1 ] keep\r
- r> <uint> swap >r alSourceQueueBuffers check-error r> ;\r
-\r
-: append-audio ( player -- player bool )\r
- num-audio-buffers-processed {\r
- { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }\r
- { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] }\r
- [ fill-processed-audio-buffer t ]\r
- } cond ;\r
-\r
-: start-audio ( player -- player bool )\r
- [ [ buffers>> first ] keep al-channel-format ] keep\r
- [ audio-buffer>> dup length ] keep\r
- [ vi>> vorbis_info-rate alBufferData check-error ] keep\r
- [ source>> 1 ] keep\r
- [ buffers>> first <uint> alSourceQueueBuffers check-error ] keep\r
- [ source>> alSourcePlay check-error ] keep\r
- t >>playing? t ;\r
-\r
-: process-audio ( player -- player bool )\r
- dup playing?>> [ append-audio ] [ start-audio ] if ;\r
-\r
-: read-bytes-into ( dest size stream -- len )\r
- #! Read the given number of bytes from a stream\r
- #! and store them in the destination byte array.\r
- stream-read >byte-array dup length [ memcpy ] keep ;\r
-\r
-: check-not-negative ( int -- )\r
- 0 < [ "Word result was a negative number." throw ] when ;\r
-\r
-: buffer-size ( -- number )\r
- 4096 ; inline\r
-\r
-: sync-buffer ( player -- buffer size player )\r
- [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;\r
-\r
-: stream-into-buffer ( buffer size player -- len player )\r
- [ stream>> read-bytes-into ] keep ;\r
-\r
-: confirm-buffer ( len player -- player eof? )\r
- [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;\r
-\r
-: buffer-data ( player -- player eof? )\r
- #! Take some compressed bitstream data and sync it for\r
- #! page extraction.\r
- sync-buffer stream-into-buffer confirm-buffer ;\r
-\r
-: queue-page ( player -- player )\r
- #! Push a page into the stream for packetization\r
- [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]\r
- [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]\r
- [ ] tri ;\r
-\r
-: retrieve-page ( player -- player bool )\r
- #! Sync the streams and get a page. Return true if a page was\r
- #! successfully retrieved.\r
- dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;\r
-\r
-: standard-initial-header? ( player -- player bool )\r
- dup og>> ogg_page_bos zero? not ;\r
-\r
-: ogg-stream-init ( player -- state player )\r
- #! Init the encode/decode logical stream state\r
- [ temp-state>> ] keep\r
- [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;\r
-\r
-: ogg-stream-pagein ( state player -- state player )\r
- #! Add the incoming page to the stream state\r
- [ og>> ogg_stream_pagein drop ] 2keep ;\r
-\r
-: ogg-stream-packetout ( state player -- state player )\r
- [ op>> ogg_stream_packetout drop ] 2keep ;\r
-\r
-: decode-packet ( player -- state player )\r
- ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;\r
-\r
-: theora-header? ( player -- player bool )\r
- #! Is the current page a theora header?\r
- dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;\r
-\r
-: is-theora-packet? ( player -- player bool )\r
- dup theora>> zero? [ theora-header? ] [ f ] if ;\r
-\r
-: copy-to-theora-state ( state player -- player )\r
- #! Copy the state to the theora state structure in the player\r
- [ to>> swap dup length memcpy ] keep ;\r
-\r
-: handle-initial-theora-header ( state player -- player )\r
- copy-to-theora-state 1 >>theora ;\r
-\r
-: vorbis-header? ( player -- player bool )\r
- #! Is the current page a vorbis header?\r
- dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;\r
-\r
-: is-vorbis-packet? ( player -- player bool )\r
- dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;\r
-\r
-: copy-to-vorbis-state ( state player -- player )\r
- #! Copy the state to the vorbis state structure in the player\r
- [ vo>> swap dup length memcpy ] keep ;\r
-\r
-: handle-initial-vorbis-header ( state player -- player )\r
- copy-to-vorbis-state 1 >>vorbis ;\r
-\r
-: handle-initial-unknown-header ( state player -- player )\r
- swap ogg_stream_clear drop ;\r
-\r
-: process-initial-header ( player -- player bool )\r
- #! Is this a standard initial header? If not, stop parsing\r
- standard-initial-header? [\r
- decode-packet {\r
- { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }\r
- { [ is-theora-packet? ] [ handle-initial-theora-header ] }\r
- [ handle-initial-unknown-header ]\r
- } cond t\r
- ] [\r
- f\r
- ] if ;\r
-\r
-: parse-initial-headers ( player -- player )\r
- #! Parse Vorbis headers, ignoring any other type stored\r
- #! in the Ogg container.\r
- retrieve-page [\r
- process-initial-header [\r
- parse-initial-headers\r
- ] [\r
- #! Don't leak the page, get it into the appropriate stream\r
- queue-page\r
- ] if\r
- ] [\r
- buffer-data not [ parse-initial-headers ] when\r
- ] if ;\r
-\r
-: have-required-vorbis-headers? ( player -- player bool )\r
- #! Return true if we need to decode vorbis due to there being\r
- #! vorbis headers read from the stream but we don't have them all\r
- #! yet.\r
- dup vorbis>> 1 2 between? not ;\r
-\r
-: have-required-theora-headers? ( player -- player bool )\r
- #! Return true if we need to decode theora due to there being\r
- #! theora headers read from the stream but we don't have them all\r
- #! yet.\r
- dup theora>> 1 2 between? not ;\r
-\r
-: get-remaining-vorbis-header-packet ( player -- player bool )\r
- dup [ vo>> ] [ op>> ] bi ogg_stream_packetout {\r
- { [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }\r
- { [ dup zero? ] [ drop f ] }\r
- { [ t ] [ drop t ] }\r
- } cond ;\r
-\r
-: get-remaining-theora-header-packet ( player -- player bool )\r
- dup [ to>> ] [ op>> ] bi ogg_stream_packetout {\r
- { [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] }\r
- { [ dup zero? ] [ drop f ] }\r
- { [ t ] [ drop t ] }\r
- } cond ;\r
-\r
-: decode-remaining-vorbis-header-packet ( player -- player )\r
- dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [\r
- "Error parsing vorbis stream; corrupt stream?" throw\r
- ] unless ;\r
-\r
-: decode-remaining-theora-header-packet ( player -- player )\r
- dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [\r
- "Error parsing theora stream; corrupt stream?" throw\r
- ] unless ;\r
-\r
-: increment-vorbis-header-count ( player -- player )\r
- [ 1+ ] change-vorbis ;\r
-\r
-: increment-theora-header-count ( player -- player )\r
- [ 1+ ] change-theora ;\r
-\r
-: parse-remaining-vorbis-headers ( player -- player )\r
- have-required-vorbis-headers? not [\r
- get-remaining-vorbis-header-packet [\r
- decode-remaining-vorbis-header-packet\r
- increment-vorbis-header-count\r
- parse-remaining-vorbis-headers\r
- ] when\r
- ] when ;\r
-\r
-: parse-remaining-theora-headers ( player -- player )\r
- have-required-theora-headers? not [\r
- get-remaining-theora-header-packet [\r
- decode-remaining-theora-header-packet\r
- increment-theora-header-count\r
- parse-remaining-theora-headers\r
- ] when\r
- ] when ;\r
-\r
-: get-more-header-data ( player -- player )\r
- buffer-data drop ;\r
-\r
-: parse-remaining-headers ( player -- player )\r
- have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [\r
- parse-remaining-vorbis-headers\r
- parse-remaining-theora-headers\r
- retrieve-page [ queue-page ] [ get-more-header-data ] if\r
- parse-remaining-headers\r
- ] when ;\r
-\r
-: tear-down-vorbis ( player -- player )\r
- dup vi>> vorbis_info_clear\r
- dup vc>> vorbis_comment_clear ;\r
-\r
-: tear-down-theora ( player -- player )\r
- dup ti>> theora_info_clear\r
- dup tc>> theora_comment_clear ;\r
-\r
-: init-vorbis-codec ( player -- player )\r
- dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop\r
- dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;\r
-\r
-: init-theora-codec ( player -- player )\r
- dup [ td>> ] [ ti>> ] bi theora_decode_init drop\r
- dup ti>> theora_info-frame_width over ti>> theora_info-frame_height\r
- 4 * * <byte-array> >>rgb ;\r
-\r
-\r
-: display-vorbis-details ( player -- player )\r
- [\r
- "Ogg logical stream " %\r
- dup vo>> ogg_stream_state-serialno #\r
- " is Vorbis " %\r
- dup vi>> vorbis_info-channels #\r
- " channel " %\r
- dup vi>> vorbis_info-rate #\r
- " Hz audio." %\r
- ] "" make print ;\r
-\r
-: display-theora-details ( player -- player )\r
- [\r
- "Ogg logical stream " %\r
- dup to>> ogg_stream_state-serialno #\r
- " is Theora " %\r
- dup ti>> theora_info-width #\r
- "x" %\r
- dup ti>> theora_info-height #\r
- " " %\r
- dup ti>> theora_info-fps_numerator\r
- over ti>> theora_info-fps_denominator /f #\r
- " fps video" %\r
- ] "" make print ;\r
-\r
-: initialize-decoder ( player -- player )\r
- dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if\r
- dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;\r
-\r
-: sync-pages ( player -- player )\r
- retrieve-page [\r
- queue-page sync-pages\r
- ] when ;\r
-\r
-: audio-buffer-not-ready? ( player -- player bool )\r
- dup vorbis>> zero? not over audio-full?>> not and ;\r
-\r
-: pending-decoded-audio? ( player -- player pcm len bool )\r
- f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;\r
-\r
-: buffer-space-available ( player -- available )\r
- audio-buffer-size swap audio-index>> - ;\r
-\r
-: samples-to-read ( player available len -- numread )\r
- >r swap num-channels / r> min ;\r
-\r
-: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline\r
-\r
-: add-to-buffer ( player val -- )\r
- over audio-index>> pick audio-buffer>> set-short-nth\r
- [ 1+ ] change-audio-index drop ;\r
-\r
-: get-audio-value ( pcm sample channel -- value )\r
- rot *void* void*-nth float-nth ;\r
-\r
-: process-channels ( player pcm sample channel -- )\r
- get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ;\r
-\r
-: (process-sample) ( player pcm sample -- )\r
- pick num-channels [ process-channels ] each-with3 ;\r
-\r
-: process-samples ( player pcm numread -- )\r
- [ (process-sample) ] each-with2 ;\r
-\r
-: decode-pending-audio ( player pcm result -- player )\r
-! [ "ret = " % dup # ] "" make write\r
- pick [ buffer-space-available swap ] keep -rot samples-to-read\r
- pick over >r >r process-samples r> r> swap\r
- ! numread player\r
- dup audio-index>> audio-buffer-size = [\r
- t >>audio-full?\r
- ] when\r
- dup vd>> vorbis_dsp_state-granulepos dup 0 >= [\r
- ! numtoread player granulepos\r
- #! This is wrong: fix\r
- pick - >>audio-granulepos\r
- ] [\r
- ! numtoread player granulepos\r
- pick + >>audio-granulepos\r
- ] if\r
- [ vd>> swap vorbis_synthesis_read drop ] keep ;\r
-\r
-: no-pending-audio ( player -- player bool )\r
- #! No pending audio. Is there a pending packet to decode.\r
- dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [\r
- dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [\r
- dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop\r
- ] when\r
- t\r
- ] [\r
- #! Need more data. Break out to suck in another page.\r
- f\r
- ] if ;\r
-\r
-: decode-audio ( player -- player )\r
- audio-buffer-not-ready? [\r
- #! If there's pending decoded audio, grab it\r
- pending-decoded-audio? [\r
- decode-pending-audio decode-audio\r
- ] [\r
- 2drop no-pending-audio [ decode-audio ] when\r
- ] if\r
- ] when ;\r
-\r
-: video-buffer-not-ready? ( player -- player bool )\r
- dup theora>> zero? not over video-ready?>> not and ;\r
-\r
-: decode-video ( player -- player )\r
- video-buffer-not-ready? [\r
- dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [\r
- dup [ td>> ] [ op>> ] bi theora_decode_packetin drop\r
- dup td>> theora_state-granulepos >>video-granulepos\r
- dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time\r
- >>video-time\r
- t >>video-ready?\r
- decode-video\r
- ] when\r
- ] when ;\r
-\r
-: decode ( player -- player )\r
- get-more-header-data sync-pages\r
- decode-audio\r
- decode-video\r
- dup audio-full?>> [\r
- process-audio [\r
- f >>audio-full?\r
- 0 >>audio-index\r
- ] when\r
- ] when\r
- dup video-ready?>> [\r
- dup video-time>> over get-time - dup 0.0 < [\r
- -0.1 > [ process-video ] when\r
- f >>video-ready?\r
- ] [\r
- drop\r
- ] if\r
- ] when\r
- decode ;\r
-\r
-: free-malloced-objects ( player -- player )\r
- {\r
- [ op>> free ]\r
- [ oy>> free ]\r
- [ og>> free ]\r
- [ vo>> free ]\r
- [ vi>> free ]\r
- [ vd>> free ]\r
- [ vb>> free ]\r
- [ vc>> free ]\r
- [ to>> free ]\r
- [ ti>> free ]\r
- [ tc>> free ]\r
- [ td>> free ]\r
- [ ]\r
- } cleave ;\r
-\r
-\r
-: unqueue-openal-buffers ( player -- player )\r
- [\r
-\r
- num-audio-buffers-processed over source>> rot buffer-indexes>> swapd\r
- alSourceUnqueueBuffers check-error\r
- ] keep ;\r
-\r
-: delete-openal-buffers ( player -- player )\r
- [\r
- buffers>> [\r
- 1 swap <uint> alDeleteBuffers check-error\r
- ] each\r
- ] keep ;\r
-\r
-: delete-openal-source ( player -- player )\r
- [ source>> 1 swap <uint> alDeleteSources check-error ] keep ;\r
-\r
-: cleanup ( player -- player )\r
- free-malloced-objects\r
- unqueue-openal-buffers\r
- delete-openal-buffers\r
- delete-openal-source ;\r
-\r
-: wait-for-sound ( player -- player )\r
- #! Waits for the openal to finish playing remaining sounds\r
- dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep\r
- *int AL_PLAYING = [\r
- 100 sleep\r
- wait-for-sound\r
- ] when ;\r
-\r
-TUPLE: theora-gadget < gadget player ;\r
-\r
-: <theora-gadget> ( player -- gadget )\r
- theora-gadget new-gadget\r
- swap >>player ;\r
-\r
-M: theora-gadget pref-dim*\r
- player>>\r
- ti>> dup theora_info-width swap theora_info-height 2array ;\r
-\r
-M: theora-gadget draw-gadget* ( gadget -- )\r
- 0 0 glRasterPos2i\r
- 1.0 -1.0 glPixelZoom\r
- GL_UNPACK_ALIGNMENT 1 glPixelStorei\r
- [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep\r
- player>> rgb>> glDrawPixels ;\r
-\r
-: initialize-gui ( gadget -- )\r
- "Theora Player" open-window ;\r
-\r
-: play-ogg ( player -- )\r
- parse-initial-headers\r
- parse-remaining-headers\r
- initialize-decoder\r
- dup gadget>> [ initialize-gui ] when*\r
- [ decode ] try\r
- wait-for-sound\r
- cleanup\r
- drop ;\r
-\r
-: play-vorbis-stream ( stream -- )\r
- <player> play-ogg ;\r
-\r
-: play-vorbis-file ( filename -- )\r
- binary <file-reader> play-vorbis-stream ;\r
-\r
-: play-theora-stream ( stream -- )\r
- <player>\r
- dup <theora-gadget> >>gadget\r
- play-ogg ;\r
-\r
-: play-theora-file ( filename -- )\r
- binary <file-reader> play-theora-stream ;\r
+! Copyright (C) 2007 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! TODO:
+! based on number of channels in file.
+! - End of decoding is indicated by an exception when reading the stream.
+! How to work around this? C player example uses feof but streams don't
+! have that in Factor.
+! - Work out openal buffer method that plays nicely with streaming over
+! slow connections.
+! - Have start/stop/seek methods on the player object.
+!
+USING: kernel alien ogg ogg.vorbis ogg.theora io byte-arrays
+ sequences libc shuffle alien.c-types system openal math
+ namespaces threads shuffle opengl arrays ui.gadgets.worlds
+ combinators math.parser ui.gadgets ui.render opengl.gl ui
+ continuations io.files hints combinators.lib sequences.lib
+ io.encodings.binary debugger math.order accessors ;
+
+IN: ogg.player
+
+: audio-buffer-size ( -- number ) 128 1024 * ; inline
+
+TUPLE: player stream temp-state
+ op oy og
+ vo vi vd vb vc vorbis
+ to ti tc td yuv rgb theora video-ready? video-time video-granulepos
+ source buffers buffer-indexes start-time
+ playing? audio-full? audio-index audio-buffer audio-granulepos
+ gadget ;
+
+: init-vorbis ( player -- )
+ dup oy>> ogg_sync_init drop
+ dup vi>> vorbis_info_init
+ vc>> vorbis_comment_init ;
+
+: init-theora ( player -- )
+ dup ti>> theora_info_init
+ tc>> theora_comment_init ;
+
+: init-sound ( player -- )
+ init-openal check-error
+ 1 gen-buffers check-error >>buffers
+ 2 "uint" <c-array> >>buffer-indexes
+ 1 gen-sources check-error first >>source drop ;
+
+: <player> ( stream -- player )
+ player new
+ swap >>stream
+ 0 >>vorbis
+ 0 >>theora
+ 0 >>video-time
+ 0 >>video-granulepos
+ f >>video-ready?
+ f >>audio-full?
+ 0 >>audio-index
+ 0 >>start-time
+ audio-buffer-size "short" <c-array> >>audio-buffer
+ 0 >>audio-granulepos
+ f >>playing?
+ "ogg_packet" malloc-object >>op
+ "ogg_sync_state" malloc-object >>oy
+ "ogg_page" malloc-object >>og
+ "ogg_stream_state" malloc-object >>vo
+ "vorbis_info" malloc-object >>vi
+ "vorbis_dsp_state" malloc-object >>vd
+ "vorbis_block" malloc-object >>vb
+ "vorbis_comment" malloc-object >>vc
+ "ogg_stream_state" malloc-object >>to
+ "theora_info" malloc-object >>ti
+ "theora_comment" malloc-object >>tc
+ "theora_state" malloc-object >>td
+ "yuv_buffer" <c-object> >>yuv
+ "ogg_stream_state" <c-object> >>temp-state
+ dup init-sound
+ dup init-vorbis
+ dup init-theora ;
+
+: num-channels ( player -- channels )
+ vi>> vorbis_info-channels ;
+
+: al-channel-format ( player -- format )
+ num-channels 1 = AL_FORMAT_MONO16 AL_FORMAT_STEREO16 ? ;
+
+: get-time ( player -- time )
+ dup start-time>> zero? [
+ millis >>start-time
+ ] when
+ start-time>> millis swap - 1000.0 /f ;
+
+: clamp ( n -- n )
+ 255 min 0 max ; inline
+
+: stride ( line yuv -- uvy yy )
+ [ yuv_buffer-uv_stride >fixnum swap 2/ * ] 2keep
+ yuv_buffer-y_stride >fixnum * >fixnum ; inline
+
+: each-with4 ( obj obj obj obj seq quot -- )
+ 4 each-withn ; inline
+
+: compute-y ( yuv uvy yy x -- y )
+ + >fixnum nip swap yuv_buffer-y uchar-nth 16 - ; inline
+
+: compute-v ( yuv uvy yy x -- v )
+ nip 2/ + >fixnum swap yuv_buffer-u uchar-nth 128 - ; inline
+
+: compute-u ( yuv uvy yy x -- v )
+ nip 2/ + >fixnum swap yuv_buffer-v uchar-nth 128 - ; inline
+
+: compute-yuv ( yuv uvy yy x -- y u v )
+ [ compute-y ] 4keep [ compute-u ] 4keep compute-v ; inline
+
+: compute-blue ( y u v -- b )
+ drop 516 * 128 + swap 298 * + -8 shift clamp ; inline
+
+: compute-green ( y u v -- g )
+ >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift clamp ;
+ inline
+
+: compute-red ( y u v -- g )
+ nip 409 * swap 298 * + 128 + -8 shift clamp ; inline
+
+: compute-rgb ( y u v -- b g r )
+ [ compute-blue ] 3keep [ compute-green ] 3keep compute-red ;
+ inline
+
+: store-rgb ( index rgb b g r -- index )
+ >r
+ >r pick 0 + >fixnum pick set-uchar-nth
+ r> pick 1 + >fixnum pick set-uchar-nth
+ r> pick 2 + >fixnum pick set-uchar-nth
+ drop ; inline
+
+: yuv>rgb-pixel ( index rgb yuv uvy yy x -- index )
+ compute-yuv compute-rgb store-rgb 3 + >fixnum ; inline
+
+: yuv>rgb-row ( index rgb yuv y -- index )
+ over stride
+ pick yuv_buffer-y_width >fixnum
+ [ yuv>rgb-pixel ] each-with4 ; inline
+
+: yuv>rgb ( rgb yuv -- )
+ 0 -rot
+ dup yuv_buffer-y_height >fixnum
+ [ yuv>rgb-row ] each-with2
+ drop ;
+
+HINTS: yuv>rgb byte-array byte-array ;
+
+: process-video ( player -- player )
+ dup gadget>> [
+ {
+ [ [ td>> ] [ yuv>> ] bi theora_decode_YUVout drop ]
+ [ [ rgb>> ] [ yuv>> ] bi yuv>rgb ]
+ [ gadget>> relayout-1 yield ]
+ [ ]
+ } cleave
+ ] when ;
+
+: num-audio-buffers-processed ( player -- player n )
+ dup source>> AL_BUFFERS_PROCESSED 0 <uint>
+ [ alGetSourcei check-error ] keep *uint ;
+
+: append-new-audio-buffer ( player -- player )
+ dup buffers>> 1 gen-buffers append >>buffers
+ [ [ buffers>> second ] keep al-channel-format ] keep
+ [ audio-buffer>> dup length ] keep
+ [ vi>> vorbis_info-rate alBufferData check-error ] keep
+ [ source>> 1 ] keep
+ [ buffers>> second <uint> alSourceQueueBuffers check-error ] keep ;
+
+: fill-processed-audio-buffer ( player n -- player )
+ #! n is the number of audio buffers processed
+ over >r >r dup source>> r> pick buffer-indexes>>
+ [ alSourceUnqueueBuffers check-error ] keep
+ *uint dup r> swap >r al-channel-format rot
+ [ audio-buffer>> dup length ] keep
+ [ vi>> vorbis_info-rate alBufferData check-error ] keep
+ [ source>> 1 ] keep
+ r> <uint> swap >r alSourceQueueBuffers check-error r> ;
+
+: append-audio ( player -- player bool )
+ num-audio-buffers-processed {
+ { [ over buffers>> length 1 = over zero? and ] [ drop append-new-audio-buffer t ] }
+ { [ over buffers>> length 2 = over zero? and ] [ yield drop f ] }
+ [ fill-processed-audio-buffer t ]
+ } cond ;
+
+: start-audio ( player -- player bool )
+ [ [ buffers>> first ] keep al-channel-format ] keep
+ [ audio-buffer>> dup length ] keep
+ [ vi>> vorbis_info-rate alBufferData check-error ] keep
+ [ source>> 1 ] keep
+ [ buffers>> first <uint> alSourceQueueBuffers check-error ] keep
+ [ source>> alSourcePlay check-error ] keep
+ t >>playing? t ;
+
+: process-audio ( player -- player bool )
+ dup playing?>> [ append-audio ] [ start-audio ] if ;
+
+: read-bytes-into ( dest size stream -- len )
+ #! Read the given number of bytes from a stream
+ #! and store them in the destination byte array.
+ stream-read >byte-array dup length [ memcpy ] keep ;
+
+: check-not-negative ( int -- )
+ 0 < [ "Word result was a negative number." throw ] when ;
+
+: buffer-size ( -- number )
+ 4096 ; inline
+
+: sync-buffer ( player -- buffer size player )
+ [ oy>> buffer-size ogg_sync_buffer buffer-size ] keep ;
+
+: stream-into-buffer ( buffer size player -- len player )
+ [ stream>> read-bytes-into ] keep ;
+
+: confirm-buffer ( len player -- player eof? )
+ [ oy>> swap ogg_sync_wrote check-not-negative ] 2keep swap zero? ;
+
+: buffer-data ( player -- player eof? )
+ #! Take some compressed bitstream data and sync it for
+ #! page extraction.
+ sync-buffer stream-into-buffer confirm-buffer ;
+
+: queue-page ( player -- player )
+ #! Push a page into the stream for packetization
+ [ [ vo>> ] [ og>> ] bi ogg_stream_pagein drop ]
+ [ [ to>> ] [ og>> ] bi ogg_stream_pagein drop ]
+ [ ] tri ;
+
+: retrieve-page ( player -- player bool )
+ #! Sync the streams and get a page. Return true if a page was
+ #! successfully retrieved.
+ dup [ oy>> ] [ og>> ] bi ogg_sync_pageout 0 > ;
+
+: standard-initial-header? ( player -- player bool )
+ dup og>> ogg_page_bos zero? not ;
+
+: ogg-stream-init ( player -- state player )
+ #! Init the encode/decode logical stream state
+ [ temp-state>> ] keep
+ [ og>> ogg_page_serialno ogg_stream_init check-not-negative ] 2keep ;
+
+: ogg-stream-pagein ( state player -- state player )
+ #! Add the incoming page to the stream state
+ [ og>> ogg_stream_pagein drop ] 2keep ;
+
+: ogg-stream-packetout ( state player -- state player )
+ [ op>> ogg_stream_packetout drop ] 2keep ;
+
+: decode-packet ( player -- state player )
+ ogg-stream-init ogg-stream-pagein ogg-stream-packetout ;
+
+: theora-header? ( player -- player bool )
+ #! Is the current page a theora header?
+ dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header 0 >= ;
+
+: is-theora-packet? ( player -- player bool )
+ dup theora>> zero? [ theora-header? ] [ f ] if ;
+
+: copy-to-theora-state ( state player -- player )
+ #! Copy the state to the theora state structure in the player
+ [ to>> swap dup length memcpy ] keep ;
+
+: handle-initial-theora-header ( state player -- player )
+ copy-to-theora-state 1 >>theora ;
+
+: vorbis-header? ( player -- player bool )
+ #! Is the current page a vorbis header?
+ dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin 0 >= ;
+
+: is-vorbis-packet? ( player -- player bool )
+ dup vorbis>> zero? [ vorbis-header? ] [ f ] if ;
+
+: copy-to-vorbis-state ( state player -- player )
+ #! Copy the state to the vorbis state structure in the player
+ [ vo>> swap dup length memcpy ] keep ;
+
+: handle-initial-vorbis-header ( state player -- player )
+ copy-to-vorbis-state 1 >>vorbis ;
+
+: handle-initial-unknown-header ( state player -- player )
+ swap ogg_stream_clear drop ;
+
+: process-initial-header ( player -- player bool )
+ #! Is this a standard initial header? If not, stop parsing
+ standard-initial-header? [
+ decode-packet {
+ { [ is-vorbis-packet? ] [ handle-initial-vorbis-header ] }
+ { [ is-theora-packet? ] [ handle-initial-theora-header ] }
+ [ handle-initial-unknown-header ]
+ } cond t
+ ] [
+ f
+ ] if ;
+
+: parse-initial-headers ( player -- player )
+ #! Parse Vorbis headers, ignoring any other type stored
+ #! in the Ogg container.
+ retrieve-page [
+ process-initial-header [
+ parse-initial-headers
+ ] [
+ #! Don't leak the page, get it into the appropriate stream
+ queue-page
+ ] if
+ ] [
+ buffer-data not [ parse-initial-headers ] when
+ ] if ;
+
+: have-required-vorbis-headers? ( player -- player bool )
+ #! Return true if we need to decode vorbis due to there being
+ #! vorbis headers read from the stream but we don't have them all
+ #! yet.
+ dup vorbis>> 1 2 between? not ;
+
+: have-required-theora-headers? ( player -- player bool )
+ #! Return true if we need to decode theora due to there being
+ #! theora headers read from the stream but we don't have them all
+ #! yet.
+ dup theora>> 1 2 between? not ;
+
+: get-remaining-vorbis-header-packet ( player -- player bool )
+ dup [ vo>> ] [ op>> ] bi ogg_stream_packetout {
+ { [ dup 0 < ] [ "Error parsing vorbis stream; corrupt stream?" throw ] }
+ { [ dup zero? ] [ drop f ] }
+ { [ t ] [ drop t ] }
+ } cond ;
+
+: get-remaining-theora-header-packet ( player -- player bool )
+ dup [ to>> ] [ op>> ] bi ogg_stream_packetout {
+ { [ dup 0 < ] [ "Error parsing theora stream; corrupt stream?" throw ] }
+ { [ dup zero? ] [ drop f ] }
+ { [ t ] [ drop t ] }
+ } cond ;
+
+: decode-remaining-vorbis-header-packet ( player -- player )
+ dup [ vi>> ] [ vc>> ] [ op>> ] tri vorbis_synthesis_headerin zero? [
+ "Error parsing vorbis stream; corrupt stream?" throw
+ ] unless ;
+
+: decode-remaining-theora-header-packet ( player -- player )
+ dup [ ti>> ] [ tc>> ] [ op>> ] tri theora_decode_header zero? [
+ "Error parsing theora stream; corrupt stream?" throw
+ ] unless ;
+
+: increment-vorbis-header-count ( player -- player )
+ [ 1+ ] change-vorbis ;
+
+: increment-theora-header-count ( player -- player )
+ [ 1+ ] change-theora ;
+
+: parse-remaining-vorbis-headers ( player -- player )
+ have-required-vorbis-headers? not [
+ get-remaining-vorbis-header-packet [
+ decode-remaining-vorbis-header-packet
+ increment-vorbis-header-count
+ parse-remaining-vorbis-headers
+ ] when
+ ] when ;
+
+: parse-remaining-theora-headers ( player -- player )
+ have-required-theora-headers? not [
+ get-remaining-theora-header-packet [
+ decode-remaining-theora-header-packet
+ increment-theora-header-count
+ parse-remaining-theora-headers
+ ] when
+ ] when ;
+
+: get-more-header-data ( player -- player )
+ buffer-data drop ;
+
+: parse-remaining-headers ( player -- player )
+ have-required-vorbis-headers? not swap have-required-theora-headers? not swapd or [
+ parse-remaining-vorbis-headers
+ parse-remaining-theora-headers
+ retrieve-page [ queue-page ] [ get-more-header-data ] if
+ parse-remaining-headers
+ ] when ;
+
+: tear-down-vorbis ( player -- player )
+ dup vi>> vorbis_info_clear
+ dup vc>> vorbis_comment_clear ;
+
+: tear-down-theora ( player -- player )
+ dup ti>> theora_info_clear
+ dup tc>> theora_comment_clear ;
+
+: init-vorbis-codec ( player -- player )
+ dup [ vd>> ] [ vi>> ] bi vorbis_synthesis_init drop
+ dup [ vd>> ] [ vb>> ] bi vorbis_block_init drop ;
+
+: init-theora-codec ( player -- player )
+ dup [ td>> ] [ ti>> ] bi theora_decode_init drop
+ dup ti>> theora_info-frame_width over ti>> theora_info-frame_height
+ 4 * * <byte-array> >>rgb ;
+
+
+: display-vorbis-details ( player -- player )
+ [
+ "Ogg logical stream " %
+ dup vo>> ogg_stream_state-serialno #
+ " is Vorbis " %
+ dup vi>> vorbis_info-channels #
+ " channel " %
+ dup vi>> vorbis_info-rate #
+ " Hz audio." %
+ ] "" make print ;
+
+: display-theora-details ( player -- player )
+ [
+ "Ogg logical stream " %
+ dup to>> ogg_stream_state-serialno #
+ " is Theora " %
+ dup ti>> theora_info-width #
+ "x" %
+ dup ti>> theora_info-height #
+ " " %
+ dup ti>> theora_info-fps_numerator
+ over ti>> theora_info-fps_denominator /f #
+ " fps video" %
+ ] "" make print ;
+
+: initialize-decoder ( player -- player )
+ dup vorbis>> zero? [ tear-down-vorbis ] [ init-vorbis-codec display-vorbis-details ] if
+ dup theora>> zero? [ tear-down-theora ] [ init-theora-codec display-theora-details ] if ;
+
+: sync-pages ( player -- player )
+ retrieve-page [
+ queue-page sync-pages
+ ] when ;
+
+: audio-buffer-not-ready? ( player -- player bool )
+ dup vorbis>> zero? not over audio-full?>> not and ;
+
+: pending-decoded-audio? ( player -- player pcm len bool )
+ f <void*> 2dup >r vd>> r> vorbis_synthesis_pcmout dup 0 > ;
+
+: buffer-space-available ( player -- available )
+ audio-buffer-size swap audio-index>> - ;
+
+: samples-to-read ( player available len -- numread )
+ >r swap num-channels / r> min ;
+
+: each-with3 ( obj obj obj seq quot -- ) 3 each-withn ; inline
+
+: add-to-buffer ( player val -- )
+ over audio-index>> pick audio-buffer>> set-short-nth
+ [ 1+ ] change-audio-index drop ;
+
+: get-audio-value ( pcm sample channel -- value )
+ rot *void* void*-nth float-nth ;
+
+: process-channels ( player pcm sample channel -- )
+ get-audio-value 32767.0 * >fixnum 32767 min -32768 max add-to-buffer ;
+
+: (process-sample) ( player pcm sample -- )
+ pick num-channels [ process-channels ] each-with3 ;
+
+: process-samples ( player pcm numread -- )
+ [ (process-sample) ] each-with2 ;
+
+: decode-pending-audio ( player pcm result -- player )
+! [ "ret = " % dup # ] "" make write
+ pick [ buffer-space-available swap ] keep -rot samples-to-read
+ pick over >r >r process-samples r> r> swap
+ ! numread player
+ dup audio-index>> audio-buffer-size = [
+ t >>audio-full?
+ ] when
+ dup vd>> vorbis_dsp_state-granulepos dup 0 >= [
+ ! numtoread player granulepos
+ #! This is wrong: fix
+ pick - >>audio-granulepos
+ ] [
+ ! numtoread player granulepos
+ pick + >>audio-granulepos
+ ] if
+ [ vd>> swap vorbis_synthesis_read drop ] keep ;
+
+: no-pending-audio ( player -- player bool )
+ #! No pending audio. Is there a pending packet to decode.
+ dup [ vo>> ] [ op>> ] bi ogg_stream_packetout 0 > [
+ dup [ vb>> ] [ op>> ] bi vorbis_synthesis 0 = [
+ dup [ vd>> ] [ vb>> ] bi vorbis_synthesis_blockin drop
+ ] when
+ t
+ ] [
+ #! Need more data. Break out to suck in another page.
+ f
+ ] if ;
+
+: decode-audio ( player -- player )
+ audio-buffer-not-ready? [
+ #! If there's pending decoded audio, grab it
+ pending-decoded-audio? [
+ decode-pending-audio decode-audio
+ ] [
+ 2drop no-pending-audio [ decode-audio ] when
+ ] if
+ ] when ;
+
+: video-buffer-not-ready? ( player -- player bool )
+ dup theora>> zero? not over video-ready?>> not and ;
+
+: decode-video ( player -- player )
+ video-buffer-not-ready? [
+ dup [ to>> ] [ op>> ] bi ogg_stream_packetout 0 > [
+ dup [ td>> ] [ op>> ] bi theora_decode_packetin drop
+ dup td>> theora_state-granulepos >>video-granulepos
+ dup [ td>> ] [ video-granulepos>> ] bi theora_granule_time
+ >>video-time
+ t >>video-ready?
+ decode-video
+ ] when
+ ] when ;
+
+: decode ( player -- player )
+ get-more-header-data sync-pages
+ decode-audio
+ decode-video
+ dup audio-full?>> [
+ process-audio [
+ f >>audio-full?
+ 0 >>audio-index
+ ] when
+ ] when
+ dup video-ready?>> [
+ dup video-time>> over get-time - dup 0.0 < [
+ -0.1 > [ process-video ] when
+ f >>video-ready?
+ ] [
+ drop
+ ] if
+ ] when
+ decode ;
+
+: free-malloced-objects ( player -- player )
+ {
+ [ op>> free ]
+ [ oy>> free ]
+ [ og>> free ]
+ [ vo>> free ]
+ [ vi>> free ]
+ [ vd>> free ]
+ [ vb>> free ]
+ [ vc>> free ]
+ [ to>> free ]
+ [ ti>> free ]
+ [ tc>> free ]
+ [ td>> free ]
+ [ ]
+ } cleave ;
+
+
+: unqueue-openal-buffers ( player -- player )
+ [
+
+ num-audio-buffers-processed over source>> rot buffer-indexes>> swapd
+ alSourceUnqueueBuffers check-error
+ ] keep ;
+
+: delete-openal-buffers ( player -- player )
+ [
+ buffers>> [
+ 1 swap <uint> alDeleteBuffers check-error
+ ] each
+ ] keep ;
+
+: delete-openal-source ( player -- player )
+ [ source>> 1 swap <uint> alDeleteSources check-error ] keep ;
+
+: cleanup ( player -- player )
+ free-malloced-objects
+ unqueue-openal-buffers
+ delete-openal-buffers
+ delete-openal-source ;
+
+: wait-for-sound ( player -- player )
+ #! Waits for the openal to finish playing remaining sounds
+ dup source>> AL_SOURCE_STATE 0 <int> [ alGetSourcei check-error ] keep
+ *int AL_PLAYING = [
+ 100 sleep
+ wait-for-sound
+ ] when ;
+
+TUPLE: theora-gadget < gadget player ;
+
+: <theora-gadget> ( player -- gadget )
+ theora-gadget new-gadget
+ swap >>player ;
+
+M: theora-gadget pref-dim*
+ player>>
+ ti>> dup theora_info-width swap theora_info-height 2array ;
+
+M: theora-gadget draw-gadget* ( gadget -- )
+ 0 0 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ GL_UNPACK_ALIGNMENT 1 glPixelStorei
+ [ pref-dim* first2 GL_RGB GL_UNSIGNED_BYTE ] keep
+ player>> rgb>> glDrawPixels ;
+
+: initialize-gui ( gadget -- )
+ "Theora Player" open-window ;
+
+: play-ogg ( player -- )
+ parse-initial-headers
+ parse-remaining-headers
+ initialize-decoder
+ dup gadget>> [ initialize-gui ] when*
+ [ decode ] try
+ wait-for-sound
+ cleanup
+ drop ;
+
+: play-vorbis-stream ( stream -- )
+ <player> play-ogg ;
+
+: play-vorbis-file ( filename -- )
+ binary <file-reader> play-vorbis-stream ;
+
+: play-theora-stream ( stream -- )
+ <player>
+ dup <theora-gadget> >>gadget
+ play-ogg ;
+
+: play-theora-file ( filename -- )
+ binary <file-reader> play-theora-stream ;
-! Copyright (C) 2008 William Schlieper\r
-! See http://factorcode.org/license.txt for BSD license.\r
-\r
-USING: accessors kernel fry math math.vectors sequences arrays vectors assocs\r
- hashtables models models.range models.product combinators\r
- ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs\r
- ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;\r
-\r
-IN: ui.gadgets.tabs\r
-\r
-TUPLE: tabbed < frame names toggler content ;\r
-\r
-DEFER: (del-page)\r
-\r
-:: add-toggle ( n name model toggler -- )\r
- <frame>\r
- n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>\r
- @right grid-add\r
- n model name <toggle-button> @center grid-add\r
- toggler swap add-gadget drop ;\r
-\r
-: redo-toggler ( tabbed -- )\r
- [ names>> ] [ model>> ] [ toggler>> ] tri\r
- [ clear-gadget ] keep\r
- [ [ length ] keep ] 2dip\r
- '[ _ _ add-toggle ] 2each ;\r
-\r
-: refresh-book ( tabbed -- )\r
- model>> [ ] change-model ;\r
-\r
-: (del-page) ( n name tabbed -- )\r
- { [ [ remove ] change-names redo-toggler ]\r
- [ dupd [ names>> length ] [ model>> ] bi\r
- [ [ = ] keep swap [ 1- ] when\r
- [ < ] keep swap [ 1- ] when ] change-model ]\r
- [ content>> nth-gadget unparent ]\r
- [ refresh-book ]\r
- } cleave ;\r
-\r
-: add-page ( page name tabbed -- )\r
- [ names>> push ] 2keep\r
- [ [ names>> length 1 - swap ]\r
- [ model>> ]\r
- [ toggler>> ] tri add-toggle ]\r
- [ content>> swap add-gadget drop ]\r
- [ refresh-book ] tri ;\r
-\r
-: del-page ( name tabbed -- )\r
- [ names>> index ] 2keep (del-page) ;\r
-\r
-: new-tabbed ( assoc class -- tabbed )\r
- new-frame\r
- 0 <model> >>model\r
- <pile> 1 >>fill >>toggler\r
- dup toggler>> @left grid-add\r
- swap\r
- [ keys >vector >>names ]\r
- [ values over model>> <book> >>content dup content>> @center grid-add ]\r
- bi\r
- dup redo-toggler ;\r
- \r
-: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;\r
+! Copyright (C) 2008 William Schlieper
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: accessors kernel fry math math.vectors sequences arrays vectors assocs
+ hashtables models models.range models.product combinators
+ ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs
+ ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;
+
+IN: ui.gadgets.tabs
+
+TUPLE: tabbed < frame names toggler content ;
+
+DEFER: (del-page)
+
+:: add-toggle ( n name model toggler -- )
+ <frame>
+ n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>
+ @right grid-add
+ n model name <toggle-button> @center grid-add
+ toggler swap add-gadget drop ;
+
+: redo-toggler ( tabbed -- )
+ [ names>> ] [ model>> ] [ toggler>> ] tri
+ [ clear-gadget ] keep
+ [ [ length ] keep ] 2dip
+ '[ _ _ add-toggle ] 2each ;
+
+: refresh-book ( tabbed -- )
+ model>> [ ] change-model ;
+
+: (del-page) ( n name tabbed -- )
+ { [ [ remove ] change-names redo-toggler ]
+ [ dupd [ names>> length ] [ model>> ] bi
+ [ [ = ] keep swap [ 1- ] when
+ [ < ] keep swap [ 1- ] when ] change-model ]
+ [ content>> nth-gadget unparent ]
+ [ refresh-book ]
+ } cleave ;
+
+: add-page ( page name tabbed -- )
+ [ names>> push ] 2keep
+ [ [ names>> length 1 - swap ]
+ [ model>> ]
+ [ toggler>> ] tri add-toggle ]
+ [ content>> swap add-gadget drop ]
+ [ refresh-book ] tri ;
+
+: del-page ( name tabbed -- )
+ [ names>> index ] 2keep (del-page) ;
+
+: new-tabbed ( assoc class -- tabbed )
+ new-frame
+ 0 <model> >>model
+ <pile> 1 >>fill >>toggler
+ dup toggler>> @left grid-add
+ swap
+ [ keys >vector >>names ]
+ [ values over model>> <book> >>content dup content>> @center grid-add ]
+ bi
+ dup redo-toggler ;
+
+: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;
return r;
}
-F_STDCALL int ffi_test_18(int x, int y, int z, int t)
+FACTOR_STDCALL(int) ffi_test_18(int x, int y, int z, int t)
{
return x + y + z * t;
}
-F_STDCALL struct bar ffi_test_19(long x, long y, long z)
+FACTOR_STDCALL(struct bar) ffi_test_19(long x, long y, long z)
{
struct bar r;
r.x = x; r.y = y; r.z = z;
return retval;
}
+/* C99 features */
+#ifndef _MSC_VER
+
_Complex float ffi_test_45(int x)
{
return x;
{
return x.parents;
}
+
+#endif
-#ifdef _MSC_VER
- #define WINDOWS
+#if defined(_MSC_VER)
+ #define FACTOR_STDCALL(return_type) return_type __stdcall
+#elif defined(i386) || defined(__i386) || defined(__i386__)
+ #define FACTOR_STDCALL(return_type) __attribute__((stdcall)) return_type
#else
- #include <stdbool.h>
-#endif
-
-#if defined(i386) || defined(__i386) || defined(__i386__) || defined(WIN32)
- #define F_STDCALL __attribute__((stdcall))
-#else
- #define F_STDCALL
+ #define FACTOR_STDCALL(return_type) return_type
#endif
#if defined(__APPLE__)
- #define F_EXPORT __attribute__((visibility("default")))
-#elif defined(WINDOWS)
- #define F_EXPORT __declspec(dllexport)
+ #define FACTOR_EXPORT __attribute__((visibility("default")))
+#elif defined(WIN32) || defined(_MSC_VER)
+ #define FACTOR_EXPORT __declspec(dllexport)
#else
- #define F_EXPORT
+ #define FACTOR_EXPORT
#endif
-F_EXPORT void ffi_test_0(void);
-F_EXPORT int ffi_test_1(void);
-F_EXPORT int ffi_test_2(int x, int y);
-F_EXPORT int ffi_test_3(int x, int y, int z, int t);
-F_EXPORT float ffi_test_4(void);
-F_EXPORT double ffi_test_5(void);
-F_EXPORT double ffi_test_6(float x, float y);
-F_EXPORT double ffi_test_7(double x, double y);
-F_EXPORT double ffi_test_8(double x, float y, double z, float t, int w);
-F_EXPORT int ffi_test_9(int a, int b, int c, int d, int e, int f, int g);
-F_EXPORT int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h);
+FACTOR_EXPORT void ffi_test_0(void);
+FACTOR_EXPORT int ffi_test_1(void);
+FACTOR_EXPORT int ffi_test_2(int x, int y);
+FACTOR_EXPORT int ffi_test_3(int x, int y, int z, int t);
+FACTOR_EXPORT float ffi_test_4(void);
+FACTOR_EXPORT double ffi_test_5(void);
+FACTOR_EXPORT double ffi_test_6(float x, float y);
+FACTOR_EXPORT double ffi_test_7(double x, double y);
+FACTOR_EXPORT double ffi_test_8(double x, float y, double z, float t, int w);
+FACTOR_EXPORT int ffi_test_9(int a, int b, int c, int d, int e, int f, int g);
+FACTOR_EXPORT int ffi_test_10(int a, int b, double c, int d, float e, int f, int g, int h);
struct foo { int x, y; };
-F_EXPORT int ffi_test_11(int a, struct foo b, int c);
+FACTOR_EXPORT int ffi_test_11(int a, struct foo b, int c);
struct rect { float x, y, w, h; };
-F_EXPORT int ffi_test_12(int a, int b, struct rect c, int d, int e, int f);
-F_EXPORT int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k);
-F_EXPORT struct foo ffi_test_14(int x, int y);
-F_EXPORT char *ffi_test_15(char *x, char *y);
+FACTOR_EXPORT int ffi_test_12(int a, int b, struct rect c, int d, int e, int f);
+FACTOR_EXPORT int ffi_test_13(int a, int b, int c, int d, int e, int f, int g, int h, int i, int j, int k);
+FACTOR_EXPORT struct foo ffi_test_14(int x, int y);
+FACTOR_EXPORT char *ffi_test_15(char *x, char *y);
struct bar { long x, y, z; };
-F_EXPORT struct bar ffi_test_16(long x, long y, long z);
+FACTOR_EXPORT struct bar ffi_test_16(long x, long y, long z);
struct tiny { int x; };
-F_EXPORT struct tiny ffi_test_17(int x);
-F_EXPORT F_STDCALL int ffi_test_18(int x, int y, int z, int t);
-F_EXPORT F_STDCALL struct bar ffi_test_19(long x, long y, long z);
-F_EXPORT void ffi_test_20(double x1, double x2, double x3,
+FACTOR_EXPORT struct tiny ffi_test_17(int x);
+FACTOR_EXPORT FACTOR_STDCALL(int) ffi_test_18(int x, int y, int z, int t);
+FACTOR_EXPORT FACTOR_STDCALL(struct bar) ffi_test_19(long x, long y, long z);
+FACTOR_EXPORT void ffi_test_20(double x1, double x2, double x3,
double y1, double y2, double y3,
double z1, double z2, double z3);
-F_EXPORT long long ffi_test_21(long x, long y);
-F_EXPORT long ffi_test_22(long x, long long y, long long z);
-F_EXPORT float ffi_test_23(float x[3], float y[3]);
+FACTOR_EXPORT long long ffi_test_21(long x, long y);
+FACTOR_EXPORT long ffi_test_22(long x, long long y, long long z);
+FACTOR_EXPORT float ffi_test_23(float x[3], float y[3]);
struct test_struct_1 { char x; };
-F_EXPORT struct test_struct_1 ffi_test_24(void);
+FACTOR_EXPORT struct test_struct_1 ffi_test_24(void);
struct test_struct_2 { char x, y; };
-F_EXPORT struct test_struct_2 ffi_test_25(void);
+FACTOR_EXPORT struct test_struct_2 ffi_test_25(void);
struct test_struct_3 { char x, y, z; };
-F_EXPORT struct test_struct_3 ffi_test_26(void);
+FACTOR_EXPORT struct test_struct_3 ffi_test_26(void);
struct test_struct_4 { char x, y, z, a; };
-F_EXPORT struct test_struct_4 ffi_test_27(void);
+FACTOR_EXPORT struct test_struct_4 ffi_test_27(void);
struct test_struct_5 { char x, y, z, a, b; };
-F_EXPORT struct test_struct_5 ffi_test_28(void);
+FACTOR_EXPORT struct test_struct_5 ffi_test_28(void);
struct test_struct_6 { char x, y, z, a, b, c; };
-F_EXPORT struct test_struct_6 ffi_test_29(void);
+FACTOR_EXPORT struct test_struct_6 ffi_test_29(void);
struct test_struct_7 { char x, y, z, a, b, c, d; };
-F_EXPORT struct test_struct_7 ffi_test_30(void);
-F_EXPORT int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41);
-F_EXPORT float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41);
+FACTOR_EXPORT struct test_struct_7 ffi_test_30(void);
+FACTOR_EXPORT int ffi_test_31(int x0, int x1, int x2, int x3, int x4, int x5, int x6, int x7, int x8, int x9, int x10, int x11, int x12, int x13, int x14, int x15, int x16, int x17, int x18, int x19, int x20, int x21, int x22, int x23, int x24, int x25, int x26, int x27, int x28, int x29, int x30, int x31, int x32, int x33, int x34, int x35, int x36, int x37, int x38, int x39, int x40, int x41);
+FACTOR_EXPORT float ffi_test_31_point_5(float x0, float x1, float x2, float x3, float x4, float x5, float x6, float x7, float x8, float x9, float x10, float x11, float x12, float x13, float x14, float x15, float x16, float x17, float x18, float x19, float x20, float x21, float x22, float x23, float x24, float x25, float x26, float x27, float x28, float x29, float x30, float x31, float x32, float x33, float x34, float x35, float x36, float x37, float x38, float x39, float x40, float x41);
struct test_struct_8 { double x; double y; };
-F_EXPORT double ffi_test_32(struct test_struct_8 x, int y);
+FACTOR_EXPORT double ffi_test_32(struct test_struct_8 x, int y);
struct test_struct_9 { float x; float y; };
-F_EXPORT double ffi_test_33(struct test_struct_9 x, int y);
+FACTOR_EXPORT double ffi_test_33(struct test_struct_9 x, int y);
struct test_struct_10 { float x; int y; };
-F_EXPORT double ffi_test_34(struct test_struct_10 x, int y);
+FACTOR_EXPORT double ffi_test_34(struct test_struct_10 x, int y);
struct test_struct_11 { int x; int y; };
-F_EXPORT double ffi_test_35(struct test_struct_11 x, int y);
+FACTOR_EXPORT double ffi_test_35(struct test_struct_11 x, int y);
struct test_struct_12 { int a; double x; };
-F_EXPORT double ffi_test_36(struct test_struct_12 x);
+FACTOR_EXPORT double ffi_test_36(struct test_struct_12 x);
-F_EXPORT void ffi_test_36_point_5(void);
+FACTOR_EXPORT void ffi_test_36_point_5(void);
-F_EXPORT int ffi_test_37(int (*f)(int, int, int));
+FACTOR_EXPORT int ffi_test_37(int (*f)(int, int, int));
-F_EXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y);
+FACTOR_EXPORT unsigned long long ffi_test_38(unsigned long long x, unsigned long long y);
struct test_struct_13 { float x1, x2, x3, x4, x5, x6; };
-F_EXPORT int ffi_test_39(long a, long b, struct test_struct_13 s);
+FACTOR_EXPORT int ffi_test_39(long a, long b, struct test_struct_13 s);
struct test_struct_14 { double x1, x2; };
-F_EXPORT struct test_struct_14 ffi_test_40(double x1, double x2);
+FACTOR_EXPORT struct test_struct_14 ffi_test_40(double x1, double x2);
-F_EXPORT struct test_struct_12 ffi_test_41(int a, double x);
+FACTOR_EXPORT struct test_struct_12 ffi_test_41(int a, double x);
struct test_struct_15 { float x, y; };
-F_EXPORT struct test_struct_15 ffi_test_42(float x, float y);
+FACTOR_EXPORT struct test_struct_15 ffi_test_42(float x, float y);
struct test_struct_16 { float x; int a; };
-F_EXPORT struct test_struct_16 ffi_test_43(float x, int a);
+FACTOR_EXPORT struct test_struct_16 ffi_test_43(float x, int a);
+
+FACTOR_EXPORT struct test_struct_14 ffi_test_44();
-F_EXPORT struct test_struct_14 ffi_test_44();
+/* C99 features */
+#ifndef _MSC_VER
-F_EXPORT _Complex float ffi_test_45(int x);
+#include <stdbool.h>
-F_EXPORT _Complex double ffi_test_46(int x);
+FACTOR_EXPORT _Complex float ffi_test_45(int x);
-F_EXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);
+FACTOR_EXPORT _Complex double ffi_test_46(int x);
+
+FACTOR_EXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y);
struct bool_field_test {
char *name;
short parents;
};
-F_EXPORT short ffi_test_48(struct bool_field_test x);
+FACTOR_EXPORT short ffi_test_48(struct bool_field_test x);
+
+#endif
}
};
+struct code_block_become_visitor {
+ slot_visitor<slot_become_visitor> *workhorse;
+
+ explicit code_block_become_visitor(slot_visitor<slot_become_visitor> *workhorse_) :
+ workhorse(workhorse_) {}
+
+ void operator()(code_block *compiled, cell size)
+ {
+ workhorse->visit_code_block_objects(compiled);
+ workhorse->visit_embedded_literals(compiled);
+ }
+};
+
+struct code_block_write_barrier_visitor {
+ code_heap *code;
+
+ explicit code_block_write_barrier_visitor(code_heap *code_) :
+ code(code_) {}
+
+ void operator()(code_block *compiled, cell size)
+ {
+ code->write_barrier(compiled);
+ }
+};
+
/* classes.tuple uses this to reshape tuples; tools.deploy.shaker uses this
to coalesce equal but distinct quotations and wrappers. */
void factor_vm::primitive_become()
}
/* Update all references to old objects to point to new objects */
- slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
- workhorse.visit_roots();
- workhorse.visit_contexts();
+ {
+ slot_visitor<slot_become_visitor> workhorse(this,slot_become_visitor(&become_map));
+ workhorse.visit_roots();
+ workhorse.visit_contexts();
- object_become_visitor object_visitor(&workhorse);
- each_object(object_visitor);
+ object_become_visitor object_visitor(&workhorse);
+ each_object(object_visitor);
+
+ code_block_become_visitor code_block_visitor(&workhorse);
+ each_code_block(code_block_visitor);
+ }
/* Since we may have introduced old->new references, need to revisit
- all objects on a minor GC. */
+ all objects and code blocks on a minor GC. */
data->mark_all_cards();
- primitive_minor_gc();
+
+ {
+ code_block_write_barrier_visitor code_block_visitor(code);
+ each_code_block(code_block_visitor);
+ }
}
}
-#include "master.hpp"\r
-\r
-namespace factor\r
-{\r
-\r
-factor_vm::factor_vm() :\r
- nursery(0,0),\r
- c_to_factor_func(NULL),\r
- profiling_p(false),\r
- gc_off(false),\r
- current_gc(NULL),\r
- gc_events(NULL),\r
- fep_disabled(false),\r
- full_output(false),\r
- last_nano_count(0)\r
-{\r
- primitive_reset_dispatch_stats();\r
-}\r
-\r
-}\r
+#include "master.hpp"
+
+namespace factor
+{
+
+factor_vm::factor_vm() :
+ nursery(0,0),
+ c_to_factor_func(NULL),
+ profiling_p(false),
+ gc_off(false),
+ current_gc(NULL),
+ gc_events(NULL),
+ fep_disabled(false),
+ full_output(false),
+ last_nano_count(0)
+{
+ primitive_reset_dispatch_stats();
+}
+
+}
projects / factor.git / commitdiff