*.a
*.dll
*.lib
+*.exp
*.res
+*.RES
*.image
*.dylib
factor
-!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
USING: alien alien.syntax alien.c-types alien.parser
eval kernel tools.test sequences system libc alien.strings
-io.encodings.utf8 math.constants classes.struct classes ;
+io.encodings.utf8 math.constants classes.struct classes
+accessors compiler.units ;
IN: alien.c-types.tests
CONSTANT: xyz 123
\ struct-redefined class?
] unit-test
+[
+ "IN: alien.c-types.tests
+ USE: alien.syntax
+ USE: alien.c-types
+ TYPEDEF: int type-redefinition-test
+ TYPEDEF: int type-redefinition-test" eval( -- )
+]
+[ error>> error>> redefine-error? ]
+must-fail-with
[ 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:
-! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman.
+! Copyright (C) 2005, 2010 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays alien alien.c-types
alien.arrays alien.strings kernel math namespaces parser
(CALLBACK:) define-inline ;
SYNTAX: TYPEDEF:
- scan-c-type CREATE-C-TYPE typedef ;
+ scan-c-type CREATE-C-TYPE dup save-location typedef ;
SYNTAX: C-ENUM:
";" parse-tokens
"If the sequence is non-empty, outputs the index and value of the closest match, which is either an element for which the quotation output " { $link +eq+ } ", or failing that, least element for which the quotation output " { $link +lt+ } "."
$nl
"If the sequence is empty, outputs " { $link f } " " { $link f } "." }
-{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." } ;
+{ $notes "If the sequence has at least one element, this word always outputs a valid index, because it finds the closest match, not necessarily an exact one. In this respect its behavior differs from " { $link find } "." }
+{ $examples
+ "Searching for an integer in a sorted array:"
+ { $example
+ "USING: binary-search math.order prettyprint ;"
+ "{ -13 -4 1 9 16 17 28 } [ 5 >=< ] search . ."
+ "1\n2"
+ }
+ "Frequently, the quotation passed to " { $link search } " is constructed by " { $link curry } " or " { $link with } " in order to make the search key a parameter:"
+ { $example
+ "USING: binary-search kernel math.order prettyprint ;"
+ "5 { -13 -4 1 9 16 17 28 } [ <=> ] with search . ."
+ "1\n2"
+ }
+} ;
{ find find-from find-last find-last find-last-from search } related-words
-! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2007, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors cpu.architecture vocabs.loader system
sequences namespaces parser kernel kernel.private classes
gc
: compile-unoptimized ( words -- )
+ [ [ subwords ] map ] keep suffix concat
[ optimized? not ] filter compile ;
"debug-compiler" get [
"." write flush
{
- lines prefix suffix unclip new-assoc update
+ lines prefix suffix unclip new-assoc assoc-union!
word-prop set-word-prop 1array 2array 3array ?nth
} compile-unoptimized
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 ;
\ c-to-factor c-to-factor-word set
\ lazy-jit-compile lazy-jit-compile-word set
\ unwind-native-frames unwind-native-frames-word set
- [ undefined ] undefined-quot set ;
+ undefined-def undefined-quot set ;
: emit-special-objects ( -- )
special-objects get keys [ emit-special-object ] each ;
: 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
GENERIC: generate-insn ( insn -- )
-TUPLE: asm label code calls ;
-
-SYMBOL: calls
-
-: add-call ( word -- )
- #! Compile this word later.
- calls get push ;
-
! Mapping _label IDs to label instances
SYMBOL: labels
-: init-generator ( -- )
- H{ } clone labels set
- V{ } clone calls set ;
-
-: generate-insns ( asm -- code )
+: generate ( mr -- code )
dup label>> [
- init-generator
+ H{ } clone labels set
instructions>> [
[ class insn-counts get inc-at ]
[ generate-insn ]
] each
] with-fixup ;
-: generate ( mr -- asm )
- [
- [ label>> ] [ generate-insns ] bi calls get
- asm boa
- ] with-scope ;
-
: lookup-label ( id -- label )
labels get [ drop <label> ] cache ;
! Special cases
M: ##no-tco generate-insn drop ;
-M: ##call generate-insn word>> [ add-call ] [ %call ] bi ;
-
-M: ##jump generate-insn word>> [ add-call ] [ %jump ] bi ;
-
M: _dispatch-label generate-insn
label>> lookup-label
cell 0 <repetition> %
CODEGEN: ##replace %replace
CODEGEN: ##inc-d %inc-d
CODEGEN: ##inc-r %inc-r
+CODEGEN: ##call %call
+CODEGEN: ##jump %jump
CODEGEN: ##return %return
CODEGEN: ##slot %slot
CODEGEN: ##slot-imm %slot-imm
: 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: assocs compiler.cfg.builder compiler.cfg.optimizer
compiler.errors compiler.tree.builder compiler.tree.optimizer
-compiler.units help.markup help.syntax io parser quotations
-sequences words ;
+compiler.units compiler.codegen help.markup help.syntax io
+parser quotations sequences words ;
IN: compiler
HELP: enable-optimizer
ARTICLE: "compiler-impl" "Compiler implementation"
"The " { $vocab-link "compiler" } "vocabulary, in addition to providing the user-visible words of the compiler, implements the main compilation loop."
$nl
-"Words are added to the " { $link compile-queue } " variable as needed and compiled."
-{ $subsections compile-queue }
"Once compiled, a word is added to the assoc stored in the " { $link compiled } " variable. When compilation is complete, this assoc is passed to " { $link modify-code-heap } "."
$nl
"The " { $link compile-word } " word performs the actual task of compiling an individual word. The process proceeds as follows:"
{ "The " { $link frontend } " word calls " { $link build-tree } ". If this fails, the error is passed to " { $link deoptimize } ". The logic for ignoring certain compile errors generated for inline words and macros is located here. If the error is not ignorable, it is added to the global " { $link compiler-errors } " assoc (see " { $link "compiler-errors" } ")." }
{ "If the word contains a breakpoint, compilation ends here. Otherwise, all remaining steps execute until machine code is generated. Any further errors thrown by the compiler are not reported as compile errors, but instead are ordinary exceptions. This is because they indicate bugs in the compiler, not errors in user code." }
{ "The " { $link frontend } " word then calls " { $link optimize-tree } ". This produces the final optimized tree IR, and this stage of the compiler is complete." }
- { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link save-asm } ", and adds any uncompiled words called by this word to the compilation queue with " { $link compile-dependency } "." }
+ { "The " { $link backend } " word calls " { $link build-cfg } " followed by " { $link optimize-cfg } " and a few other stages. Finally, it calls " { $link generate } "." }
}
"If compilation fails, the word is stored in the " { $link compiled } " assoc with a value of " { $link f } ". This causes the VM to compile the word with the non-optimizing compiler."
$nl
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
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
+continuations vocabs assocs definitions math graphs generic
+generic.single combinators combinators.smart macros
+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
compiler.codegen ;
IN: compiler
-SYMBOL: compile-queue
SYMBOL: compiled
: compile? ( word -- ? )
#! Don't attempt to compile certain words.
{
[ "forgotten" word-prop ]
- [ compiled get key? ]
[ inlined-block? ]
} 1|| not ;
-: queue-compile ( word -- )
- dup compile? [ compile-queue get push-front ] [ drop ] if ;
-
-: 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.
- dup recompile-callers?
- [ compiled-usage 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 -- ? )
-M: method-body no-compile? "method-generic" word-prop no-compile? ;
+M: method no-compile? "method-generic" word-prop no-compile? ;
M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
GENERIC: combinator? ( word -- ? )
-M: method-body combinator? "method-generic" word-prop combinator? ;
+M: method combinator? "method-generic" word-prop combinator? ;
M: predicate-engine-word combinator? "owner-generic" word-prop combinator? ;
#! Recompile callers if the word's stack effect changed, then
#! save the word's dependencies so that if they change, the
#! word can get recompiled too.
- [ recompile-callers ]
[ 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 ;
+ ] bi ;
: 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 )
contains-breakpoints? [ nip deoptimize* ] [ drop ] if
] [ deoptimize* ] if ;
-: compile-dependency ( word -- )
- #! If a word calls an unoptimized word, try to compile the callee.
- dup optimized? [ drop ] [ queue-compile ] if ;
-
-! Only switch this off for debugging.
-SYMBOL: compile-dependencies?
-
-t compile-dependencies? set-global
-
-: compile-dependencies ( asm -- )
- compile-dependencies? get
- [ calls>> [ compile-dependency ] each ] [ drop ] if ;
-
-: save-asm ( asm -- )
- [ [ code>> ] [ label>> ] bi compiled get set-at ]
- [ compile-dependencies ]
- bi ;
-
: backend ( tree word -- )
build-cfg [
[ optimize-cfg build-mr ] with-cfg
- generate
- save-asm
+ [ generate ] [ label>> ] bi compiled get set-at
] each ;
: compile-word ( word -- )
} cleave
] with-return ;
-: compile-loop ( deque -- )
- [ compile-word yield-hook get call( -- ) ] slurp-deque ;
-
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
- H{ } clone compiled set
- [
- [ queue-compile ]
- [ subwords [ compile-dependency ] each ] bi
- ] each
- compile-queue get compile-loop
+ H{ } clone compiled [
+ [ compile? ] filter
+ [ compile-word yield-hook get call( -- ) ] each
compiled get >alist
- ] with-scope
+ ] with-variable
"--- compile done" compiler-message ;
M: optimizing-compiler to-recompile ( -- words )
- changed-definitions get compiled-usages
- changed-generics get compiled-generic-usages
- append assoc-combine keys ;
+ [
+ changed-effects get new-words get assoc-diff outdated-effect-usages
+ changed-definitions get new-words get assoc-diff outdated-definition-usages
+ maybe-changed get new-words get assoc-diff outdated-conditional-usages
+ changed-definitions get [ drop word? ] assoc-filter 1array
+ ] append-outputs assoc-combine keys ;
M: optimizing-compiler process-forgotten-words
[ delete-compiled-xref ] each ;
-! 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 ;
+
+: outdated-definition-usages ( assoc -- assocs )
+ [ drop word? ] assoc-filter
+ [ drop definition-dependencies-of ] { } assoc>map ;
+
+: outdated-effect-usages ( assoc -- assocs )
[ drop word? ] assoc-filter
- [ [ drop (compiled-usages) ] { } assoc>map ] keep suffix ;
+ [ drop effect-dependencies-of ] { } assoc>map ;
+
+: 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 ;
-: compiled-generic-usage ( word -- assoc )
- compiled-generic-crossref get at ;
+: set-generic-call-sites ( word alist -- )
+ concat f like "generic-call-sites" set-word-prop ;
-: (compiled-generic-usages) ( generic class -- assoc )
- [ compiled-generic-usage ] dip
- [
- 2dup [ valid-class? ] both?
- [ classes-intersect? ] [ 2drop f ] if nip
- ] curry assoc-filter ;
+: split-dependencies ( assoc -- effect-deps cond-deps def-deps )
+ [ nip effect-dependency eq? ] assoc-partition
+ [ nip conditional-dependency eq? ] assoc-partition ;
-: compiled-generic-usages ( assoc -- assocs )
- [ (compiled-generic-usages) ] { } assoc>map ;
+: (store-dependencies) ( word assoc prop -- )
+ [ keys f like ] dip set-word-prop ;
-: (compiled-xref) ( word dependencies word-prop variable -- )
- [ [ concat ] dip set-word-prop ] [ get add-vertex* ] bi-curry* 2bi ;
+: store-dependencies ( word assoc -- )
+ split-dependencies
+ "effect-dependencies" "conditional-dependencies" "definition-dependencies"
+ [ (store-dependencies) ] tri-curry@ tri-curry* tri ;
+
+: (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 ;
+
+: 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 ;
-: (compiled-unxref) ( word word-prop variable -- )
- [ [ [ dupd word-prop 2 <groups> ] dip get remove-vertex* ] 2curry ]
- [ drop [ remove-word-prop ] curry ]
- 2bi bi ;
+: 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 ;
IN: compiler.test
: decompile ( word -- )
- dup def>> 2array 1array modify-code-heap ;
+ dup def>> 2array 1array t t modify-code-heap ;
: recompile-all ( -- )
all-words compile ;
[ ] [ 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 ( ) ;
: compile-cfg ( cfg -- word )
gensym
- [ build-mr generate code>> ] dip
- [ associate >alist modify-code-heap ] keep ;
+ [ build-mr generate ] dip
+ [ associate >alist t t modify-code-heap ] keep ;
: compile-test-cfg ( -- word )
cfg new 0 get >>entry
! Indirect dependency on an unoptimized word
: test-9 ( -- ) ;
<< SYMBOL: quot
-[ test-9 ] quot set-global >>
-MACRO: test-10 ( -- quot ) quot get ;
+[ test-9 ] quot set-global
+MACRO: test-10 ( -- quot ) quot get ; >>
: test-11 ( -- ) test-10 ;
[ ] [ test-11 ] unit-test
-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
: breakage-word ( a b -- c ) + ;
-MACRO: breakage-macro ( a -- ) '[ _ breakage-word ] ;
+<< MACRO: breakage-macro ( a -- ) '[ _ breakage-word ] ; >>
GENERIC: breakage-caller ( a -- c )
--- /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
--- /dev/null
+USING: kernel tools.test definitions compiler.units ;
+IN: compiler.tests.redefine21
+
+[ ] [ : a ( -- ) ; << : b ( quot -- ) call a ; inline >> [ ] b ] unit-test
+
+[ ] [ [ { a b } forget-all ] with-compilation-unit ] unit-test
+
+[ ] [ : A ( -- ) ; << : B ( -- ) A ; inline >> B ] unit-test
+
+[ ] [ [ { A B } forget-all ] with-compilation-unit ] 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
: symbolic-stack-trace ( -- newseq )
error-continuation get call>> callstack>array
- 2 group flip first ;
+ 3 group flip first ;
: foo ( -- * ) 3 throw 7 ;
: bar ( -- * ) foo 4 ;
[ 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 ;
word>> {
{ [ dup "intrinsic" word-prop ] [ intrinsics-called ] }
{ [ dup generic? ] [ generics-called ] }
- { [ dup method-body? ] [ methods-called ] }
+ { [ dup method? ] [ methods-called ] }
[ words-called ]
} cond get inc-at
] [ drop ] if
[ ] [ "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
+[ 1 3 test-quotatation inline-cache-invalidation-test ] [ T{ wrong-values f [ call(-redefine-test ] (( 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
! Copyright (C) 2009, 2010 Slava Pestov, Daniel Ehrenberg.
! 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
+fry kernel kernel.private make namespaces sequences continuations
+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 ;
+ ! Save and restore error variables here, so that we don't
+ ! pollute words such as :error and :c for the user.
+ error get-global error-continuation get-global
+ [ [ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ] 2dip
+ [ error set-global ] [ error-continuation set-global ] bi* ;
: cached-effect-valid? ( quot -- ? )
cache-counter>> effect-counter eq? ; inline
over +unknown+ eq?
[ 2drop f ] [ [ { effect } declare ] dip effect<= ] if ; inline
-: (call-effect-slow>quot) ( in out effect -- quot )
- [
- [ [ datastack ] dip dip ] %
- [ [ , ] bi@ \ check-datastack , ] dip
- '[ _ wrong-values ] , \ unless ,
- ] [ ] make ;
-
: call-effect-slow>quot ( effect -- quot )
- [ in>> length ] [ out>> length ] [ ] tri
- [ (call-effect-slow>quot) ] keep add-effect-input
- [ call-effect-unsafe ] 2curry ;
+ [ \ call-effect def>> curry ] [ add-effect-input ] bi
+ '[ _ _ call-effect-unsafe ] ;
: call-effect-slow ( quot effect -- ) drop call ;
[ '[ _ execute ] ] dip call-effect-slow ; inline
: execute-effect-unsafe? ( word effect -- ? )
- over optimized? [ [ stack-effect ] dip effect<= ] [ 2drop f ] if ; inline
+ over optimized?
+ [ [ stack-effect { effect } declare ] dip effect<= ]
+ [ 2drop f ]
+ if ; inline
: execute-effect-fast ( word effect inline-cache -- )
2over execute-effect-unsafe?
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 ] ;
HOOK: %set-alien-vector cpu ( ptr offset value rep -- )
HOOK: %alien-global cpu ( dst symbol library -- )
+HOOK: %vm-field cpu ( dst fieldname -- )
HOOK: %vm-field-ptr cpu ( dst fieldname -- )
HOOK: %allot cpu ( dst size class temp -- )
rs-reg ctx-reg context-retainstack-offset LWZ ;\r
\r
[\r
- 0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
- 11 3 profile-count-offset LWZ\r
+ 0 12 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel\r
+ 11 12 profile-count-offset LWZ\r
11 11 1 tag-fixnum ADDI\r
- 11 3 profile-count-offset STW\r
- 11 3 word-code-offset LWZ\r
+ 11 12 profile-count-offset STW\r
+ 11 12 word-code-offset LWZ\r
11 11 compiled-header-size ADDI\r
11 MTCTR\r
BCTR\r
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs sequences kernel combinators make math
math.order math.ranges system namespaces locals layouts words
: %load-vm-addr ( reg -- ) vm-reg MR ;
-: %load-vm-field-addr ( reg symbol -- )
- [ vm-reg ] dip vm-field-offset ADDI ;
+M: ppc %vm-field ( dst field -- )
+ [ vm-reg ] dip vm-field-offset LWZ ;
-M: ppc %vm-field-ptr ( dst field -- ) %load-vm-field-addr ;
+M: ppc %vm-field-ptr ( dst field -- )
+ [ vm-reg ] dip vm-field-offset ADDI ;
GENERIC: loc-reg ( loc -- reg )
M: ppc %set-alien-double -rot STFD ;
: load-zone-ptr ( reg -- )
- "nursery" %load-vm-field-addr ;
+ "nursery" %vm-field-ptr ;
: load-allot-ptr ( nursery-ptr allot-ptr -- )
[ drop load-zone-ptr ] [ swap 0 LWZ ] 2bi ;
ds-reg ds-reg 4 ADDI
int-regs return-reg ds-reg 0 STW ;
-:: %load-context-datastack ( dst -- )
- ! Load context struct
- dst "ctx" %vm-field-ptr
- dst dst 0 LWZ
- ! Load context datastack pointer
- dst dst "datastack" context-field-offset ADDI ;
-
M: ppc %push-context-stack ( -- )
- 11 %load-context-datastack
- 12 11 0 LWZ
+ 11 "ctx" %vm-field
+ 12 11 "datastack" context-field-offset LWZ
12 12 4 ADDI
- 12 11 0 STW
+ 12 11 "datastack" context-field-offset STW
int-regs return-reg 12 0 STW ;
M: ppc %pop-context-stack ( -- )
- 11 %load-context-datastack
- 12 11 0 LWZ
+ 11 "ctx" %vm-field
+ 12 11 "datastack" context-field-offset LWZ
int-regs return-reg 12 0 LWZ
12 12 4 SUBI
- 12 11 0 STW ;
+ 12 11 "datastack" context-field-offset STW ;
M: ppc %unbox ( n rep func -- )
! Value must be in r3
"from_value_struct" f %alien-invoke ;
M:: ppc %restore-context ( temp1 temp2 -- )
- temp1 "ctx" %load-vm-field-addr
- temp1 temp1 0 LWZ
+ temp1 "ctx" %vm-field
temp2 1 stack-frame get total-size>> ADDI
temp2 temp1 "callstack-bottom" context-field-offset STW
- ds-reg temp1 8 LWZ
- rs-reg temp1 12 LWZ ;
+ ds-reg temp1 "datastack" context-field-offset LWZ
+ rs-reg temp1 "retainstack" context-field-offset LWZ ;
M:: ppc %save-context ( temp1 temp2 -- )
- temp1 "ctx" %load-vm-field-addr
- temp1 temp1 0 LWZ
- 1 temp1 0 STW
- ds-reg temp1 8 STW
- rs-reg temp1 12 STW ;
+ temp1 "ctx" %vm-field
+ 1 temp1 "callstack-top" context-field-offset STW
+ ds-reg temp1 "datastack" context-field-offset STW
+ rs-reg temp1 "retainstack" context-field-offset STW ;
M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
M: x86.32 %mov-vm-ptr ( reg -- )
0 MOV 0 rc-absolute-cell rel-vm ;
+M: x86.32 %vm-field ( dst field -- )
+ [ 0 [] MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
+
M: x86.32 %vm-field-ptr ( dst field -- )
[ 0 MOV ] dip vm-field-offset rc-absolute-cell rel-vm ;
0 PUSH rc-absolute-cell rel-this
3 cells - decr-stack-reg ;
+M: x86.32 %prepare-jump
+ pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here ;
+
M: x86.32 %load-param-reg
stack-params assert=
[ [ EAX ] dip local@ MOV ] dip
EAX swap ds-reg reg-stack MOV ;
M: x86.32 %pop-context-stack ( -- )
- temp-reg %load-context-datastack
- EAX temp-reg [] MOV
+ temp-reg "ctx" %vm-field
+ EAX temp-reg "datastack" context-field-offset [+] MOV
EAX EAX [] MOV
- temp-reg [] bootstrap-cell SUB ;
+ temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
: call-unbox-func ( func -- )
4 save-vm-ptr
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 ;
ESP stack-frame-size 3 bootstrap-cells - SUB
] jit-prolog jit-define
+[
+ temp3 0 MOV rc-absolute-cell rt-here jit-rel
+ 0 JMP rc-relative rt-entry-point-pic-tail jit-rel
+] jit-word-jump jit-define
+
: jit-load-vm ( -- )
vm-reg 0 MOV 0 rc-absolute-cell jit-vm ;
M: x86.64 %mov-vm-ptr ( reg -- )
vm-reg MOV ;
+M: x86.64 %vm-field ( dst field -- )
+ [ vm-reg ] dip vm-field-offset [+] MOV ;
+
M: x86.64 %vm-field-ptr ( dst field -- )
[ vm-reg ] dip vm-field-offset [+] LEA ;
: param@ ( n -- op ) reserved-stack-space + stack@ ;
M: x86.64 %prologue ( n -- )
- temp-reg 0 MOV rc-absolute-cell rel-this
+ temp-reg -7 [] LEA
dup PUSH
temp-reg PUSH
stack-reg swap 3 cells - SUB ;
+M: x86.64 %prepare-jump
+ pic-tail-reg xt-tail-pic-offset [] LEA ;
+
: load-cards-offset ( dst -- )
0 MOV rc-absolute-cell rel-cards-offset ;
param-reg-0 swap ds-reg reg-stack MOV ;
M: x86.64 %pop-context-stack ( -- )
- temp-reg %load-context-datastack
- param-reg-0 temp-reg [] MOV
+ temp-reg "ctx" %vm-field
+ param-reg-0 temp-reg "datastack" context-field-offset [+] MOV
param-reg-0 param-reg-0 [] MOV
- temp-reg [] bootstrap-cell SUB ;
+ temp-reg "datastack" context-field-offset [+] bootstrap-cell SUB ;
M:: x86.64 %unbox ( n rep func -- )
param-reg-1 %mov-vm-ptr
RSP stack-frame-size 3 bootstrap-cells - SUB
] jit-prolog jit-define
+[
+ temp3 5 [] LEA
+ 0 JMP rc-relative rt-entry-point-pic-tail jit-rel
+] jit-word-jump jit-define
+
: jit-load-context ( -- )
ctx-reg vm-reg vm-context-offset [+] MOV ;
[
! Load word
- temp0 0 MOV rc-absolute-cell rt-literal jit-rel
+ safe-reg 0 MOV rc-absolute-cell rt-literal jit-rel
! Bump profiling counter
- temp0 profile-count-offset [+] 1 tag-fixnum ADD
+ safe-reg profile-count-offset [+] 1 tag-fixnum ADD
! Load word->code
- temp0 temp0 word-code-offset [+] MOV
+ safe-reg safe-reg word-code-offset [+] MOV
! Compute word entry point
- temp0 compiled-header-size ADD
+ safe-reg compiled-header-size ADD
! Jump to entry point
- temp0 JMP
+ safe-reg JMP
] jit-profiling jit-define
[
ds-reg [] temp0 MOV
] jit-push jit-define
-[
- temp3 0 MOV rc-absolute-cell rt-here jit-rel
- 0 JMP rc-relative rt-entry-point-pic-tail jit-rel
-] jit-word-jump jit-define
-
[
0 CALL rc-relative rt-entry-point-pic jit-rel
] jit-word-call jit-define
#! See the comment in vm/cpu-x86.hpp
4 1 + ; inline
+HOOK: %prepare-jump cpu ( -- )
+
M: x86 %jump ( word -- )
- pic-tail-reg 0 MOV xt-tail-pic-offset rc-absolute-cell rel-here
+ %prepare-jump
0 JMP rc-relative rel-word-pic-tail ;
M: x86 %jump-label ( label -- ) 0 JMP rc-relative label-fixup ;
ds-reg cell ADD
ds-reg [] int-regs return-reg MOV ;
-:: %load-context-datastack ( dst -- )
- ! Load context struct
- dst "ctx" %vm-field-ptr
- dst dst [] MOV
- ! Load context datastack pointer
- dst "datastack" context-field-offset ADD ;
-
M: x86 %push-context-stack ( -- )
- temp-reg %load-context-datastack
- temp-reg [] bootstrap-cell ADD
- temp-reg temp-reg [] MOV
+ temp-reg "ctx" %vm-field
+ temp-reg "datastack" context-field-offset [+] bootstrap-cell ADD
+ temp-reg temp-reg "datastack" context-field-offset [+] MOV
temp-reg [] int-regs return-reg MOV ;
M: x86 %epilogue ( n -- ) cell - incr-stack-reg ;
M:: x86 %restore-context ( temp1 temp2 -- )
#! Load Factor stack pointers on entry from C to Factor.
#! Also save callstack bottom!
- temp1 "ctx" %vm-field-ptr
- temp1 temp1 [] MOV
+ temp1 "ctx" %vm-field
temp2 stack-reg stack-frame get total-size>> cell - [+] LEA
temp1 "callstack-bottom" context-field-offset [+] temp2 MOV
ds-reg temp1 "datastack" context-field-offset [+] MOV
#! Save Factor stack pointers in case the C code calls a
#! callback which does a GC, which must reliably trace
#! all roots.
- temp1 "ctx" %vm-field-ptr
- temp1 temp1 [] MOV
+ temp1 "ctx" %vm-field
temp2 stack-reg cell neg [+] LEA
temp1 "callstack-top" context-field-offset [+] temp2 MOV
temp1 "datastack" context-field-offset [+] ds-reg MOV
IN: db.errors
ERROR: db-error ;
-ERROR: sql-error location ;
+TUPLE: sql-error location ;
ERROR: bad-schema ;
-ERROR: sql-unknown-error < sql-error message ;
+TUPLE: sql-unknown-error < sql-error message ;
: <sql-unknown-error> ( message -- error )
\ sql-unknown-error new
swap >>message ;
-ERROR: sql-table-exists < sql-error table ;
+TUPLE: sql-table-exists < sql-error table ;
: <sql-table-exists> ( table -- error )
\ sql-table-exists new
swap >>table ;
-ERROR: sql-table-missing < sql-error table ;
+TUPLE: sql-table-missing < sql-error table ;
: <sql-table-missing> ( table -- error )
\ sql-table-missing new
swap >>table ;
-ERROR: sql-syntax-error < sql-error message ;
+TUPLE: sql-syntax-error < sql-error message ;
: <sql-syntax-error> ( message -- error )
\ sql-syntax-error new
swap >>message ;
-ERROR: sql-function-exists < sql-error message ;
+TUPLE: sql-function-exists < sql-error message ;
: <sql-function-exists> ( message -- error )
\ sql-function-exists new
swap >>message ;
-ERROR: sql-function-missing < sql-error message ;
+TUPLE: sql-function-missing < sql-error message ;
: <sql-function-missing> ( message -- error )
\ sql-function-missing new
swap >>message ;
;EBNF
-ERROR: parse-postgresql-location column line text ;
+TUPLE: parse-postgresql-location column line text ;
C: <parse-postgresql-location> parse-postgresql-location
EBNF: parse-postgresql-line-error
ERROR: sqlite-error < db-error n string ;
ERROR: sqlite-sql-error < sql-error n string ;
-: <sqlite-sql-error> ( n string -- error )
- \ sqlite-sql-error new
- swap >>string
- swap >>n ;
-
: throw-sqlite-error ( n -- * )
dup sqlite-error-messages nth sqlite-error ;
: sqlite-statement-error ( -- * )
SQLITE_ERROR
- db-connection get handle>> sqlite3_errmsg <sqlite-sql-error> throw ;
+ db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
: sqlite-check-result ( n -- )
{
-! 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
: restart. ( restart n -- )
[
- 1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
+ 1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
name>> %
] "" make print ;
def>> . ;
M: undefined summary
- drop "Calling a deferred word before it has been defined" ;
+ word>> undefined?
+ "Cannot execute a deferred word before it has been defined"
+ "Cannot execute a word before it has been compiled"
+ ? ;
M: no-compilation-unit error.
"Attempting to define " write
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" ;
M: not-found-in-roots summary drop "Cannot resolve vocab: path" ;
-M: wrong-values summary drop "Quotation called with wrong stack effect" ;
+M: wrong-values summary drop "Quotation's stack effect does not match call site" ;
M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ;
[ class>> swap first create-method dup fake-definition ] keep
[ drop ] [ "consultation" set-word-prop ] 2bi ;
-PREDICATE: consult-method < method-body "consultation" word-prop ;
+PREDICATE: consult-method < method "consultation" word-prop ;
M: consult-method reset-word
[ call-next-method ] [ f "consultation" set-word-prop ] bi ;
(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
}
send-response ;
: serving? ( path -- ? )
- normalize-path server get serving-directory>> head? ;
+ resolve-symlinks server get serving-directory>> head? ;
: can-serve-directory? ( path -- ? )
{ [ exists? ] [ file-info directory? ] [ serving? ] } 1&& ;
: <ftp-server> ( directory port -- server )
latin1 ftp-server new-threaded-server
swap >>insecure
- swap normalize-path >>serving-directory
+ swap resolve-symlinks >>serving-directory
"ftp.server" >>name
5 minutes >>timeout ;
[ [ (fake-quotations>) ] each ] { } make , ;
M: fake-call-next-method (fake-quotations>)
- drop method-body get literalize , \ (call-next-method) , ;
+ drop \ method get literalize , \ (call-next-method) , ;
M: object (fake-quotations>) , ;
FUNCTOR-SYNTAX: M:
scan-param suffix!
scan-param suffix!
- [ create-method-in dup method-body set ] append!
+ [ create-method-in dup \ method set ] append!
parse-definition*
\ define* suffix! ;
action new-action ;\r
\r
: merge-forms ( form -- )\r
- form get\r
- [ [ errors>> ] bi@ push-all ]\r
- [ [ values>> ] bi@ swap update ]\r
- [ swap validation-failed>> >>validation-failed drop ]\r
+ [ form get ] dip\r
+ [ [ errors>> ] bi@ append! drop ]\r
+ [ [ values>> ] bi@ assoc-union! drop ]\r
+ [ validation-failed>> >>validation-failed drop ]\r
2tri ;\r
\r
: set-nested-form ( form name -- )\r
XML> body>> clone ;
: add-tag-attrs ( attrs tag -- )
- attrs>> swap update ;
+ attrs>> swap assoc-union! drop ;
CHLOE: button
button-tag-markup
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 ;
{ $table
{ "General form" "Description" "Examples" }
{ { $snippet { $emphasis "foo" } "?" } "outputs a boolean" { { $link empty? } } }
+ { { $snippet { $emphasis "foo" } "!" } { "a variant of " { $snippet "foo" } " which mutates one of its arguments" } { { $link append! } } }
{ { $snippet "?" { $emphasis "foo" } } { "conditionally performs " { $snippet { $emphasis "foo" } } } { { $links ?nth } } }
{ { $snippet "<" { $emphasis "foo" } ">" } { "creates a new " { $snippet "foo" } } { { $link <array> } } }
{ { $snippet ">" { $emphasis "foo" } } { "converts the top of the stack into a " { $snippet "foo" } } { { $link >array } } }
USING: accessors arrays assocs byte-arrays byte-vectors classes
combinators definitions effects fry generic generic.single
generic.standard hashtables io.binary io.streams.string kernel
-kernel.private math math.integers.private math.parser math.parser.private
+kernel.private math math.integers.private math.parser
namespaces parser sbufs sequences splitting splitting.private strings
vectors words ;
IN: hints
: 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* ;
: standard-method? ( method -- ? )
- dup method-body? [
+ dup method? [
"method-generic" word-prop standard-generic?
] [ drop f ] if ;
M\ hashtable set-at { { object fixnum object } { object word object } } "specializer" set-word-prop
-\ dec>float { string } "specializer" set-word-prop
-
-\ hex>float { string } "specializer" set-word-prop
-
-\ string>integer { string fixnum } "specializer" set-word-prop
-
\ bignum/f { { bignum bignum } { bignum fixnum } { fixnum bignum } { fixnum fixnum } } "specializer" set-word-prop
[ [ value ] keep ] dip ; inline
: from-object ( object -- )
- [ values ] [ make-mirror ] bi* update ;
+ [ values ] [ make-mirror ] bi* assoc-union! drop ;
: to-object ( destination names -- )
- [ make-mirror ] [ values extract-keys ] bi* update ;
+ [ make-mirror ] [ values extract-keys ] bi* assoc-union! drop ;
: with-each-value ( name quot -- )
[ value ] dip '[
! 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 BGR and 32-bit uncompressed BGRA 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 = [ BGR ] [ BGRA ] 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>> { BGRA BGRA } 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>>
+ {
+ { BGR [ B{ 24 } write ] }
+ { BGRA [ B{ 32 } write ] }
+ } case
+ ]
+ [
+ dup component-order>>
+ {
+ { BGR [ 0 ] }
+ { BGRA [ 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:"
tools.test io.launcher arrays io namespaces continuations math
io.encodings.binary io.encodings.ascii accessors kernel
sequences io.encodings.utf8 destructors io.streams.duplex locals
-concurrency.promises threads unix.process calendar ;
+concurrency.promises threads unix.process calendar unix ;
[ ] [
[ "launcher-test-1" temp-file delete-file ] ignore-errors
[ p fulfill ] [ wait-for-process s fulfill ] bi
] in-thread
- p 1 seconds ?promise-timeout handle>> 9 kill drop
+ p 1 seconds ?promise-timeout handle>> kill-process*
s ?promise 0 =
]
] unit-test
TUPLE: signal n ;
: code>status ( code -- obj )
- dup WIFEXITED [ WEXITSTATUS ] [ WTERMSIG signal boa ] if ;
+ dup WIFSIGNALED [ WTERMSIG signal boa ] [ WEXITSTATUS ] if ;
M: unix wait-for-processes ( -- ? )
0 <int> -1 over WNOHANG waitpid
-! 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"
}
+USING: kernel vocabs.loader ;
IN: json
-USE: vocabs.loader
SINGLETON: json-null
+: if-json-null ( x if-null else -- )
+ [ dup json-null? ]
+ [ [ drop ] prepose ]
+ [ ] tri* if ; inline
+
+: when-json-null ( x if-null -- ) [ ] if-json-null ; inline
+: unless-json-null ( x else -- ) [ ] swap if-json-null ; inline
+
"json.reader" require
"json.writer" require
! Copyright (C) 2008 Peter Burns, 2009 Philipp Winkler
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs combinators io io.streams.string json
-kernel math math.parser prettyprint
-sequences strings vectors ;
+kernel math math.parser prettyprint sequences strings vectors ;
IN: json.reader
<PRIVATE
: value ( char -- num char )
1string " \t\r\n,:}]" read-until
- [
- append
- [ string>float ]
- [ [ "eE." index ] any? [ >integer ] unless ] bi
- ] dip ;
+ [ append string>number ] dip ;
DEFER: j-string
: errno ( -- int )
int "factor" "err_no" { } alien-invoke ;
+: set-errno ( int -- )
+ void "factor" "set_err_no" { int } alien-invoke ;
+
: clear-errno ( -- )
- void "factor" "clear_err_no" { } alien-invoke ;
+ 0 set-errno ;
+
+: preserve-errno ( quot -- )
+ errno [ call ] dip set-errno ; inline
<PRIVATE
"arrays"
"assocs"
"combinators"
- "compiler"
"compiler.errors"
"compiler.units"
"continuations"
"tools.test"
"tools.threads"
"tools.time"
+ "tools.walker"
"vocabs"
"vocabs.loader"
"vocabs.refresh"
: 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
M: lambda-macro reset-word
[ call-next-method ] [ f "lambda" set-word-prop ] bi ;
-INTERSECTION: lambda-method method-body lambda-word ;
+INTERSECTION: lambda-method method lambda-word ;
M: lambda-method definer drop \ M:: \ ; ;
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
-IN: macros.tests
USING: tools.test macros math kernel arrays
-vectors io.streams.string prettyprint parser eval see ;
+vectors io.streams.string prettyprint parser eval see
+stack-checker compiler.units definitions vocabs ;
+IN: macros.tests
MACRO: see-test ( a b -- quot ) + ;
[ f ] [ \ see-test macro? ] unit-test
-[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
+[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ;" eval( -- ) ] unit-test
+[ ] [ "USING: macros kernel ; IN: hanging-macro : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
+
+[ ] [ [ "hanging-macro" forget-vocab ] with-compilation-unit ] 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
+
+! The macro expander code should infer
+MACRO: bad-macro ( a -- b ) 1 2 3 [ ] ;
+
+! Must fail twice, and not memoize a bad result
+[ [ 0 bad-macro ] call ] must-fail
+[ [ 0 bad-macro ] call ] must-fail
+
+[ [ 0 bad-macro ] infer ] must-fail
+[ ] [ [ \ bad-macro forget ] with-compilation-unit ] unit-test
-! 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
+definitions quotations namespaces memoize accessors fry
compiler.units ;
IN: macros
: define-macro ( word definition effect -- )
real-macro-effect {
- [ [ memoize-quot [ call ] append ] keep define-declared ]
+ [
+ [ '[ _ _ call-effect ] ] keep
+ [ memoize-quot '[ @ call ] ] keep
+ define-declared
+ ]
[ drop "macro" set-word-prop ]
[ 2drop changed-effect ]
} 3cleave ;
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 ;
HELP: q+
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u+v" "a quaternion" } }
{ $description "Add quaternions." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q+ ." "{ C{ 0 1 } 1 }" } } ;
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 1 0 0 } { 0 0 1 0 } q+ ." "{ 0 1 1 0 }" } } ;
HELP: q-
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u-v" "a quaternion" } }
{ $description "Subtract quaternions." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q- ." "{ C{ 0 1 } -1 }" } } ;
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 1 0 0 } { 0 0 1 0 } q- ." "{ 0 1 -1 0 }" } } ;
HELP: q*
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u*v" "a quaternion" } }
{ $description "Multiply quaternions." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } { 0 1 } q* ." "{ 0 C{ 0 1 } }" } } ;
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 1 0 0 } { 0 0 1 0 } q* ." "{ 0 0 0 1 }" } } ;
HELP: qconjugate
{ $values { "u" "a quaternion" } { "u'" "a quaternion" } }
HELP: q/
{ $values { "u" "a quaternion" } { "v" "a quaternion" } { "u/v" "a quaternion" } }
{ $description "Divide quaternions." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 C{ 0 1 } } { 0 1 } q/ ." "{ C{ 0 1 } 0 }" } } ;
+{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 0 0 0 1 } { 0 0 1 0 } q/ ." "{ 0 1 0 0 }" } } ;
HELP: q*n
-{ $values { "q" "a quaternion" } { "n" number } { "q" "a quaternion" } }
-{ $description "Multiplies each element of " { $snippet "q" } " by " { $snippet "n" } "." }
-{ $notes "You will get the wrong result if you try to multiply a quaternion by a complex number on the right using " { $link v*n } ". Use this word instead."
- $nl "Note that " { $link v*n } " with a quaternion and a real is okay." } ;
+{ $values { "q" "a quaternion" } { "n" real } { "q" "a quaternion" } }
+{ $description "Multiplies each element of " { $snippet "q" } " by real value " { $snippet "n" } "." }
+{ $notes "To multiply a quaternion with a complex value, use " { $link c>q } " " { $link q* } "." } ;
HELP: c>q
{ $values { "c" number } { "q" "a quaternion" } }
{ $description "Turn a complex number into a quaternion." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "C{ 0 1 } c>q ." "{ C{ 0 1 } 0 }" } } ;
-
-HELP: v>q
-{ $values { "v" vector } { "q" "a quaternion" } }
-{ $description "Turn a 3-vector into a quaternion with real part 0." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ 1 0 0 } v>q ." "{ C{ 0 1 } 0 }" } } ;
-
-HELP: q>v
-{ $values { "q" "a quaternion" } { "v" vector } }
-{ $description "Get the vector part of a quaternion, discarding the real part." }
-{ $examples { $example "USING: math.quaternions prettyprint ;" "{ C{ 0 1 } 0 } q>v ." "{ 1 0 0 }" } } ;
+{ $examples { $example "USING: math.quaternions prettyprint ;" "C{ 0 1 } c>q ." "{ 0 1 0 0 }" } } ;
HELP: euler
{ $values { "phi" number } { "theta" number } { "psi" number } { "q" "a quaternion" } }
USING: tools.test math.quaternions kernel math.vectors
math.constants ;
+CONSTANT: q0 { 0 0 0 0 }
+CONSTANT: q1 { 1 0 0 0 }
+CONSTANT: qi { 0 1 0 0 }
+CONSTANT: qj { 0 0 1 0 }
+CONSTANT: qk { 0 0 0 1 }
+
[ 1.0 ] [ qi norm ] unit-test
[ 1.0 ] [ qj norm ] unit-test
[ 1.0 ] [ qk norm ] unit-test
[ t ] [ qi qj q* qk = ] unit-test
[ t ] [ qj qk q* qi = ] unit-test
[ t ] [ qk qi q* qj = ] unit-test
-[ t ] [ qi qi q* q1 v+ q0 = ] unit-test
-[ t ] [ qj qj q* q1 v+ q0 = ] unit-test
-[ t ] [ qk qk q* q1 v+ q0 = ] unit-test
-[ t ] [ qi qj qk q* q* q1 v+ q0 = ] unit-test
-[ t ] [ C{ 0 1 } qj n*v qk = ] unit-test
-[ t ] [ qj C{ 0 1 } q*n qk v+ q0 = ] unit-test
+[ t ] [ qi qi q* q1 q+ q0 = ] unit-test
+[ t ] [ qj qj q* q1 q+ q0 = ] unit-test
+[ t ] [ qk qk q* q1 q+ q0 = ] unit-test
+[ t ] [ qi qj qk q* q* q1 q+ q0 = ] unit-test
[ t ] [ qk qj q/ qi = ] unit-test
[ t ] [ qi qk q/ qj = ] unit-test
[ t ] [ qj qi q/ qk = ] unit-test
-[ t ] [ qi q>v v>q qi = ] unit-test
-[ t ] [ qj q>v v>q qj = ] unit-test
-[ t ] [ qk q>v v>q qk = ] unit-test
[ t ] [ 1 c>q q1 = ] unit-test
[ t ] [ C{ 0 1 } c>q qi = ] unit-test
[ t ] [ qi qi q+ qi 2 q*n = ] unit-test
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions math.vectors sequences ;
+USING: arrays combinators kernel locals math math.functions
+math.libm math.order math.vectors sequences ;
IN: math.quaternions
-! Everybody's favorite non-commutative skew field, the quaternions!
+: q+ ( u v -- u+v )
+ v+ ; inline
-! Quaternions are represented as pairs of complex numbers, using the
-! identity: (a+bi)+(c+di)j = a+bi+cj+dk.
+: q- ( u v -- u-v )
+ v- ; inline
<PRIVATE
-: ** ( x y -- z ) conjugate * ; inline
-
-: 2q ( u v -- u' u'' v' v'' ) [ first2 ] bi@ ; inline
-
-: q*a ( u v -- a ) 2q swapd ** [ * ] dip - ; inline
-
-: q*b ( u v -- b ) 2q [ ** swap ] dip * + ; inline
+GENERIC: (q*sign) ( q -- q' )
+M: object (q*sign) { -1 1 1 1 } v* ; inline
PRIVATE>
-: q+ ( u v -- u+v )
- v+ ;
-
-: q- ( u v -- u-v )
- v- ;
-
: q* ( u v -- u*v )
- [ q*a ] [ q*b ] 2bi 2array ;
+ {
+ [ [ { 1 0 0 0 } vshuffle ] [ { 1 1 2 3 } vshuffle ] bi* v* ]
+ [ [ { 2 1 2 3 } vshuffle ] [ { 2 0 0 0 } vshuffle ] bi* v* v+ ]
+ [ [ { 3 2 3 1 } vshuffle ] [ { 3 3 1 2 } vshuffle ] bi* v* v+ ]
+ [ [ { 0 3 1 2 } vshuffle ] [ { 0 2 3 1 } vshuffle ] bi* v* v- ]
+ } 2cleave (q*sign) ; inline
-: qconjugate ( u -- u' )
- first2 [ conjugate ] [ neg ] bi* 2array ;
+GENERIC: qconjugate ( u -- u' )
+M: object qconjugate ( u -- u' )
+ { 1 -1 -1 -1 } v* ; inline
: qrecip ( u -- 1/u )
- qconjugate dup norm-sq v/n ;
+ qconjugate dup norm-sq v/n ; inline
: q/ ( u v -- u/v )
- qrecip q* ;
+ qrecip q* ; inline
-: q*n ( q n -- q )
- conjugate v*n ;
+: n*q ( q n -- q )
+ v*n ; inline
-: c>q ( c -- q )
- 0 2array ;
+: q*n ( q n -- q )
+ v*n ; inline
-: v>q ( v -- q )
- first3 rect> [ 0 swap rect> ] dip 2array ;
+: n>q ( n -- q )
+ 0 0 0 4array ; inline
-: q>v ( q -- v )
- first2 [ imaginary-part ] dip >rect 3array ;
+: n>q-like ( c exemplar -- q )
+ [ 0 0 0 ] dip 4sequence ; inline
-! Zero
-CONSTANT: q0 { 0 0 }
+: c>q ( c -- q )
+ >rect 0 0 4array ; inline
-! Units
-CONSTANT: q1 { 1 0 }
-CONSTANT: qi { C{ 0 1 } 0 }
-CONSTANT: qj { 0 1 }
-CONSTANT: qk { 0 C{ 0 1 } }
+: c>q-like ( c exemplar -- q )
+ [ >rect 0 0 ] dip 4sequence ; inline
! Euler angles
<PRIVATE
-: (euler) ( theta unit -- q )
- [ -0.5 * [ cos c>q ] [ sin ] bi ] dip n*v v- ;
+: (euler) ( theta exemplar shuffle -- q )
+ swap
+ [ 0.5 * [ fcos ] [ fsin ] bi 0.0 0.0 ] [ call ] [ 4sequence ] tri* ; inline
PRIVATE>
+: euler-like ( phi theta psi exemplar -- q )
+ [ [ ] (euler) ] [ [ swapd ] (euler) ] [ [ rot ] (euler) ] tri-curry tri* q* q* ; inline
+
: euler ( phi theta psi -- q )
- [ qi (euler) ] [ qj (euler) ] [ qk (euler) ] tri* q* q* ;
+ { } euler-like ; inline
+
+:: slerp ( q0 q1 t -- qt )
+ q0 q1 v. -1.0 1.0 clamp :> dot
+ dot facos t * :> omega
+ q1 dot q0 n*v v- normalize :> qt'
+ omega fcos q0 n*v omega fsin qt' n*v v+ ; inline
-! 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
[ "-10/2" string>number ]
unit-test
-[ -5 ]
+[ f ]
[ "10/-2" string>number ]
unit-test
-[ 5 ]
+[ f ]
[ "-10/-2" string>number ]
unit-test
+
[ "33/100" ]
[ "66/200" string>number number>string ]
unit-test
}
{ $description "Returns a hashtable where the keys are the elements of the sequence and the values are the number of times they appeared in that sequence." } ;
-HELP: histogram*
+HELP: histogram!
{ $values
{ "hashtable" hashtable } { "seq" sequence }
{ "hashtable" hashtable }
{ $examples
{ $example "! Count the number of times the elements of two sequences appear."
"USING: prettyprint math.statistics ;"
- "\"aaabc\" histogram \"aaaaaabc\" histogram* ."
+ "\"aaabc\" histogram \"aaaaaabc\" histogram! ."
"H{ { 97 9 } { 98 2 } { 99 2 } }"
}
}
}
{ $description "Iterates over a sequence, allowing elements of the sequence to be added to a newly created " { $snippet "assoc" } " according to the passed quotation." } ;
-HELP: sequence>assoc*
+HELP: sequence>assoc!
{ $values
{ "assoc" assoc } { "seq" sequence } { "quot" quotation }
{ "assoc" assoc }
{ $examples
{ $example "! Iterate over a sequence and add the counts to an existing assoc"
"USING: assocs prettyprint math.statistics kernel ;"
- "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc* ."
+ "H{ { 97 2 } { 98 1 } } clone \"aaabc\" [ inc-at ] sequence>assoc! ."
"H{ { 97 5 } { 98 2 } { 99 1 } }"
}
}
"Counting elements in a sequence:"
{ $subsections
histogram
- histogram*
+ histogram!
sorted-histogram
}
"Combinators for implementing histogram:"
{ $subsections
sequence>assoc
- sequence>assoc*
+ sequence>assoc!
sequence>hashtable
} ;
PRIVATE>
-: sequence>assoc* ( assoc seq quot: ( obj assoc -- ) -- assoc )
+: sequence>assoc! ( assoc seq quot: ( obj assoc -- ) -- assoc )
rot (sequence>assoc) ; inline
: sequence>assoc ( seq quot: ( obj assoc -- ) exemplar -- assoc )
: sequence>hashtable ( seq quot: ( obj hashtable -- ) -- hashtable )
H{ } sequence>assoc ; inline
-: histogram* ( hashtable seq -- hashtable )
- [ inc-at ] sequence>assoc* ;
+: histogram! ( hashtable seq -- hashtable )
+ [ inc-at ] sequence>assoc! ;
: histogram ( seq -- hashtable )
[ inc-at ] sequence>hashtable ;
M: word pprint*
[ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
-M: method-body pprint*
+M: method pprint*
[
[
[ "M\\ " % "method-class" word-prop word-name* % ]
M: wrapper pprint*
{
- { [ dup wrapped>> method-body? ] [ wrapped>> pprint* ] }
+ { [ dup wrapped>> method? ] [ wrapped>> pprint* ] }
{ [ dup wrapped>> word? ] [ <block \ \ pprint-word wrapped>> pprint-word block> ] }
[ pprint-object ]
} cond ;
-! Copyright (C) 2003, 2009 Slava Pestov.
+! Copyright (C) 2003, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays accessors assocs colors combinators grouping io
io.streams.string io.styles kernel make math math.parser namespaces
parser prettyprint.backend prettyprint.config prettyprint.custom
prettyprint.sections quotations sequences sorting strings vocabs
-vocabs.prettyprint words sets ;
+vocabs.prettyprint words sets generic ;
IN: prettyprint
: with-use ( obj quot -- )
] [ ] make ;
: remove-breakpoints ( quot pos -- quot' )
- over quotation? [
- 1 + short cut [ (remove-breakpoints) ] bi@
- [ -> ] glue
- ] [
- drop
- ] if ;
+ 1 + short cut [ (remove-breakpoints) ] bi@ [ -> ] glue ;
+
+: optimized-frame? ( triple -- ? ) second word? ;
+
+: frame-word? ( triple -- ? )
+ first word? ;
+
+: frame-word. ( triple -- )
+ first {
+ { [ dup method? ] [ "Method: " write pprint ] }
+ { [ dup word? ] [ "Word: " write pprint ] }
+ [ drop ]
+ } cond ;
+
+: optimized-frame. ( triple -- )
+ [
+ [ "(O)" write ] with-cell
+ [ frame-word. ] with-cell
+ ] with-row ;
+
+: unoptimized-frame. ( triple -- )
+ [
+ [ "(U)" write ] with-cell
+ [
+ "Quotation: " write
+ dup [ second ] [ third ] bi remove-breakpoints
+ [
+ 3 nesting-limit set
+ 100 length-limit set
+ pprint
+ ] with-scope
+ ] with-cell
+ ] with-row
+ dup frame-word? [
+ [
+ [ ] with-cell
+ [ frame-word. ] with-cell
+ ] with-row
+ ] [ drop ] if ;
+
+: callframe. ( triple -- )
+ dup optimized-frame?
+ [ optimized-frame. ] [ unoptimized-frame. ] if ;
PRIVATE>
: callstack. ( callstack -- )
- callstack>array 2 <groups> [
- remove-breakpoints
- [
- 3 nesting-limit set
- 100 length-limit set
- .
- ] with-scope
- ] assoc-each ;
+ callstack>array 3 <groups>
+ { { table-gap { 5 5 } } } [ [ callframe. ] each ] tabular-output nl ;
: .c ( -- ) callstack callstack. ;
}
{ $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
[
unify-final-state renumber-states box-transitions
[ start-state>> ]
[ final-states>> keys first ]
- [ nfa-table get [ transitions>> ] bi@ swap update ] tri ;
+ [ nfa-table get [ transitions>> ] bi@ swap assoc-union! drop ] tri ;
: ast>dfa ( parse-tree -- minimal-dfa )
construct-nfa disambiguate construct-dfa minimize ;
[ stack-effect. ]
} cleave ;
-M: method-body synopsis*
+M: method synopsis*
[ definer. ]
[ "method-class" word-prop pprint-word ]
[ "method-generic" word-prop pprint-word ] tri ;
: deserialize-hashtable ( -- hashtable )
H{ } clone
[ intern-object ]
- [ (deserialize) update ]
+ [ (deserialize) assoc-union! drop ]
[ ] tri ;
: copy-seq-to-tuple ( seq tuple -- )
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.parser assocs
-compiler.units functors growable kernel lexer namespaces parser
+compiler.units functors growable kernel lexer math namespaces parser
prettyprint.custom sequences specialized-arrays
specialized-arrays.private strings vocabs vocabs.parser
vocabs.generated fry make ;
M: V contract 2drop ; inline
-M: V byte-length underlying>> byte-length ; inline
+M: V byte-length length \ T heap-size * ; inline
M: V pprint-delims drop \ V{ \ } ;
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 ] }
\ bignum>float { bignum } { float } define-primitive
\ bignum>float make-foldable
-\ (string>float) { byte-array } { float } define-primitive
-\ (string>float) make-foldable
-
\ (float>string) { float } { byte-array } define-primitive
\ (float>string) make-foldable
\ data-room { } { byte-array } define-primitive
\ data-room make-flushable
+\ (code-blocks) { } { array } define-primitive
+\ (code-blocks) make-flushable
+
\ code-room { } { byte-array } define-primitive
\ code-room make-flushable
\ dll-valid? { object } { object } define-primitive
-\ modify-code-heap { array } { } define-primitive
+\ modify-code-heap { array object object } { } define-primitive
\ unimplemented { } { } define-primitive
"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
\ bad-macro [ "OOPS" throw ] 0 define-transform
-[ [ bad-macro ] infer ] [ f >>continuation T{ transform-expansion-error f "OOPS" f bad-macro } = ] must-fail-with
+[ [ bad-macro ] infer ] [ [ transform-expansion-error? ] [ error>> "OOPS" = ] [ word>> \ bad-macro = ] tri and and ] must-fail-with
MACRO: two-params ( a b -- c ) + 1quotation ;
\ 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
[ { "A BB" "CC D" } ] [ { { "A" "BB" } { "CC" "D" } } format-table ] unit-test
-[ { "A C" "B " "D E" } ] [ { { "A\nB" "C" } { "D" "E" } } format-table ] unit-test
\ No newline at end of file
+[ { "A C" "B " "D E" } ] [ { { "A\nB" "C" } { "D" "E" } } format-table ] unit-test
+
+[ { "A B" " C" "D E" } ] [ { { "A" "B\nC" } { "D" "E" } } format-table ] unit-test
+
+[ { "A B" "C D" " E" } ] [ { { "A" "B" } { "C" "D\nE" } } format-table ] unit-test
\ No newline at end of file
: max-length ( seq -- n )
[ length ] [ max ] map-reduce ;
-: format-row ( seq ? -- seq )
- [
- dup max-length
- '[ _ "" pad-tail ] map
- ] unless ;
+: format-row ( seq -- seq )
+ dup max-length
+ '[ _ "" pad-tail ] map ;
: format-column ( seq ? -- seq )
[
PRIVATE>
: format-table ( table -- seq )
- [ [ [ string-lines ] map ] dip format-row flip ] map-last concat
+ [ [ string-lines ] map format-row flip ] map concat
flip [ format-column ] map-last flip [ " " join ] map ;
\ No newline at end of file
M: object smart-usage usage [ irrelevant? not ] filter ;
-M: method-body smart-usage "method-generic" word-prop smart-usage ;
+M: method smart-usage "method-generic" word-prop smart-usage ;
M: f smart-usage drop \ f smart-usage ;
[ [ vocab-name ] [ words [ generic? not ] filter ] bi ] dip map
[
[ [ word? ] [ generic? not ] bi and ] filter [
- dup method-body?
+ dup method?
[ "method-generic" word-prop ] when
vocabulary>>
] map
-! 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
: strip-word-props ( stripped-props words -- )
"Stripping word properties" show
- [
- swap '[
- [
- [ drop _ member? not ] assoc-filter sift-assoc
- >alist f like
- ] change-props drop
- ] each
- ] [
- H{ } clone '[
- [ [ _ [ ] cache ] map ] change-props drop
- ] each
- ] bi ;
+ swap '[
+ [
+ [ drop _ member? not ] assoc-filter sift-assoc
+ >alist f like
+ ] change-props drop
+ ] each ;
: stripped-word-props ( -- seq )
[
"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) 2008, 2010 Slava Pestov, Jorge Acereda Macia.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.disassembler namespaces combinators
-alien alien.syntax alien.c-types lexer parser kernel
-sequences layouts math math.order alien.libraries
-math.parser system make fry arrays libc destructors
-tools.disassembler.utils tools.disassembler.private splitting
-alien.data classes.struct ;
+USING: tools.disassembler namespaces combinators alien
+alien.syntax alien.c-types lexer parser kernel sequences layouts
+math math.order alien.libraries math.parser system make fry
+arrays libc destructors tools.memory tools.disassembler.utils
+tools.disassembler.private splitting alien.data classes.struct ;
IN: tools.disassembler.udis
<<
dup UD_SYN_INTEL ud_set_syntax ;
: with-ud ( quot: ( ud -- ) -- )
- [ [ [ <ud> ] dip call ] with-destructors ] with-word-entry-points ; inline
+ [ [ [ <ud> ] dip call ] with-destructors ] with-code-blocks ; inline
SINGLETON: udis-disassembler
-USING: accessors arrays binary-search kernel math math.order
-math.parser namespaces sequences sorting splitting vectors vocabs words ;
+USING: accessors kernel math math.parser prettyprint sequences
+splitting tools.memory ;
IN: tools.disassembler.utils
-SYMBOL: word-entry-points
-SYMBOL: smallest-xt
-SYMBOL: greatest-xt
-
-: (word-entry-points) ( -- assoc )
- vocabs [ words ] map concat [ [ word-code ] keep 3array ] map
- [ first ] sort-with ;
+: 0x ( str -- str' ) "0x" prepend ;
: complete-address ( n seq -- str )
- [ first - ] [ third name>> ] bi
- over zero? [ nip ] [ swap 16 >base "0x" prepend "+" glue ] if ;
+ [ nip owner>> unparse-short ] [ entry-point>> - ] 2bi
+ [ 16 >base 0x " + " glue ] unless-zero ;
-: search-xt ( n -- str/f )
- dup [ smallest-xt get < ] [ greatest-xt get > ] bi or [
- drop f
- ] [
- word-entry-points get over [ swap first <=> ] curry search nip
- 2dup second <= [
- [ complete-address ] [ drop f ] if*
- ] [
- 2drop f
- ] if
- ] if ;
+: search-xt ( addr -- str/f )
+ dup lookup-return-address
+ dup [ complete-address ] [ 2drop f ] if ;
: resolve-xt ( str -- str' )
- [ "0x" prepend ] [ 16 base> ] bi
+ [ 0x ] [ 16 base> ] bi
[ search-xt [ " (" ")" surround append ] when* ] when* ;
: resolve-call ( str -- str' )
"0x" split1-last [ resolve-xt "0x" glue ] when* ;
-
-: with-word-entry-points ( quot -- )
- [
- (word-entry-points)
- [ word-entry-points set ]
- [ first first smallest-xt set ]
- [ last second greatest-xt set ] tri
- call
- ] with-scope ; inline
-! Copyright (C) 2005, 2009 Slava Pestov.
+! Copyright (C) 2005, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays assocs classes classes.struct
-combinators combinators.smart continuations fry generalizations
-generic grouping io io.styles kernel make math math.parser
-math.statistics memory namespaces parser prettyprint sequences
-sorting splitting strings system vm words ;
+USING: accessors arrays assocs binary-search classes
+classes.struct combinators combinators.smart continuations fry
+generalizations generic grouping io io.styles kernel make math
+math.order math.parser math.statistics memory memory.private
+layouts namespaces parser prettyprint sequences sorting
+splitting strings system vm words hints hashtables ;
IN: tools.memory
<PRIVATE
{ "Mark stack:" [ mark-stack>> kilobytes ] }
} object-table. ;
+PRIVATE>
+
: data-room. ( -- )
"== Data heap ==" print nl
data-room data-heap-room memory>struct {
[ misc-room. ]
} cleave ;
-: code-room. ( -- )
- "== Code heap ==" print nl
- code-room mark-sweep-sizes memory>struct mark-sweep-table. ;
-
-PRIVATE>
-
-: room. ( -- ) data-room. nl code-room. ;
-
<PRIVATE
: heap-stat-step ( obj counts sizes -- )
{ "Code heap sweep time:" [ [ code-sweep-time>> ] map-sum nanos>string ] }
{ "Compaction time:" [ [ compaction-time>> ] map-sum nanos>string ] }
} object-table. ;
+
+SINGLETONS: +unoptimized+ +optimized+ +profiling+ +pic+ ;
+
+TUPLE: code-block
+{ owner read-only }
+{ parameters read-only }
+{ relocation read-only }
+{ type read-only }
+{ size read-only }
+{ entry-point read-only } ;
+
+TUPLE: code-blocks { blocks sliced-groups } { cache hashtable } ;
+
+<PRIVATE
+
+: code-block-type ( n -- type )
+ { +unoptimized+ +optimized+ +profiling+ +pic+ } nth ;
+
+: <code-block> ( seq -- code-block )
+ 6 firstn-unsafe {
+ [ ]
+ [ ]
+ [ ]
+ [ code-block-type ]
+ [ ]
+ [ tag-bits get shift ]
+ } spread code-block boa ; inline
+
+: <code-blocks> ( seq -- code-blocks )
+ 6 <sliced-groups> H{ } clone \ code-blocks boa ;
+
+SYMBOL: code-heap-start
+SYMBOL: code-heap-end
+
+: in-code-heap? ( address -- ? )
+ code-heap-start get code-heap-end get between? ;
+
+: (lookup-return-address) ( addr seq -- code-block )
+ [ entry-point>> <=> ] with search nip ;
+
+HINTS: (lookup-return-address) code-blocks ;
+
+PRIVATE>
+
+M: code-blocks length blocks>> length ; inline
+
+FROM: sequences.private => nth-unsafe ;
+
+M: code-blocks nth-unsafe
+ [ cache>> ] [ blocks>> ] bi
+ '[ _ nth-unsafe <code-block> ] cache ; inline
+
+INSTANCE: code-blocks immutable-sequence
+
+: code-blocks ( -- blocks )
+ (code-blocks) <code-blocks> ;
+
+: with-code-blocks ( quot -- )
+ [
+ code-blocks
+ [ \ code-blocks set ]
+ [ first entry-point>> code-heap-start set ]
+ [ last [ entry-point>> ] [ size>> ] bi + code-heap-end set ] tri
+ call
+ ] with-scope ; inline
+
+: lookup-return-address ( addr -- code-block )
+ dup in-code-heap?
+ [ \ code-blocks get (lookup-return-address) ] [ drop f ] if ;
+
+<PRIVATE
+
+: code-block-stats ( code-blocks -- counts sizes )
+ H{ } clone H{ } clone
+ [ '[ [ size>> ] [ type>> ] bi [ nip _ inc-at ] [ _ at+ ] 2bi ] each ]
+ 2keep ;
+
+: blocks ( n -- str ) number>string " blocks" append ;
+
+: code-block-table-row ( string type counts sizes -- triple )
+ [ at 0 or blocks ] [ at 0 or kilobytes ] bi-curry* bi 3array ;
+
+: code-block-table. ( counts sizes -- )
+ [
+ {
+ { "Optimized code:" +optimized+ }
+ { "Unoptimized code:" +unoptimized+ }
+ { "Inline caches:" +pic+ }
+ { "Profiling stubs:" +profiling+ }
+ }
+ ] 2dip '[ _ _ code-block-table-row ] { } assoc>map
+ simple-table. ;
+
+PRIVATE>
+
+: code-room. ( -- )
+ "== Code heap ==" print nl
+ code-room mark-sweep-sizes memory>struct mark-sweep-table. nl
+ code-blocks code-block-stats code-block-table. ;
+
+: room. ( -- )
+ data-room. nl code-room. ;
-Heap introspection tools
+Data and code heap introspection tools
USING: accessors tools.profiler tools.test kernel memory math
threads alien alien.c-types tools.profiler.private sequences
-compiler.test compiler.units words ;
+compiler.test compiler.units words arrays ;
IN: tools.profiler.tests
[ t ] [
\ length counter>> =
] unit-test
-[ ] [ [ 10 [ gc ] times ] profile ] unit-test
+[ ] [ [ 3 [ gc ] times ] profile ] unit-test
[ ] [ [ 1000000 sleep ] profile ] unit-test
[ ] [ [ [ ] compile-call ] profile ] unit-test
-[ [ gensym execute ] profile ] [ T{ undefined } = ] must-fail-with
+[ [ gensym execute ] profile ] [ undefined? ] must-fail-with
: crash-bug-1 ( -- x ) "hi" <uninterned-word> ;
: crash-bug-2 ( -- ) 100000 [ crash-bug-1 drop ] times ;
] profile
counter>>
] unit-test
+
+! unwind_native_frames() would fail if profiling was enabled
+! because the jit-profiling stub would clobber a parameter register
+! on x86-64
+[ [ -10 f <array> ] profile ] must-fail
-! 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>
MACRO: boa-unsafe ( class -- quot ) tuple-layout '[ _ <tuple-boa> ] ;
-MACRO: infer-in ( class -- quot ) inputs '[ _ ] ;
-
-: tuple-arity ( class -- quot ) '[ _ boa ] infer-in ; inline
+: tuple-arity ( class -- quot ) '[ _ boa ] inputs ; inline
: smart-tuple>array ( tuple class -- array )
'[ [ _ boa ] undo ] output>array ; inline
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 ;
{
{ APPCOMMAND_BROWSER_BACKWARD [ pick window left-action send-action ] }
{ APPCOMMAND_BROWSER_FORWARD [ pick window right-action send-action ] }
+ [ drop ]
} case 3drop ;
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
H{ { +nullary+ f } { +listener+ f } { +description+ f } } ;
: define-command ( word hash -- )
- [ props>> ] [ default-flags swap assoc-union ] bi* update ;
+ default-flags swap assoc-union
+ '[ _ assoc-union ] change-props drop ;
: command-quot ( target command -- quot )
[ 1quotation ] [ +nullary+ word-prop ] bi
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors alien core-graphics.types core-text
-core-text.fonts kernel hashtables namespaces sequences
-ui.gadgets.worlds ui.text ui.text.private opengl opengl.gl
-opengl.textures destructors combinators core-foundation
-core-foundation.strings math math.vectors init colors colors.constants
-cache arrays images ;
+core-text.fonts kernel hashtables namespaces sequences ui.text
+ui.text.private destructors combinators core-foundation
+core-foundation.strings math math.vectors init colors
+colors.constants cache arrays images ;
IN: ui.text.core-text
SINGLETON: core-text-renderer
M: core-text-renderer flush-layout-cache
cached-lines get purge-cache ;
-: rendered-line ( font string -- texture )
- world get world-text-handle [
- cached-line [ image>> ] [ loc>> ] bi <texture>
- ] 2cache ;
-
-M: core-text-renderer draw-string ( font string -- )
- rendered-line draw-texture ;
+M: core-text-renderer string>image ( font string -- image loc )
+ cached-line [ image>> ] [ loc>> ] bi ;
M: core-text-renderer x>offset ( x font string -- n )
[ 2drop 0 ] [
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types assocs cache kernel math math.vectors
-namespaces opengl.textures pango.cairo pango.layouts ui.gadgets.worlds
-ui.text ui.text.private pango sequences ;
+USING: accessors assocs cache kernel math math.vectors
+namespaces pango.cairo pango.layouts ui.text ui.text.private
+pango sequences ;
IN: ui.text.pango
SINGLETON: pango-renderer
M: pango-renderer flush-layout-cache
cached-layouts get purge-cache ;
-: rendered-layout ( font string -- texture )
- world get world-text-handle [
- cached-layout [ image>> ] [ text-position vneg ] bi <texture>
- ] 2cache ;
-
-M: pango-renderer draw-string ( font string -- )
- rendered-layout draw-texture ;
+M: pango-renderer string>image ( font string -- image loc )
+ cached-layout [ image>> ] [ text-position vneg ] bi ;
M: pango-renderer x>offset ( x font string -- n )
cached-layout swap x>line-offset ;
IN: ui.text
-USING: help.markup help.syntax kernel ui.text.private strings math fonts ;
+USING: help.markup help.syntax kernel ui.text.private strings math fonts images ;
HELP: string-width
{ $values { "font" font } { "string" string } { "w" "a positive integer" } }
{ $values { "font" font } { "string" string } { "metrics" line-metrics } }
{ $contract "Outputs a " { $link metrics } " object with text measurements." } ;
+HELP: string>image
+{ $values { "font" font } { "string" string } { "image" image } { "loc" "a pair of real numbers" } }
+{ $description "Renders a line of text into an image." } ;
+
ARTICLE: "text-rendering" "Rendering text"
-"The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11."
+"The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X, Uniscribe on Windows and Pango on X11."
{ $subsections "fonts" }
"Measuring text:"
{ $subsections
offset>x
}
"Rendering text:"
-{ $subsections draw-text }
+{ $subsections draw-text string>image }
"Low-level text protocol for UI backends:"
{ $subsections
string-width
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ui.text fonts math accessors kernel sequences ;
+USING: tools.test ui.text images fonts math arrays accessors kernel
+sequences ;
IN: ui.text.tests
[ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test
[ t ] [ sans-serif-font "" text-dim first zero? ] unit-test
[ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test
+
+[ t ] [ serif-font "Hello world" string>image [ image? ] [ pair? ] bi* and ] unit-test
-! Copyright (C) 2009 Slava Pestov.
+! Copyright (C) 2009, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math math.order cache opengl
-opengl.gl strings fonts colors accessors namespaces
-ui.gadgets.worlds ;
+USING: kernel arrays assocs sequences math math.order cache
+opengl opengl.gl opengl.textures strings fonts colors accessors
+namespaces ui.gadgets.worlds ;
IN: ui.text
<PRIVATE
M: object string-height string-dim second ;
-HOOK: draw-string font-renderer ( font string -- )
-
HOOK: free-fonts font-renderer ( world -- )
: combine-text-dim ( dim1 dim2 -- dim3 )
HOOK: line-metrics font-renderer ( font string -- metrics )
+HOOK: string>image font-renderer ( font string -- image loc )
+
+<PRIVATE
+
+: string-empty? ( obj -- ? )
+ dup selection? [ string>> ] when empty? ;
+
+: draw-string ( font string -- )
+ dup string-empty? [ 2drop ] [
+ world get world-text-handle
+ [ string>image <texture> ] 2cache
+ draw-texture
+ ] if ;
+
+PRIVATE>
+
GENERIC: draw-text ( font text -- )
M: string draw-text draw-string ;
-! Copyright (C) 2009 Slava Pestov.\r
+! Copyright (C) 2009, 2010 Slava Pestov.\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: accessors assocs cache kernel math math.vectors sequences fonts\r
-namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds \r
-windows.uniscribe ;\r
+USING: accessors assocs cache kernel math math.vectors sequences\r
+fonts namespaces ui.text ui.text.private windows.uniscribe ;\r
IN: ui.text.uniscribe\r
\r
SINGLETON: uniscribe-renderer\r
M: uniscribe-renderer flush-layout-cache\r
cached-script-strings get purge-cache ;\r
\r
-: rendered-script-string ( font string -- texture )\r
- world get world-text-handle\r
- [ cached-script-string image>> { 0 0 } <texture> ]\r
- 2cache ;\r
-\r
-M: uniscribe-renderer draw-string ( font string -- )\r
- dup dup selection? [ string>> ] when empty?\r
- [ 2drop ] [ rendered-script-string draw-texture ] if ;\r
+M: uniscribe-renderer string>image ( font string -- image loc )\r
+ cached-script-string image>> { 0 0 } ;\r
\r
M: uniscribe-renderer x>offset ( x font string -- n )\r
[ 2drop 0 ] [\r
: method-completion-string ( word -- string )
"method-generic" word-prop present ;
-M: method-body completion-string method-completion-string ;
+M: method completion-string method-completion-string ;
GENERIC# accept-completion-hook 1 ( item popup -- )
M: method-renderer column-alignment drop { 0 0 1 } ;
M: method-renderer filled-column drop 1 ;
-! Value is a { method-body count } pair
+! Value is a { method count } pair
M: method-renderer row-columns
drop [
[ [ definition-icon <image-name> ] [ synopsis ] bi ]
-Unicode 5.1 support
+Unicode 5.2 support
[ nip ] [ number>string ] if* ;
: group-id ( string -- id/f )
- group-struct [ gr_gid>> ] [ f ] if* ;
+ group-struct dup [ gr_gid>> ] when ;
<PRIVATE
HELP: user-id
{ $values
{ "string" string }
- { "id" integer } }
+ { "id/f" "an integer or f" } }
{ $description "Returns the user id associated with the user-name." } ;
HELP: with-effective-user
[ "9999999999999999999" ] [ 9999999999999999999 user-name ] unit-test
[ f ] [ 89898989898989898989898989898 user-passwd ] unit-test
+
+[ f ] [ "thisusershouldnotexistabcdefg12345asdfasdfasdfasdfasdfasdfasdf" user-id ] unit-test
dup user-passwd
[ nip user-name>> ] [ number>string ] if* ;
-: user-id ( string -- id )
- user-passwd uid>> ;
+: user-id ( string -- id/f )
+ user-passwd dup [ uid>> ] when ;
: real-user-id ( -- id )
unix.ffi:getuid ; inline
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 ;
{ dics DICOLORSET }
{ lpUnkDDSTarget IUnknown* } ;
TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
-TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPDICONFIGUREDEVICESPARAMSW
+TYPEDEF: DICONFIGUREDEVICESPARAMSW* LPCDICONFIGUREDEVICESPARAMSW
STRUCT: DIDEVCAPS
{ dwSize DWORD }
TYPEDEF: long LONG
TYPEDEF: long* LPLONG
-TYPEDEF: long LONG_PTR
-TYPEDEF: long* PLONG_PTR
+TYPEDEF: intptr_t LONG_PTR
TYPEDEF: uint ULONG
-TYPEDEF: void* ULONG_PTR
-TYPEDEF: void* PULONG_PTR
+TYPEDEF: uintptr_t ULONG_PTR
TYPEDEF: void VOID
TYPEDEF: void* PVOID
TYPEDEF: intptr_t INT_PTR
TYPEDEF: intptr_t UINT_PTR
-TYPEDEF: int LONG_PTR
-TYPEDEF: ulong ULONG_PTR
-
TYPEDEF: int INT32
TYPEDEF: uint UINT32
TYPEDEF: uint DWORD32
TYPEDEF: WORD ATOM
TYPEDEF: BYTE BOOLEAN
-TYPEDEF: DWORD COLORREF
TYPEDEF: ULONGLONG DWORDLONG
TYPEDEF: ULONG_PTR DWORD_PTR
TYPEDEF: PVOID HANDLE
TYPEDEF: LONG_PTR LPARAM
TYPEDEF: BOOL* LPBOOL
TYPEDEF: BYTE* LPBYTE
-TYPEDEF: DWORD* LPCOLORREF
TYPEDEF: WCHAR* LPCWSTR
! TYPEDEF: WCHAR* LPWSTR
TYPEDEF: HANDLE SC_HANDLE
TYPEDEF: LPVOID SC_LOCK
TYPEDEF: HANDLE SERVICE_STATUS_HANDLE
-TYPEDEF: ULONG_PTR SIZE_T
-TYPEDEF: LONG_PTR SSIZE_T
TYPEDEF: LONGLONG USN
TYPEDEF: UINT_PTR WPARAM
TYPEDEF: PIXELFORMATDESCRIPTOR PFD
TYPEDEF: PFD* LPPFD
TYPEDEF: HANDLE HGLRC
-TYPEDEF: HANDLE HRGN
TYPEDEF: void* PWNDCLASS
TYPEDEF: void* PWNDCLASSEX
! 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
[ resolve-delegate ] each-rule ;
: ?update ( keyword-map/f keyword-map -- keyword-map )
- over [ dupd update ] [ nip clone ] if ;
+ over [ assoc-union! ] [ nip clone ] if ;
: import-keywords ( parent child -- )
over [ [ keywords>> ] bi@ ?update ] dip (>>keywords) ;
{ "int" KEYWORD1 }
{ "void" KEYWORD2 }
{ "size_t" KEYWORD3 }
-} update
+} assoc-union! drop
[ 3 ] [ "k" get assoc-size ] unit-test
[ KEYWORD1 ] [ "int" "k" get at ] unit-test
{ "Foo" KEYWORD1 }
{ "bbar" KEYWORD2 }
{ "BAZ" KEYWORD3 }
-} update
+} assoc-union! drop
[ KEYWORD1 ] [ "fOo" "k" get at ] unit-test
{ $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*
{ $subsections
assoc-subset?
assoc-intersect
- update
assoc-union
assoc-diff
substitute
extract-keys
}
+"Destructive operations:"
+{ $subsections
+ assoc-union!
+ assoc-diff!
+}
{ $see-also key? assoc-any? assoc-all? "sets" } ;
ARTICLE: "assocs-mutation" "Storing keys and values in assocs"
assoc-map
assoc-filter
assoc-filter-as
+ assoc-partition
assoc-any?
assoc-all?
}
-"Additional combinators:"
+"Mapping between assocs and sequences:"
{ $subsections
- assoc-partition
- cache
- 2cache
map>assoc
assoc>map
assoc-map-as
+}
+"Destructive combinators:"
+{ $subsections
+ assoc-filter!
+ cache
+ 2cache
} ;
ARTICLE: "assocs" "Associative mapping operations"
{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } { "exemplar" assoc } { "subassoc" "a new assoc" } }
{ $description "Outputs an assoc of the same type as " { $snippet "exemplar" } " consisting of all entries for which the predicate quotation yields true." } ;
-{ assoc-filter assoc-filter-as } related-words
+HELP: assoc-filter!
+{ $values { "assoc" assoc } { "quot" { $quotation "( key value -- ? )" } } }
+{ $description "Removes all entries for which the predicate quotation yields true." }
+{ $side-effects "assoc" } ;
+
+{ assoc-filter assoc-filter-as assoc-filter! } related-words
HELP: assoc-partition
{ $values
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc2" } " such that the key is also present in " { $snippet "assoc1" } "." }
{ $notes "The values of the keys in " { $snippet "assoc1" } " are disregarded, so this word is usually used for set-theoretic calculations where the assoc in question either has dummy sentinels as values, or the values equal the keys." } ;
-HELP: update
+HELP: assoc-union!
{ $values { "assoc1" assoc } { "assoc2" assoc } }
{ $description "Adds all entries from " { $snippet "assoc2" } " to " { $snippet "assoc1" } "." }
{ $side-effects "assoc1" } ;
{ $description "Outputs an assoc consisting of all entries from " { $snippet "assoc1" } " whose key is not contained in " { $snippet "assoc2" } "." }
;
+HELP: assoc-diff!
+{ $values { "assoc1" assoc } { "assoc2" assoc } }
+{ $description "Removes all entries from " { $snippet "assoc1" } " whose key is contained in " { $snippet "assoc2" } "." }
+{ $side-effects "assoc1" } ;
+
HELP: substitute
{ $values { "seq" sequence } { "assoc" assoc } { "newseq" sequence } }
{ $description "Creates a new sequence where elements of " { $snippet "seq" } " which appear as keys in " { $snippet "assoc" } " are replaced by the corresponding values, and all other elements are unchanged." } ;
[ f ] [ H{ { 1 2 } { 2 2 } } [ = ] assoc-all? ] unit-test
[ H{ } ] [ H{ { t f } { f t } } [ 2drop f ] assoc-filter ] unit-test
+[ H{ } ] [ H{ { t f } { f t } } clone dup [ 2drop f ] assoc-filter! drop ] unit-test
+[ H{ } ] [ H{ { t f } { f t } } clone [ 2drop f ] assoc-filter! ] unit-test
+
[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } }
[ drop 3 >= ] assoc-filter
] unit-test
+[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
+ H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } } clone
+ [ drop 3 >= ] assoc-filter!
+] unit-test
+
+[ H{ { 3 4 } { 4 5 } { 6 7 } } ] [
+ H{ { 1 2 } { 2 3 } { 3 4 } { 4 5 } { 6 7 } } clone dup
+ [ drop 3 >= ] assoc-filter! drop
+] unit-test
+
[ 21 ] [
0 H{
{ 1 2 }
assoc-union
] unit-test
+[
+ H{ { 1 2 } { 2 3 } { 6 5 } }
+] [
+ H{ { 2 4 } { 6 5 } } clone dup H{ { 1 2 } { 2 3 } }
+ assoc-union! drop
+] unit-test
+
+[
+ H{ { 1 2 } { 2 3 } { 6 5 } }
+] [
+ H{ { 2 4 } { 6 5 } } clone H{ { 1 2 } { 2 3 } }
+ assoc-union!
+] unit-test
+
[ H{ { 1 2 } { 2 3 } } t ] [
f H{ { 1 2 } { 2 3 } } [ assoc-union ] 2keep swap assoc-union dupd =
] unit-test
H{ { 1 f } } H{ { 1 f } } assoc-intersect
] unit-test
+[
+ H{ { 3 4 } }
+] [
+ H{ { 1 2 } { 3 4 } } H{ { 1 3 } } assoc-diff
+] unit-test
+
+[
+ H{ { 3 4 } }
+] [
+ H{ { 1 2 } { 3 4 } } clone dup H{ { 1 3 } } assoc-diff! drop
+] unit-test
+
+[
+ H{ { 3 4 } }
+] [
+ H{ { 1 2 } { 3 4 } } clone H{ { 1 3 } } assoc-diff!
+] unit-test
+
[ H{ { "hi" 2 } { 3 4 } } ]
[ "hi" 1 H{ { 1 2 } { 3 4 } } clone [ rename-at ] keep ]
unit-test
(assoc-each) each ; inline
: assoc>map ( assoc quot exemplar -- seq )
- [ collector [ assoc-each ] dip ] dip like ; inline
+ [ collector-for [ assoc-each ] dip ] [ like ] bi ; inline
: assoc-map-as ( assoc quot exemplar -- newassoc )
[ [ 2array ] compose V{ } assoc>map ] dip assoc-like ; inline
: assoc-filter ( assoc quot -- subassoc )
over assoc-filter-as ; inline
+: assoc-filter! ( assoc quot -- assoc )
+ [
+ over [ [ [ drop ] 2bi ] dip [ delete-at ] 2curry unless ] 2curry
+ assoc-each
+ ] [ drop ] 2bi ; inline
+
: assoc-partition ( assoc quot -- true-assoc false-assoc )
[ (assoc-each) partition ] [ drop ] 2bi
[ assoc-like ] curry bi@ ; inline
: assoc-intersect ( assoc1 assoc2 -- intersection )
swap [ nip key? ] curry assoc-filter ;
-: update ( assoc1 assoc2 -- )
- swap [ set-at ] with-assoc assoc-each ;
+: assoc-union! ( assoc1 assoc2 -- assoc1 )
+ over [ set-at ] with-assoc assoc-each ;
: assoc-union ( assoc1 assoc2 -- union )
[ [ [ assoc-size ] bi@ + ] [ drop ] 2bi new-assoc ] 2keep
- [ dupd update ] bi@ ;
+ [ assoc-union! ] bi@ ;
: assoc-combine ( seq -- union )
- H{ } clone [ dupd update ] reduce ;
+ H{ } clone [ assoc-union! ] reduce ;
: assoc-refine ( seq -- assoc )
[ f ] [ [ ] [ assoc-intersect ] map-reduce ] if-empty ;
+: assoc-differ ( key -- quot )
+ [ nip key? not ] curry ; inline
+
: assoc-diff ( assoc1 assoc2 -- diff )
- [ nip key? not ] curry assoc-filter ;
+ assoc-differ assoc-filter ;
+
+: assoc-diff! ( assoc1 assoc2 -- assoc1 )
+ assoc-differ assoc-filter! ;
: substitute ( seq assoc -- newseq )
substituter map ;
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 ;
{ "resize-byte-array" "byte-arrays" "primitive_resize_byte_array" (( n byte-array -- newbyte-array )) }
{ "<tuple-boa>" "classes.tuple.private" "primitive_tuple_boa" (( ... layout -- tuple )) }
{ "<tuple>" "classes.tuple.private" "primitive_tuple" (( layout -- tuple )) }
- { "modify-code-heap" "compiler.units" "primitive_modify_code_heap" (( alist -- )) }
+ { "modify-code-heap" "compiler.units" "primitive_modify_code_heap" (( alist update-existing? reset-pics? -- )) }
{ "lookup-method" "generic.single.private" "primitive_lookup_method" (( object methods -- method )) }
{ "mega-cache-miss" "generic.single.private" "primitive_mega_cache_miss" (( methods index cache -- method )) }
{ "(exists?)" "io.files.private" "primitive_existsp" (( path -- ? )) }
{ "double>bits" "math" "primitive_double_bits" (( x -- n )) }
{ "float>bits" "math" "primitive_float_bits" (( x -- n )) }
{ "(float>string)" "math.parser.private" "primitive_float_to_str" (( n -- str )) }
- { "(string>float)" "math.parser.private" "primitive_str_to_float" (( str -- n/f )) }
{ "bignum*" "math.private" "primitive_bignum_multiply" (( x y -- z )) }
{ "bignum+" "math.private" "primitive_bignum_add" (( x y -- z )) }
{ "bignum-" "math.private" "primitive_bignum_subtract" (( x y -- z )) }
{ "float>bignum" "math.private" "primitive_float_to_bignum" (( x -- y )) }
{ "float>fixnum" "math.private" "primitive_float_to_fixnum" (( x -- y )) }
{ "all-instances" "memory" "primitive_all_instances" (( -- array )) }
+ { "(code-blocks)" "memory.private" "primitive_code_blocks" (( -- array )) }
{ "code-room" "memory" "primitive_code_room" (( -- code-room )) }
{ "compact-gc" "memory" "primitive_compact_gc" (( -- )) }
{ "data-room" "memory" "primitive_data_room" (( -- data-room )) }
-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
over [ slot-named* ] dip check-slot-exists drop ;
: assoc>object ( class slots values -- tuple )
- [ [ [ initial>> ] map ] keep ] dip
+ [ [ [ initial>> ] map <enum> ] keep ] dip
swap [ [ slot-named-checked ] curry dip ] curry assoc-map
- [ dup <enum> ] dip update boa>object ;
+ assoc-union! seq>> boa>object ;
: parse-tuple-literal-slots ( class slots -- tuple )
scan {
}
"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
[ (( x y z -- * )) ] [ \ derived-error stack-effect ] unit-test
-USE: classes.struct
+! Make sure that tuple reshaping updates code heap roots
+TUPLE: code-heap-ref ;
-[ { } ] [
- classes
- [ "prototype" word-prop ] map
- [ '[ _ hashcode drop f ] [ drop t ] recover ] filter
-] unit-test
+: 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> ;
+
+: error-slots ( slots -- slots' )
+ [
+ dup string? [ 1array ] when
+ read-only swap remove
+ read-only suffix
+ ] map ;
+
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 -- )
+ error-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) 2006, 2009 Slava Pestov, Daniel Ehrenberg.
+! Copyright (C) 2006, 2010 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays sequences sequences.private math.private
kernel kernel.private math assocs quotations vectors
PRIVATE>
-ERROR: wrong-values effect ;
+ERROR: wrong-values quot effect ;
! We can't USE: effects here so we forward reference slots instead
SLOT: in
SLOT: out
: call-effect ( quot effect -- )
- [ [ datastack ] dip dip ] dip
- [ in>> length ] [ out>> length ] [ ] tri [ check-datastack ] dip
- [ wrong-values ] curry unless ;
+ ! Don't use fancy combinators here, since this word always
+ ! runs unoptimized
+ [ datastack ] 2dip
+ 2dup [
+ [ dip ] dip
+ dup in>> length swap out>> length
+ check-datastack
+ ] 2dip rot
+ [ 2drop ] [ wrong-values ] if ;
: execute-effect ( word effect -- )
[ [ execute ] curry ] dip call-effect ;
USING: help.markup help.syntax words math source-files
-parser quotations definitions ;
+parser quotations definitions stack-checker.errors ;
IN: compiler.units
-ARTICLE: "compilation-units" "Compilation units"
-"A " { $emphasis "compilation unit" } " scopes a group of related definitions. They are compiled and entered into the system in one atomic operation."
-$nl
-"Words defined in a compilation unit may not be called until the compilation unit is finished. The parser detects this case for parsing words and throws a " { $link staging-violation } "; calling any other word from within its own compilation unit throws an " { $link undefined } " error."
+ARTICLE: "compilation-units-internals" "Compilation units internals"
+"These words do not need to be called directly, and only serve to support the implementation."
$nl
-"The parser groups all definitions in a source file into one compilation unit, and parsing words do not need to concern themselves with compilation units. However, if definitions are being created at run time, a compilation unit must be created explicitly:"
-{ $subsections with-compilation-unit }
"Compiling a set of words:"
{ $subsections compile }
"Words called to associate a definition with a compilation unit and a source file location:"
"Low-level compiler interface exported by the Factor VM:"
{ $subsections modify-code-heap } ;
+ARTICLE: "compilation-units" "Compilation units"
+"A " { $emphasis "compilation unit" } " scopes a group of related definitions. They are compiled and entered into the system in one atomic operation."
+$nl
+"When a source file is being parsed, all definitions are part of a single compilation unit, unless the " { $link POSTPONE: << } " parsing word is used to create nested compilation units."
+$nl
+"Words defined in a compilation unit may not be called until the compilation unit is finished. The parser detects this case for parsing words and throws a " { $link staging-violation } ". Similarly, an attempt to use a macro from a word defined in the same compilation unit will throw a " { $link transform-expansion-error } ". Calling any other word from within its own compilation unit throws an " { $link undefined } " error."
+$nl
+"This means that parsing words and macros generally cannot be used in the same source file as they are defined. There are two means of getting around this:"
+{ $list
+ { "The simplest way is to split off the parsing words and macros into sub-vocabularies; perhaps suffixed by " { $snippet ".syntax" } " and " { $snippet ".macros" } "." }
+ { "Alternatively, nested compilation units can be created using " { $link "syntax-immediate" } "." }
+}
+"Parsing words which create new definitions at parse time will implicitly add them to the compilation unit of the current source file."
+$nl
+"Code which creates new definitions at run time will need to explicitly create a compilation unit with a combinator. There is an additional combinator used by the parser to implement " { $link "syntax-immediate" } "."
+{ $subsections with-compilation-unit with-nested-compilation-unit }
+"Additional topics:"
+{ $subsections "compilation-units-internals" } ;
+
ABOUT: "compilation-units"
HELP: redefine-error
HELP: with-compilation-unit
{ $values { "quot" quotation } }
{ $description "Calls a quotation in a new compilation unit. The quotation can define new words and classes, as well as forget words. When the quotation returns, any changed words are recompiled, and changes are applied atomically." }
-{ $notes "Compilation units may be nested."
+{ $notes "Calls to " { $link with-compilation-unit } " may be nested."
$nl
"The parser wraps every source file in a compilation unit, so parsing words may define new words without having to perform extra work; to define new words at any other time, you must wrap your defining code with this combinator."
$nl
"Since compilation is relatively expensive, you should try to batch up as many definitions into one compilation unit as possible." } ;
+HELP: with-nested-compilation-unit
+{ $values { "quot" quotation } }
+{ $description "Calls a quotation in a new compilation unit. The only difference between this word and " { $link with-compilation-unit } " is that variables used by the parser to associate definitions with source files are not rebound." }
+{ $notes "This word is used by " { $link "syntax-immediate" } " to ensure that definitions in nested blocks are correctly recorded. User code should not depend on parser internals in such a way that calling this combinator is required." } ;
+
HELP: recompile
{ $values { "words" "a sequence of words" } { "alist" "an association list mapping words to compiled definitions" } }
{ $contract "Internal word which compiles words. Called at the end of " { $link with-compilation-unit } "." } ;
{ $description "Throws a " { $link no-compilation-unit } " error." }
{ $error-description "Thrown when an attempt is made to define a word outside of a " { $link with-compilation-unit } " combinator." } ;
-HELP: modify-code-heap ( alist -- )
-{ $values { "alist" "an alist" } }
-{ $description "Stores compiled code definitions in the code heap. The alist maps words to the following:"
+HELP: modify-code-heap ( alist update-existing? reset-pics? -- )
+{ $values { "alist" "an association list with words as keys" } { "update-existing?" "a boolean" } { "reset-pics?" "a boolean" } }
+{ $description "Lowest-level primitive for defining words. Associates words with code blocks in the code heap."
+$nl
+"The alist maps words to the following:"
{ $list
{ "a quotation - in this case, the quotation is compiled with the non-optimizing compiler and the word will call the quotation when executed." }
- { { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data and the word will call the code block when executed." }
-} }
+ { "a 5-element array " { $snippet "{ parameters literals relocation labels code }" } " - in this case, a code heap block is allocated with the given data and the word will call the code block when executed. This is used by the optimizing compiler." }
+}
+"If any of the redefined words may already be referenced by other words in the code heap, from outside of the compilation unit, then a scan of the code heap must be performed to update all word call sites. Passing " { $link t } " as the " { $snippet "update-existing?" } " parameter enables this code path."
+$nl
+"If classes, methods or generic words were redefined, then inline cache call sites need to be updated as well. Passing " { $link t } " as the " { $snippet "reset-pics?" } " parameter enables this code path."
+}
{ $notes "This word is called at the end of " { $link with-compilation-unit } "." } ;
HELP: compile
! Non-optimizing compiler bugs
[ 1 1 ] [
- "A" <uninterned-word> [ [ [ 1 ] dip ] 2array 1array modify-code-heap ] keep
+ "A" <uninterned-word> [ [ [ 1 ] dip ] 2array 1array t t modify-code-heap ] keep
1 swap execute
] unit-test
-! 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 )
HOOK: process-forgotten-words compiler-impl ( words -- )
-: compile ( words -- ) recompile modify-code-heap ;
+: compile ( words -- )
+ recompile t f 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
: updated-definitions ( -- assoc )
H{ } clone
- dup forgotten-definitions get update
- dup new-definitions get first update
- dup new-definitions get second update
- dup changed-definitions get update
- dup dup changed-vocabs update ;
+ forgotten-definitions get assoc-union!
+ new-definitions get first assoc-union!
+ new-definitions get second assoc-union!
+ changed-definitions get assoc-union!
+ maybe-changed get assoc-union!
+ dup changed-vocabs assoc-union! ;
: process-forgotten-definitions ( -- )
forgotten-definitions get keys
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? [
updated-definitions dup assoc-empty?
[ drop ] [ notify-definition-observers notify-error-observers ] if ;
+: update-existing? ( defs -- ? )
+ new-words get keys diff empty? not ;
+
+: reset-pics? ( -- ? )
+ outdated-generics get assoc-empty? not ;
+
: 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
+ ] keep update-existing? reset-pics? modify-code-heap
+ bump-effect-counter
+ notify-observers
+ ] if-bootstrapping ;
+
+TUPLE: nesting-observer new-words ;
+
+M: nesting-observer definitions-changed new-words>> swap assoc-diff! drop ;
+
+: add-nesting-observer ( -- )
+ new-words get nesting-observer boa
+ [ nesting-observer set ] [ add-definition-observer ] bi ;
+
+: remove-nesting-observer ( -- )
+ nesting-observer get remove-definition-observer ;
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
+ add-nesting-observer
+ [
+ remove-nesting-observer
+ finish-compilation-unit
+ ] [ ] cleanup
] with-scope ; inline
: with-compilation-unit ( quot -- )
[
- H{ } clone changed-definitions set
- H{ } clone changed-generics 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
+ H{ } clone forgotten-definitions set
+ with-nested-compilation-unit
] with-scope ; inline
{ $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
{ $class-description "Pushes a method on the stack." }
{ $examples { $code "M\\ fixnum + see" } { $code "USING: ui.gadgets ui.gadgets.editors ;" "M\\ editor draw-gadget* edit" } } ;
-HELP: method-body
-{ $class-description "The class of method bodies, which are words with special word properties set." } ;
-
HELP: method
-{ $values { "class" class } { "generic" generic } { "method/f" { $maybe method-body } } }
-{ $description "Looks up a method definition." } ;
+{ $values { "class" class } { "generic" generic } { "method/f" { $maybe method } } }
+{ $description "Looks up a method definition." }
+{ $class-description "The class of method bodies, which are words with special word properties set." } ;
{ method create-method POSTPONE: M: } related-words
$low-level-note ;
HELP: create-method
-{ $values { "class" class } { "generic" generic } { "method" method-body } }
+{ $values { "class" class } { "generic" generic } { "method" method } }
{ $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)
-{ $values { "method" method-body } }
+{ $values { "method" method } }
{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
[ ] [ "IN: generic.tests USE: math FORGET: M\\ integer forget-test" eval( -- ) ] unit-test
[ { } ] [
- \ + compiled-usage keys
- [ method-body? ] filter
+ \ + effect-dependencies-of keys [ method? ] filter
[ "method-generic" word-prop \ forget-test eq? ] filter
] unit-test
[ dup "combination" word-prop perform-combination ]
bi ;
+PREDICATE: method < word
+ "method-generic" word-prop >boolean ;
+
: method ( class generic -- method/f )
"methods" word-prop at ;
\ 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 flushable?
+ "method-generic" word-prop flushable? ;
-M: method-body stack-effect
+M: method stack-effect
"method-generic" word-prop stack-effect ;
-M: method-body crossref?
+M: method crossref?
"forgotten" word-prop not ;
: method-word-props ( class generic -- assoc )
dupd <default-method> "default-method" set-word-prop ;
! Definition protocol
-M: method-body definer
+M: method definer
drop \ M: \ ; ;
-M: method-body forget*
+M: method forget*
dup "forgotten" word-prop [ drop ] [
[
dup default-method? [ drop ] [
[ 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# ;
[ over assumed [ compile-engine ] with-variable ] assoc-map ;
: direct-dispatch-table ( assoc n -- table )
- default get <array> [ <enum> swap update ] keep ;
+ default get <array> <enum> swap assoc-union! seq>> ;
: tag-number ( class -- n ) "type" word-prop ;
tuple assumed [
echelons>> compile-engines
dup keys supremum 1 + f <array>
- [ <enum> swap update ] keep
+ <enum> swap assoc-union! seq>>
] with-variable ;
PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
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
{ $values { "a" object } { "b" object } }
{ $description "Throws an " { $link assert } " error if " { $snippet "a" } " does not equal " { $snippet "b" } "." } ;
+HELP: become
+{ $values { "old" array } { "new" array } }
+{ $description "Replaces all references to objects in " { $snippet "old" } " with the corresponding object in " { $snippet "new" } ". This word is used to implement tuple reshaping. See " { $link "tuple-redefinition" } "." } ;
+
ARTICLE: "shuffle-words-complex" "Complex shuffle words"
"These shuffle words tend to make code difficult to read and to reason about. Code that uses them should almost always be rewritten using " { $link "locals" } " or " { $link "dataflow-combinators" } "."
$nl
! Test traceback accuracy
: last-frame ( -- pair )
- error-continuation get call>> callstack>array 4 head* 2 tail* ;
+ error-continuation get call>> callstack>array 6 head* 3 tail* ;
[
- { [ 1 2 [ 3 throw ] call 4 ] 3 }
+ { [ 1 2 [ 3 throw ] call 4 ] [ 1 2 [ 3 throw ] call 4 ] 3 }
] [
[ [ 1 2 [ 3 throw ] call 4 ] call ] ignore-errors
last-frame
] unit-test
[
- { [ 1 2 [ 3 throw ] dip 4 ] 3 }
+ { [ 1 2 [ 3 throw ] dip 4 ] [ 1 2 [ 3 throw ] dip 4 ] 3 }
] [
[ [ 1 2 [ 3 throw ] dip 4 ] call ] ignore-errors
last-frame
] unit-test
[
- { [ 1 2 3 throw [ ] call 4 ] 3 }
+ { [ 1 2 3 throw [ ] call 4 ] [ 1 2 3 throw [ ] call 4 ] 3 }
] [
[ [ 1 2 3 throw [ ] call 4 ] call ] ignore-errors
last-frame
] unit-test
[
- { [ 1 2 3 throw [ ] dip 4 ] 3 }
+ { [ 1 2 3 throw [ ] dip 4 ] [ 1 2 3 throw [ ] dip 4 ] 3 }
] [
[ [ 1 2 3 throw [ ] dip 4 ] call ] ignore-errors
last-frame
] unit-test
[
- { [ 1 2 3 throw [ ] [ ] if 4 ] 3 }
+ { [ 1 2 3 throw [ ] [ ] if 4 ] [ 1 2 3 throw [ ] [ ] if 4 ] 3 }
] [
[ [ 1 2 3 throw [ ] [ ] if 4 ] call ] ignore-errors
last-frame
"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" } }
}
} ;
-HELP: string>float ( str -- n/f )
-{ $values { "str" string } { "n/f" "a real number or " { $link f } } }
-{ $description "Primitive for creating a float from a string representation." }
-{ $notes "The " { $link string>number } " word is more general."
-$nl
-"Outputs " { $link f } " if the string does not represent a float." } ;
-
HELP: float>string
{ $values { "n" real } { "str" string } }
{ $description "Primitive for getting a string representation of a float." }
[ f string>number ]
unit-test
+[ f ]
+[ ";" string>number ]
+unit-test
+
+[ f ]
+[ "<>" string>number ]
+unit-test
+
+[ f ]
+[ "^" string>number ]
+unit-test
+
+[ f ]
+[ "789:;<=>?@" string>number ]
+unit-test
+
[ f ]
[ "12345abcdef" string>number ]
unit-test
-[ t ]
-[ "-12" string>number 0 < ]
+[ 12 ]
+[ "+12" string>number ]
+unit-test
+
+[ -12 ]
+[ "-12" string>number ]
+unit-test
+
+[ f ]
+[ "-+12" string>number ]
+unit-test
+
+[ f ]
+[ "+-12" string>number ]
unit-test
[ f ]
[ "e" string>number ]
unit-test
+[ 1/2 ] [ "1/2" string>number ] unit-test
+[ -1/2 ] [ "-1/2" string>number ] unit-test
+[ 2 ] [ "4/2" string>number ] unit-test
+[ f ] [ "1/-2" string>number ] unit-test
+[ f ] [ "1/2/3" string>number ] unit-test
+[ 1+1/2 ] [ "1+1/2" string>number ] unit-test
+[ 1+1/2 ] [ "+1+1/2" string>number ] unit-test
+[ f ] [ "1-1/2" string>number ] unit-test
+[ -1-1/2 ] [ "-1-1/2" string>number ] unit-test
+[ f ] [ "-1+1/2" string>number ] unit-test
+[ f ] [ "1+2" string>number ] unit-test
+[ f ] [ "1+" string>number ] unit-test
+[ f ] [ "1-" string>number ] unit-test
+[ f ] [ "1+1/2+2" string>number ] unit-test
+
[ 100000 ] [ "100,000" string>number ] unit-test
[ 100000.0 ] [ "100,000.0" string>number ] unit-test
[ f ] [ "-,2" string>number ] unit-test
[ 2.0 ] [ "2." string>number ] unit-test
+[ 2.0 ] [ "+2." string>number ] unit-test
+[ 0.25 ] [ ".25" string>number ] unit-test
+[ -2.0 ] [ "-2." string>number ] unit-test
+[ -0.25 ] [ "-.25" string>number ] unit-test
+[ f ] [ "-." string>number ] unit-test
[ 255 ] [ "ff" hex> ] unit-test
+[ 100.0 ] [ "1.0e2" string>number ] unit-test
+[ 100.0 ] [ "100.0" string>number ] unit-test
+[ 100.0 ] [ "100." string>number ] unit-test
+
+[ 100.0 ] [ "1e2" string>number ] unit-test
+[ 100.0 ] [ "1e+2" string>number ] unit-test
+[ HEX: 1e2 ] [ "1e2" hex> ] unit-test
+
+[ HEX: 1.999999999999ap-3 ] [ "0.2" string>number ] unit-test
+[ HEX: 1.3333333333333p0 ] [ "1.2" string>number ] unit-test
+[ HEX: 1.5555555555555p0 ] [ "1.333,333,333,333,333,333" string>number ] unit-test
+[ HEX: 1.aaaaaaaaaaaabp0 ] [ "1.666,666,666,666,666,666" string>number ] unit-test
+
[ "100.0" ]
[ "1.0e2" string>number number>string ]
unit-test
+[ -100.0 ] [ "-1.0e2" string>number ] unit-test
+[ -100.0 ] [ "-100.0" string>number ] unit-test
+[ -100.0 ] [ "-100." string>number ] unit-test
+
[ "-100.0" ]
[ "-1.0e2" string>number number>string ]
unit-test
+[ -100.0 ] [ "-1.e2" string>number ] unit-test
+
[ "0.01" ]
[ "1.0e-2" string>number number>string ]
unit-test
+[ 0.01 ] [ "1.0e-2" string>number ] unit-test
+
[ "-0.01" ]
[ "-1.0e-2" string>number number>string ]
unit-test
+[ -0.01 ] [ "-1.0e-2" string>number ] unit-test
+
+[ "-0.01" ]
+[ "-1.e-2" string>number number>string ]
+unit-test
+
+[ -1.0e-12 ] [ "-1.0e-12" string>number ] unit-test
+
[ t ]
[ "-1.0e-12" string>number number>string { "-1.0e-12" "-1.0e-012" } member? ]
unit-test
[ f ]
[ "." string>number ]
unit-test
-
+
[ f ]
[ ".e" string>number ]
unit-test
[ "1e1/2" string>number ]
unit-test
+[ f ]
+[ "1e1.2" string>number ]
+unit-test
+
[ f ]
[ "e/2" string>number ]
unit-test
[ -1/0. ] [ "-1/0." string>number ] unit-test
+[ -0.5 ] [ "-1/2." string>number ] unit-test
+
[ "-0.0" ] [ -0.0 number>string ] unit-test
[ "-3/4" ] [ -3/4 number>string ] unit-test
[ 1.0 ] [ "1.0" hex> ] unit-test
[ 1.5 ] [ "1.8" hex> ] unit-test
+[ 1.875 ] [ "1.e" hex> ] unit-test
+[ 1.90625 ] [ "1.e8" hex> ] unit-test
[ 1.03125 ] [ "1.08" hex> ] unit-test
[ 15.5 ] [ "f.8" hex> ] unit-test
[ 15.53125 ] [ "f.88" hex> ] unit-test
-! Copyright (C) 2004, 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math.private namespaces sequences sequences.private
-strings arrays combinators splitting math assocs byte-arrays make ;
+! (c)2009 Joe Groff bsd license
+USING: accessors combinators kernel kernel.private math
+namespaces sequences sequences.private splitting strings make ;
IN: math.parser
: digit> ( ch -- n )
- 127 bitand {
- { [ dup CHAR: 9 <= ] [ CHAR: 0 - ] }
- { [ dup CHAR: a < ] [ CHAR: A 10 - - ] }
- [ CHAR: a 10 - - ]
- } cond
- dup 0 < [ drop 255 ] [ dup 16 >= [ drop 255 ] when ] if ; inline
+ {
+ { [ dup CHAR: 9 <= ] [ CHAR: 0 - dup 0 < [ drop 255 ] when ] }
+ { [ dup CHAR: a < ] [ CHAR: A 10 - - dup 10 < [ drop 255 ] when ] }
+ [ CHAR: a 10 - - dup 10 < [ drop 255 ] when ]
+ } cond ; inline
-: string>digits ( str -- digits )
- [ digit> ] B{ } map-as ; inline
+<PRIVATE
-: (digits>integer) ( valid? accum digit radix -- valid? accum )
- 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
+TUPLE: number-parse
+ { str read-only }
+ { length fixnum read-only }
+ { radix fixnum read-only } ;
-: each-digit ( seq radix quot -- n/f )
- [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
+: <number-parse> ( str radix -- i number-parse n )
+ [ 0 ] 2dip
+ [ dup length ] dip
+ number-parse boa
+ 0 ; inline
-: digits>integer ( seq radix -- n/f )
- [ (digits>integer) ] each-digit ; inline
+: (next-digit) ( i number-parse n digit-quot end-quot -- n/f )
+ [ 2over length>> < ] 2dip
+ [ [ 2over str>> nth-unsafe >fixnum [ 1 + >fixnum ] 3dip ] prepose ] dip if ; inline
-DEFER: base>
+: require-next-digit ( i number-parse n quot -- n/f )
+ [ 3drop f ] (next-digit) ; inline
-<PRIVATE
+: next-digit ( i number-parse n quot -- n/f )
+ [ 2nip ] (next-digit) ; inline
-SYMBOL: radix
-SYMBOL: negative?
+: add-digit ( i number-parse n digit quot -- n/f )
+ [ [ dup radix>> ] [ * ] [ + ] tri* ] dip next-digit ; inline
-: string>natural ( seq radix -- n/f )
- over empty? [ 2drop f ] [
- [ over CHAR: , eq? [ 2drop ] [ [ digit> ] dip (digits>integer) ] if ] each-digit
- ] if ;
+: digit-in-radix ( number-parse n char -- number-parse n digit ? )
+ digit> pick radix>> over > ; inline
-: sign ( -- str ) negative? get "-" "+" ? ;
+: ?make-ratio ( num denom/f -- ratio/f )
+ [ / ] [ drop f ] if* ; inline
-: with-radix ( radix quot -- )
- radix swap with-variable ; inline
+TUPLE: float-parse
+ { radix read-only }
+ { point read-only }
+ { exponent read-only } ;
+
+: inc-point ( float-parse -- float-parse' )
+ [ radix>> ] [ point>> 1 + ] [ exponent>> ] tri float-parse boa ; inline
+
+: store-exponent ( float-parse n expt -- float-parse' n )
+ swap [ [ drop radix>> ] [ drop point>> ] [ nip ] 2tri float-parse boa ] dip ; inline
+
+: ?store-exponent ( float-parse n expt/f -- float-parse' n/f )
+ [ store-exponent ] [ drop f ] if* ; inline
+
+: ((pow)) ( base x -- base^x )
+ iota 1 rot [ nip * ] curry reduce ; inline
+
+: (pow) ( base x -- base^x )
+ dup 0 >= [ ((pow)) ] [ [ recip ] [ neg ] bi* ((pow)) ] if ; inline
+
+: add-mantissa-digit ( float-parse i number-parse n digit quot -- float-parse' n/f )
+ [ [ inc-point ] 4dip ] dip add-digit ; inline
+
+: make-float-dec-exponent ( float-parse n/f -- float/f )
+ [ [ radix>> ] [ point>> ] [ exponent>> ] tri - (pow) ] [ swap /f ] bi* ; inline
+
+: make-float-bin-exponent ( float-parse n/f -- float/f )
+ [ drop [ radix>> ] [ point>> ] bi (pow) ]
+ [ nip swap /f ]
+ [ drop 2.0 swap exponent>> (pow) * ] 2tri ; inline
+
+: ?make-float ( float-parse n/f -- float/f )
+ {
+ { [ dup not ] [ 2drop f ] }
+ { [ over radix>> 10 = ] [ make-float-dec-exponent ] }
+ [ make-float-bin-exponent ]
+ } cond ; inline
-: (base>) ( str -- n ) radix get base> ;
+: ?neg ( n/f -- -n/f )
+ [ neg ] [ f ] if* ; inline
-: whole-part ( str -- m n )
- sign split1 [ (base>) ] dip
- dup [ (base>) ] [ drop 0 swap ] if ;
+: ?add-ratio ( m n/f -- m+n/f )
+ dup ratio? [ + ] [ 2drop f ] if ; inline
-: string>ratio ( str radix -- a/b )
+: @abort ( i number-parse n x -- f )
+ 2drop 2drop f ; inline
+
+: @split ( i number-parse n -- n i number-parse n' )
+ -rot 0 ; inline
+
+: @split-exponent ( i number-parse n -- n i number-parse' n' )
+ -rot [ str>> ] [ length>> ] bi 10 number-parse boa 0 ; inline
+
+: <float-parse> ( i number-parse n -- float-parse i number-parse n )
+ [ drop nip radix>> 0 0 float-parse boa ] 3keep ; inline
+
+DEFER: @exponent-digit
+DEFER: @mantissa-digit
+DEFER: @denom-digit
+DEFER: @num-digit
+DEFER: @pos-digit
+DEFER: @neg-digit
+
+: @exponent-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
+ {
+ { CHAR: , [ [ @exponent-digit ] require-next-digit ] }
+ [ @exponent-digit ]
+ } case ; inline
+
+: @exponent-digit ( float-parse i number-parse n char -- float-parse n/f )
+ { float-parse fixnum number-parse integer fixnum } declare
+ digit-in-radix [ [ @exponent-digit-or-punc ] add-digit ] [ @abort ] if ;
+
+: @exponent-first-char ( float-parse i number-parse n char -- float-parse n/f )
+ {
+ { CHAR: - [ [ @exponent-digit ] require-next-digit ?neg ] }
+ { CHAR: + [ [ @exponent-digit ] require-next-digit ] }
+ [ @exponent-digit ]
+ } case ; inline
+
+: ->exponent ( float-parse i number-parse n -- float-parse' n/f )
+ @split-exponent [ @exponent-first-char ] require-next-digit ?store-exponent ; inline
+
+: exponent-char? ( number-parse n char -- number-parse n char ? )
+ 3dup nip swap radix>> {
+ { 10 [ [ CHAR: e CHAR: E ] dip [ = ] curry either? ] }
+ [ drop [ CHAR: p CHAR: P ] dip [ = ] curry either? ]
+ } case ; inline
+
+: or-exponent ( i number-parse n char quot -- n/f )
+ [ exponent-char? [ drop <float-parse> ->exponent ?make-float ] ] dip if ; inline
+
+: or-mantissa->exponent ( float-parse i number-parse n char quot -- float-parse n/f )
+ [ exponent-char? [ drop ->exponent ] ] dip if ; inline
+
+: @mantissa-digit-or-punc ( float-parse i number-parse n char -- float-parse n/f )
+ {
+ { CHAR: , [ [ @mantissa-digit ] require-next-digit ] }
+ [ @mantissa-digit ]
+ } case ; inline
+
+: @mantissa-digit ( float-parse i number-parse n char -- float-parse n/f )
+ { float-parse fixnum number-parse integer fixnum } declare
[
- "-" ?head dup negative? set swap
- "/" split1 (base>) [ whole-part ] dip
- 3dup and and [ / + swap [ neg ] when ] [ 2drop 2drop f ] if
- ] with-radix ;
+ digit-in-radix
+ [ [ @mantissa-digit-or-punc ] add-mantissa-digit ]
+ [ @abort ] if
+ ] or-mantissa->exponent ;
-: string>integer ( str radix -- n/f )
- over first-unsafe CHAR: - = [
- [ rest-slice ] dip string>natural dup [ neg ] when
- ] [
- string>natural
- ] if ; inline
-
-: dec>float ( str -- n/f )
- [ CHAR: , eq? not ] BV{ } filter-as
- 0 over push B{ } like (string>float) ;
-
-: hex>float-parts ( str -- neg? mantissa-str expt )
- "-" ?head swap "p" split1 [ 10 base> ] [ 0 ] if* ; inline
-
-: make-mantissa ( str -- bits )
- 16 base> dup log2 52 swap - shift ; inline
-
-: combine-hex-float-parts ( neg? mantissa expt -- float )
- dup 2046 > [ 2drop -1/0. 1/0. ? ] [
- dup 0 <= [ 1 - shift 0 ] when
- [ HEX: 8000,0000,0000,0000 0 ? ]
- [ 52 2^ 1 - bitand ]
- [ 52 shift ] tri* bitor bitor
- bits>double
- ] if ; inline
-
-: hex>float ( str -- n/f )
- hex>float-parts
- [ "." split1 [ append make-mantissa ] [ drop 16 base> log2 ] 2bi ]
- [ + 1023 + ] bi*
- combine-hex-float-parts ;
-
-: base>float ( str base -- n/f )
- {
- { 16 [ hex>float ] }
- [ drop dec>float ]
+: ->mantissa ( i number-parse n -- n/f )
+ <float-parse> [ @mantissa-digit ] next-digit ?make-float ; inline
+
+: ->required-mantissa ( i number-parse n -- n/f )
+ <float-parse> [ @mantissa-digit ] require-next-digit ?make-float ; inline
+
+: @denom-digit-or-punc ( i number-parse n char -- n/f )
+ {
+ { CHAR: , [ [ @denom-digit ] require-next-digit ] }
+ { CHAR: . [ ->mantissa ] }
+ [ [ @denom-digit ] or-exponent ]
+ } case ; inline
+
+: @denom-digit ( i number-parse n char -- n/f )
+ { fixnum number-parse integer fixnum } declare
+ digit-in-radix [ [ @denom-digit-or-punc ] add-digit ] [ @abort ] if ;
+
+: @denom-first-digit ( i number-parse n char -- n/f )
+ {
+ { CHAR: . [ ->mantissa ] }
+ [ @denom-digit ]
} case ; inline
-: number-char? ( char -- ? )
- "0123456789ABCDEFabcdef." member? ; inline
+: ->denominator ( i number-parse n -- n/f )
+ @split [ @denom-first-digit ] require-next-digit ?make-ratio ; inline
-: last-unsafe ( seq -- elt )
- [ length 1 - ] [ nth-unsafe ] bi ; inline
+: @num-digit-or-punc ( i number-parse n char -- n/f )
+ {
+ { CHAR: , [ [ @num-digit ] require-next-digit ] }
+ { CHAR: / [ ->denominator ] }
+ [ @num-digit ]
+ } case ; inline
-: numeric-looking? ( str -- ? )
- dup empty? [ drop f ] [
- dup first-unsafe number-char? [
- last-unsafe number-char?
- ] [
- dup first-unsafe CHAR: - eq? [
- dup length 1 eq? [ drop f ] [
- 1 over nth-unsafe number-char? [
- last-unsafe number-char?
- ] [ drop f ] if
- ] if
- ] [ drop f ] if
- ] if
- ] if ; inline
+: @num-digit ( i number-parse n char -- n/f )
+ { fixnum number-parse integer fixnum } declare
+ digit-in-radix [ [ @num-digit-or-punc ] add-digit ] [ @abort ] if ;
-PRIVATE>
+: ->numerator ( i number-parse n -- n/f )
+ @split [ @num-digit ] require-next-digit ?add-ratio ; inline
-: string>float ( str -- n/f )
- 10 base>float ; inline
+: @pos-digit-or-punc ( i number-parse n char -- n/f )
+ {
+ { CHAR: , [ [ @pos-digit ] require-next-digit ] }
+ { CHAR: + [ ->numerator ] }
+ { CHAR: / [ ->denominator ] }
+ { CHAR: . [ ->mantissa ] }
+ [ [ @pos-digit ] or-exponent ]
+ } case ; inline
+
+: @pos-digit ( i number-parse n char -- n/f )
+ { fixnum number-parse integer fixnum } declare
+ digit-in-radix [ [ @pos-digit-or-punc ] add-digit ] [ @abort ] if ;
+
+: @pos-first-digit ( i number-parse n char -- n/f )
+ {
+ { CHAR: . [ ->required-mantissa ] }
+ [ @pos-digit ]
+ } case ; inline
+
+: @neg-digit-or-punc ( i number-parse n char -- n/f )
+ {
+ { CHAR: , [ [ @neg-digit ] require-next-digit ] }
+ { CHAR: - [ ->numerator ] }
+ { CHAR: / [ ->denominator ] }
+ { CHAR: . [ ->mantissa ] }
+ [ [ @neg-digit ] or-exponent ]
+ } case ; inline
+
+: @neg-digit ( i number-parse n char -- n/f )
+ { fixnum number-parse integer fixnum } declare
+ digit-in-radix [ [ @neg-digit-or-punc ] add-digit ] [ @abort ] if ;
+
+: @neg-first-digit ( i number-parse n char -- n/f )
+ {
+ { CHAR: . [ ->required-mantissa ] }
+ [ @neg-digit ]
+ } case ; inline
+
+: @first-char ( i number-parse n char -- n/f )
+ {
+ { CHAR: - [ [ @neg-first-digit ] require-next-digit ?neg ] }
+ { CHAR: + [ [ @pos-first-digit ] require-next-digit ] }
+ [ @pos-first-digit ]
+ } case ; inline
+
+PRIVATE>
: base> ( str radix -- n/f )
- over numeric-looking? [
- over [ "/." member? ] find nip {
- { CHAR: / [ string>ratio ] }
- { CHAR: . [ base>float ] }
- [ drop string>integer ]
- } case
- ] [ 2drop f ] if ;
+ <number-parse> [ @first-char ] require-next-digit ;
: string>number ( str -- n/f ) 10 base> ; inline
-: bin> ( str -- n/f ) 2 base> ; inline
-: oct> ( str -- n/f ) 8 base> ; inline
+
+: bin> ( str -- n/f ) 2 base> ; inline
+: oct> ( str -- n/f ) 8 base> ; inline
+: dec> ( str -- n/f ) 10 base> ; inline
: hex> ( str -- n/f ) 16 base> ; inline
+: string>digits ( str -- digits )
+ [ digit> ] B{ } map-as ; inline
+
+<PRIVATE
+
+: (digits>integer) ( valid? accum digit radix -- valid? accum )
+ 2dup < [ swapd * + ] [ 2drop 2drop f 0 ] if ; inline
+
+: each-digit ( seq radix quot -- n/f )
+ [ t 0 ] 3dip curry each swap [ drop f ] unless ; inline
+
+PRIVATE>
+
+: digits>integer ( seq radix -- n/f )
+ [ (digits>integer) ] each-digit ; inline
+
: >digit ( n -- ch )
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] if ; inline
+<PRIVATE
+
: positive>base ( num radix -- str )
dup 1 <= [ "Invalid radix" throw ] when
[ dup 0 > ] swap [ /mod >digit ] curry "" produce-as nip
reverse! ; inline
+PRIVATE>
+
GENERIC# >base 1 ( n radix -- str )
<PRIVATE
+SYMBOL: radix
+SYMBOL: negative?
+
+: sign ( -- str ) negative? get "-" "+" ? ;
+
+: with-radix ( radix quot -- )
+ radix swap with-variable ; inline
+
: (>base) ( n -- str ) radix get positive>base ;
PRIVATE>
"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
PREDICATE: reader < word "reader" word-prop ;
-PREDICATE: reader-method < method-body "reading" word-prop ;
+PREDICATE: reader-method < method "reading" word-prop ;
PREDICATE: writer < word "writer" word-prop ;
-PREDICATE: writer-method < method-body "writing" word-prop ;
+PREDICATE: writer-method < method "writing" word-prop ;
: <slot-spec> ( -- slot-spec )
slot-spec new
: define-typecheck ( class generic quot props -- )
[ create-method ] 2dip
- [ [ props>> ] [ drop ] [ ] tri* update ]
+ [ [ props>> ] [ drop ] [ ] tri* assoc-union! drop ]
[ drop define ]
[ 2drop make-inline ]
3tri ;
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) ;
IN: strings
ARTICLE: "strings" "Strings"
-"The " { $vocab-link "strings" } " vocabulary implements fixed-size mutable sequences of of Unicode 5.1 code points."
+"The " { $vocab-link "strings" } " vocabulary implements a data type for storing text. Strings are represented as fixed-size mutable sequences of Unicode code points. Code points are represented as integers in the range [0,2,097,152]."
$nl
-"Code points, or characters as they're informally known, are not a first-class type; they are simply represented as integers in the range 0 and 16,777,216 (2^24), inclusive. Only characters up to 2,097,152 (2^21) have a defined meaning in Unicode."
-$nl
-"String literal syntax is covered in " { $link "syntax-strings" } "."
-$nl
-"Since strings implement the " { $link "sequence-protocol" } ", basic string manipulation can be performed with " { $link "sequences" } " in the " { $vocab-link "sequences" } " vocabulary. More text processing functionality can be found in vocabularies carrying the " { $link T{ vocab-tag { name "text" } } } " tag."
+"Strings implement the " { $link "sequence-protocol" } ", and basic string manipulation can be performed with " { $link "sequences" } " from the " { $vocab-link "sequences" } " vocabulary. More text processing functionality can be found in vocabularies carrying the " { $link T{ vocab-tag { name "text" } } } " tag."
$nl
"Strings form a class:"
{ $subsections
<string>
}
"Creating a string from a single character:"
-{ $subsections 1string } ;
+{ $subsections 1string }
+{ $see-also "syntax-strings" "sbufs" "unicode" "io.encodings" } ;
ABOUT: "strings"
} ;
ARTICLE: "syntax-strings" "Character and string syntax"
-"Factor has no distinct character type, however Unicode character value integers can be read by specifying a literal character, or an escaped representation thereof."
+"Factor has no distinct character type. Integers representing Unicode code points can be read by specifying a literal character, or an escaped representation thereof."
{ $subsections
POSTPONE: CHAR:
POSTPONE: "
$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"
HELP: CHAR:
{ $syntax "CHAR: token" }
-{ $values { "token" "a literal character, escape code, or Unicode character name" } }
+{ $values { "token" "a literal character, escape code, or Unicode code point name" } }
{ $description "Adds a Unicode code point to the parse tree." }
{ $examples
{ $code
"DEFER:" [
scan current-vocab create
- [ fake-definition ] [ set-word ] [ [ undefined ] define ] tri
+ [ fake-definition ] [ set-word ] [ undefined-def define ] tri
] define-core-syntax
"ALIAS:" [
{ $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
"There are several ways of creating an uninterned word:"
{ $subsections
<word>
+ <uninterned-word>
gensym
define-temp
} ;
"Deferred words are just compound definitions in disguise. The following two lines are equivalent:"
{ $code
"DEFER: foo"
- ": foo undefined ;"
+ ": foo ( -- * ) undefined ;"
} ;
ARTICLE: "declarations" "Compiler declarations"
{ deferred POSTPONE: DEFER: } related-words
+HELP: undefined
+{ $error-description "This error is thrown in two cases, and the debugger's summary message reflects the cause:"
+ { $list
+ { "A word was executed before being compiled. For example, this can happen if a macro is defined in the same compilation unit where it was used. See " { $link "compilation-units" } " for a discussion." }
+ { "A word defined with " { $link POSTPONE: DEFER: } " was executed. Since this syntax is usually used for mutually-recursive word definitions, executing a deferred word usually indicates a programmer mistake." }
+ }
+} ;
+
HELP: primitive
{ $description "The class of primitive words." } ;
HELP: <word> ( name vocab -- word )
{ $values { "name" string } { "vocab" string } { "word" word } }
-{ $description "Allocates an uninterned word with the specified name and vocabulary, and a blank word property hashtable. User code should call " { $link gensym } " to create uninterned words and " { $link create } " to create interned words." }
+{ $description "Allocates a word with the specified name and vocabulary. User code should call " { $link <uninterned-word> } " to create uninterned words and " { $link create } " to create interned words, instead of calling this constructor directly." }
{ $notes "This word must be called from inside " { $link with-compilation-unit } "." } ;
+HELP: <uninterned-word> ( name -- word )
+{ $values { "name" string } { "word" word } }
+{ $description "Creates an uninterned word with the specified name, that is not equal to any other word in the system." }
+{ $notes "Unlike " { $link create } ", this word does not have to be called from inside " { $link with-compilation-unit } "." } ;
+
HELP: gensym
{ $values { "word" word } }
{ $description "Creates an uninterned word that is not equal to any other word in the system." }
"( gensym )"
}
}
-{ $notes "Gensyms are often used as placeholder values that have no meaning of their own but must be unique. For example, the compiler uses gensyms to label sections of code." } ;
+{ $notes "Unlike " { $link create } ", this word does not have to be called from inside " { $link with-compilation-unit } "." } ;
HELP: bootstrapping?
{ $var-description "Set by the library while bootstrap is in progress. Some parsing words need to behave differently during bootstrap." } ;
FORGET: another-forgotten
: another-forgotten ( -- ) ;
+! Make sure that undefined words throw proper errors
+DEFER: deferred
+[ deferred ] [ T{ undefined f deferred } = ] must-fail-with
-DEFER: x
-[ x ] [ undefined? ] must-fail-with
+[ "IN: words.tests DEFER: not-compiled << not-compiled >>" eval( -- ) ]
+[ error>> [ undefined? ] [ word>> name>> "not-compiled" = ] bi and ] must-fail-with
+
+[ ] [ "IN: words.tests FORGET: not-compiled" eval( -- ) ] unit-test
[ ] [ [ "no-loc" "words.tests" create drop ] with-compilation-unit ] unit-test
[ f ] [ "no-loc" "words.tests" lookup where ] unit-test
[ { } ]
[
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
: reset-props ( word seq -- ) [ remove-word-prop ] with each ;
-ERROR: undefined ;
+<PRIVATE
-PREDICATE: deferred < word ( obj -- ? ) def>> [ undefined ] = ;
+: caller ( callstack -- word ) callstack>array <reversed> third ;
+
+PRIVATE>
+
+TUPLE: undefined word ;
+: undefined ( -- * ) callstack caller \ undefined boa throw ;
+
+: undefined-def ( -- quot )
+ #! 'f' inhibits tail call optimization in non-optimizing
+ #! compiler, ensuring that we can pull out the caller word
+ #! above.
+ [ undefined f ] ;
+
+PREDICATE: deferred < word ( obj -- ? ) def>> undefined-def = ;
M: deferred definer drop \ DEFER: f ;
M: deferred definition drop f ;
: 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"
2dup [ hashcode ] bi@ bitxor >fixnum (word) dup new-word ;
: <uninterned-word> ( name -- word )
- f \ <uninterned-word> counter >fixnum (word) ;
+ f \ <uninterned-word> counter >fixnum (word)
+ new-words get [ dup new-word ] when ;
: gensym ( -- word )
"( gensym )" <uninterned-word> ;
: 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 ;
[ days-per-year v*n ] [ solar-mass * ] bi* body <struct-boa> ; inline
: <jupiter> ( -- body )
- double-4{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 0.0 }
+ double-4{ 4.84143144246472090e00 -1.16032004402742839e00 -1.03622044471123109e-01 0.0 }
double-4{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 0.0 }
9.54791938424326609e-04
<body> ;
: <saturn> ( -- body )
- double-4{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 0.0 }
+ double-4{ 8.34336671824457987e00 4.12479856412430479e00 -4.03523417114321381e-01 0.0 }
double-4{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 0.0 }
2.85885980666130812e-04
<body> ;
: <uranus> ( -- body )
- double-4{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 0.0 }
+ double-4{ 1.28943695621391310e01 -1.51111514016986312e01 -2.23307578892655734e-01 0.0 }
double-4{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 0.0 }
4.36624404335156298e-05
<body> ;
: <neptune> ( -- body )
- double-4{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 0.0 }
+ double-4{ 1.53796971148509165e01 -2.59193146099879641e01 1.79258772950371181e-01 0.0 }
double-4{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 0.0 }
5.15138902046611451e-05
<body> ;
[ days-per-year v*n ] [ solar-mass * ] bi* body boa ; inline
: <jupiter> ( -- body )
- double-array{ 4.84143144246472090e+00 -1.16032004402742839e+00 -1.03622044471123109e-01 }
+ double-array{ 4.84143144246472090e00 -1.16032004402742839e00 -1.03622044471123109e-01 }
double-array{ 1.66007664274403694e-03 7.69901118419740425e-03 -6.90460016972063023e-05 }
9.54791938424326609e-04
<body> ;
: <saturn> ( -- body )
- double-array{ 8.34336671824457987e+00 4.12479856412430479e+00 -4.03523417114321381e-01 }
+ double-array{ 8.34336671824457987e00 4.12479856412430479e00 -4.03523417114321381e-01 }
double-array{ -2.76742510726862411e-03 4.99852801234917238e-03 2.30417297573763929e-05 }
2.85885980666130812e-04
<body> ;
: <uranus> ( -- body )
- double-array{ 1.28943695621391310e+01 -1.51111514016986312e+01 -2.23307578892655734e-01 }
+ double-array{ 1.28943695621391310e01 -1.51111514016986312e01 -2.23307578892655734e-01 }
double-array{ 2.96460137564761618e-03 2.37847173959480950e-03 -2.96589568540237556e-05 }
4.36624404335156298e-05
<body> ;
: <neptune> ( -- body )
- double-array{ 1.53796971148509165e+01 -2.59193146099879641e+01 1.79258772950371181e-01 }
+ double-array{ 1.53796971148509165e01 -2.59193146099879641e01 1.79258772950371181e-01 }
double-array{ 2.68067772490389322e-03 1.62824170038242295e-03 -9.51592254519715870e-05 }
5.15138902046611451e-05
<body> ;
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
+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 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>number ] 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 f 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, vertex format and material 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 material ;
+
--- /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.obj.private game.models
+game.models.util io.pathnames ;
+IN: game.models.obj
+
+ABOUT: "game.models.obj"
+
+ARTICLE: "game.models.obj" "Conversion of Wavefront OBJ assets"
+"The " { $vocab-link "game.models.obj" } " vocabulary implements words for converting Wavefront OBJ assets to data suitable for use with OpenGL." ;
+
+HELP: material
+{ $class-description "Tuple describing the GPU state that needs to be applied prior to rendering geometry tagged with this material." } ;
+
+HELP: cm
+{ $values { "current-material" material } }
+{ $description "Convenience word for accessing the current material while parsing primitives." } ;
+
+HELP: md
+{ $values { "material-dictionary" assoc } }
+{ $description "Convenience word for accessing the material dictionary while parsing primitives. " } ;
+
+HELP: strings>numbers
+{ $values { "strings" sequence } { "numbers" sequence } }
+{ $description "Convert a sequence of strings to a sequence of numbers." } ;
+
+HELP: strings>faces
+{ $values { "strings" sequence } { "faces" sequence } }
+{ $description "Convert a sequence of '/'-delimited strings into a sequence of sequences of numbers. Each number is an index into the vertex, texture or normal tables, respectively." } ;
+
+HELP: split-string
+{ $values { "string" string } { "strings" sequence } }
+{ $description "Split the given string on whitespace." } ;
+
+HELP: line>mtl
+{ $values { "line" string } }
+{ $description "Process a line from a material file within the current parsing context." } ;
+
+HELP: read-mtl
+{ $values { "file" pathname } { "material-dictionary" assoc } }
+{ $description "Read the specified material file and generate a material dictionary keyed by material name." } ;
+
+HELP: obj-vertex-format
+{ $class-description "Vertex format used for rendering OBJ geometry." } ;
+
+HELP: triangle>aos
+{ $values { "x" sequence } { "y" sequence } }
+{ $description "Convert a sequence of vertex, texture and normal indices into a sequence of vertex, texture and normal values." } ;
+
+HELP: quad>aos
+{ $values { "x" sequence } { "y" sequence } { "z" sequence } }
+{ $description "Convert a sequence of vertex, texture and normal indices into two sequences of vertex, texture and normal values. This splits a quad into two triangles." } ;
+
+HELP: face>aos
+{ $values { "x" sequence } { "y" sequence } }
+{ $description "Convert a face line to a sequence of vertex attributes." } ;
+
+HELP: push*
+{ $values { "elt" "an object" } { "seq" sequence } { "seq" sequence } }
+{ $description "Push the value onto the sequence, keeping the sequence on the stack." } ;
+
+HELP: push-current-model
+{ $description "Push the current model being built onto the models list and initialize a fresh empty model." } ;
+
+HELP: line>obj
+{ $values { "line" string } }
+{ $description "Process a line from the object file within the current parsing context." } ;
+
--- /dev/null
+! Copyright (C) 2010 Erik Charlebois
+! 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
+game.models.util gpu.shaders images game.models.loader
+prettyprint ;
+IN: game.models.obj
+
+SINGLETON: obj-models
+"obj" ascii obj-models register-models-class
+
+<PRIVATE
+SYMBOLS: vp vt vn current-model current-material material-dictionary models ;
+
+TUPLE: material
+ { name initial: f }
+ { ambient-reflectivity initial: { 1.0 1.0 1.0 } }
+ { diffuse-reflectivity initial: { 1.0 1.0 1.0 } }
+ { specular-reflectivity initial: { 1.0 1.0 1.0 } }
+ { transmission-filter initial: { 1.0 1.0 1.0 } }
+ { dissolve initial: 1.0 }
+ { specular-exponent initial: 10.0 }
+ { refraction-index initial: 1.5 }
+ { ambient-map initial: f }
+ { diffuse-map initial: f }
+ { specular-map initial: f }
+ { specular-exponent-map initial: f }
+ { dissolve-map initial: f }
+ { displacement-map initial: f }
+ { bump-map initial: f }
+ { reflection-map initial: f } ;
+
+: cm ( -- current-material ) current-material get ; inline
+: md ( -- material-dictionary ) material-dictionary get ; inline
+
+: strings>numbers ( strings -- numbers )
+ [ string>number ] map ;
+
+: strings>faces ( strings -- faces )
+ [ "/" split [ string>number ] map ] map ;
+
+: split-string ( string -- strings )
+ " \t\n" split harvest ;
+
+: line>mtl ( line -- )
+ " \t\n" split harvest
+ [
+ [ rest ] [ first ] bi
+ {
+ { "newmtl" [ first
+ [ material new swap >>name current-material set ]
+ [ cm swap md set-at ] bi
+ ] }
+ { "Ka" [ 3 head strings>numbers cm (>>ambient-reflectivity) ] }
+ { "Kd" [ 3 head strings>numbers cm (>>diffuse-reflectivity) ] }
+ { "Ks" [ 3 head strings>numbers cm (>>specular-reflectivity) ] }
+ { "Tf" [ 3 head strings>numbers cm (>>transmission-filter) ] }
+ { "d" [ first string>number cm (>>dissolve) ] }
+ { "Ns" [ first string>number cm (>>specular-exponent) ] }
+ { "Ni" [ first string>number cm (>>refraction-index) ] }
+ { "map_Ka" [ first cm (>>ambient-map) ] }
+ { "map_Kd" [ first cm (>>diffuse-map) ] }
+ { "map_Ks" [ first cm (>>specular-map) ] }
+ { "map_Ns" [ first cm (>>specular-exponent-map) ] }
+ { "map_d" [ first cm (>>dissolve-map) ] }
+ { "map_bump" [ first cm (>>bump-map) ] }
+ { "bump" [ first cm (>>bump-map) ] }
+ { "disp" [ first cm (>>displacement-map) ] }
+ { "refl" [ first cm (>>reflection-map) ] }
+ [ 2drop ]
+ } case
+ ] unless-empty ;
+
+: read-mtl ( file -- material-dictionary )
+ [
+ f current-material set
+ H{ } clone material-dictionary set
+ ] H{ } make-assoc
+ [
+ ascii file-lines [ line>mtl ] each
+ md
+ ] bind ;
+
+VERTEX-FORMAT: obj-vertex-format
+ { "POSITION" float-components 3 f }
+ { "TEXCOORD" float-components 2 f }
+ { "NORMAL" float-components 3 f } ;
+
+: triangle>aos ( x -- y )
+ dup length
+ {
+ { 3 [
+ first3
+ [ 1 - vp get nth ]
+ [ 1 - vt get nth ]
+ [ 1 - vn get nth ] tri* 3array flatten
+ ] }
+ { 2 [
+ first2
+ [ 1 - vp get nth ]
+ [ 1 - vt get nth ] bi* 2array flatten
+ ] }
+ } case ;
+
+: quad>aos ( x -- y z )
+ [ 3 head [ triangle>aos 1array ] map ]
+ [ [ 2 swap nth ]
+ [ 3 swap nth ]
+ [ 0 swap nth ] tri 3array
+ [ triangle>aos 1array ] map ]
+ bi ;
+
+: face>aos ( x -- y )
+ dup length
+ {
+ { 3 [ [ triangle>aos 1array ] map 1array ] }
+ { 4 [ quad>aos 2array ] }
+ } case ;
+
+: push* ( elt seq -- seq )
+ [ push ] keep ;
+
+: push-current-model ( -- )
+ current-model get [
+ [ dseq>> flatten >float-array ]
+ [ iseq>> flatten >uint-array ]
+ bi obj-vertex-format current-material get model boa models get push
+ V{ } V{ } H{ } <indexed-seq> current-model set
+ ] unless-empty ;
+
+: line>obj ( line -- )
+ split-string
+ [
+ [ rest ] [ first ] bi
+ {
+ { "mtllib" [ first read-mtl material-dictionary set ] }
+ { "v" [ strings>numbers 3 head vp [ push* ] change ] }
+ { "vt" [ strings>numbers 2 head vt [ push* ] change ] }
+ { "vn" [ strings>numbers 3 head vn [ push* ] change ] }
+ { "usemtl" [ push-current-model first md at current-material set ] }
+ { "f" [ strings>faces face>aos [ [ current-model [ push* ] change ] each ] each ] }
+ [ 2drop ]
+ } case
+ ] unless-empty ;
+
+PRIVATE>
+
+M: obj-models stream>models
+ drop
+ [
+ V{ } clone vp set
+ V{ } clone vt set
+ V{ } clone vn set
+ V{ } clone models set
+ V{ } V{ } H{ } <indexed-seq> current-model set
+ f current-material set
+ f material-dictionary set
+ ] H{ } make-assoc
+ [
+ [ line>obj ] each-stream-line push-current-model
+ models get
+ ] bind ;
+
--- /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: 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 ;
+
}
{ $description "Discards any memory currently held by " { $snippet "buffer" } " and reallocates a new memory block of " { $snippet "size" } " bytes for it. If " { $snippet "initial-data" } " is not " { $link f } ", " { $snippet "size" } " bytes are copied from " { $snippet "initial-data" } " into the buffer to initialize it; otherwise, the buffer content is left uninitialized." } ;
+HELP: allocate-byte-array
+{ $values
+ { "buffer" buffer } { "byte-array" byte-array }
+}
+{ $description "Discards any memory currently held by " { $snippet "buffer" } " and reallocates a new memory block large enough to store " { $snippet "byte-array" } ". The contents of " { $snippet "byte-array" } " are then copied into the buffer." } ;
+
HELP: buffer
{ $class-description "Objects of this class represent GPU-accessible memory buffers. Buffer objects can be used to store vertex data and to update or read pixel data from textures and framebuffers without CPU involvement. The data inside buffer objects may be resident in main memory or different parts of GPU memory; the graphics driver will choose a location for a buffer based on usage hints specified when the buffer object is constructed with " { $link <buffer> } " or " { $link byte-array>buffer } ":"
{ $list
}
{ $description "Maps " { $snippet "buffer" } " into CPU address space with " { $snippet "access" } " for the dynamic extent of " { $snippet "quot" } ". " { $snippet "quot" } " is called with a pointer to the mapped memory on top of the stack." } ;
-{ allocate-buffer buffer-size update-buffer read-buffer copy-buffer with-mapped-buffer } related-words
+{ allocate-buffer allocate-byte-array buffer-size update-buffer read-buffer copy-buffer with-mapped-buffer } related-words
HELP: write-access
{ $class-description "This " { $link buffer-access-mode } " value requests write-only access when mapping a buffer object through " { $link with-mapped-buffer } "." } ;
"Manipulating buffer data:"
{ $subsections
allocate-buffer
+ allocate-byte-array
update-buffer
read-buffer
copy-buffer
2dup [ buffer-size ] dip -
buffer-range boa ; inline
-TYPED:: allocate-buffer ( buffer: buffer size: integer initial-data -- )
+:: allocate-buffer ( buffer size initial-data -- )
buffer bind-buffer :> target
- target size initial-data buffer gl-buffer-usage glBufferData ;
+ target size initial-data buffer gl-buffer-usage glBufferData ; inline
+
+: allocate-byte-array ( buffer byte-array -- )
+ [ byte-length ] [ ] bi allocate-buffer ; inline
TYPED: <buffer> ( upload: buffer-upload-pattern
usage: buffer-usage-pattern
[ 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 )
} cleave ;
: merge-frames ( id3 assoc -- id3 )
- [ dup frames>> ] dip update ;
+ [ dup frames>> ] dip assoc-union! drop ;
: merge-id3v1 ( id3 -- id3 )
dup id3v1>frames frames>assoc merge-frames ;
--- /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 ;
+
+: make-atlas-assoc ( image-assoc -- texcoord-assoc atlas-image )
+ dup values make-atlas [ '[ _ at ] assoc-map ] dip ;
--- /dev/null
+Tool for generating an atlas image from an array of images
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: tools.deploy.config ;
-V{
- { deploy-ui? t }
- { deploy-io 1 }
- { deploy-reflection 1 }
- { deploy-math? t }
- { deploy-word-props? f }
- { deploy-c-types? f }
- { "stop-after-last-window?" t }
- { deploy-name "Jamshred" }
-}
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
-IN: jamshred.game
-
-TUPLE: jamshred sounds tunnel players running quit ;
-
-: <jamshred> ( -- jamshred )
- <sounds> <random-tunnel> "Player 1" pick <player>
- 2dup swap play-in-tunnel 1array f f jamshred boa ;
-
-: jamshred-player ( jamshred -- player )
- ! TODO: support more than one player
- players>> first ;
-
-: jamshred-update ( jamshred -- )
- dup running>> [
- jamshred-player update-player
- ] [ drop ] if ;
-
-: toggle-running ( jamshred -- )
- dup running>> [
- f >>running drop
- ] [
- [ jamshred-player moved ]
- [ t >>running drop ] bi
- ] if ;
-
-: mouse-moved ( x-radians y-radians jamshred -- )
- jamshred-player -rot turn-player ;
-
-CONSTANT: units-per-full-roll 50
-
-: jamshred-roll ( jamshred n -- )
- [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
-
-: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
-
-: mouse-scroll-y ( jamshred y -- )
- neg swap jamshred-player change-player-speed ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien.c-types jamshred.game jamshred.oint
-jamshred.player jamshred.tunnel kernel math math.constants
-math.functions math.vectors opengl opengl.gl opengl.glu
-opengl.demo-support sequences specialized-arrays locals ;
-FROM: alien.c-types => float ;
-SPECIALIZED-ARRAY: float
-IN: jamshred.gl
-
-CONSTANT: min-vertices 6
-CONSTANT: max-vertices 32
-
-CONSTANT: n-vertices 32
-
-! render enough of the tunnel that it looks continuous
-CONSTANT: n-segments-ahead 60
-CONSTANT: n-segments-behind 40
-
-! so that we can't see through the wall, we draw it a bit further away
-CONSTANT: wall-drawing-offset 0.15
-
-: wall-drawing-radius ( segment -- r )
- radius>> wall-drawing-offset + ;
-
-: wall-up ( segment -- v )
- [ wall-drawing-radius ] [ up>> ] bi n*v ;
-
-: wall-left ( segment -- v )
- [ wall-drawing-radius ] [ left>> ] bi n*v ;
-
-: segment-vertex ( theta segment -- vertex )
- [
- [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
- ] [
- location>> v+
- ] bi ;
-
-: segment-vertex-normal ( vertex segment -- normal )
- location>> swap v- normalize ;
-
-: segment-vertex-and-normal ( segment theta -- vertex normal )
- swap [ segment-vertex ] keep dupd segment-vertex-normal ;
-
-: equally-spaced-radians ( n -- seq )
- #! return a sequence of n numbers between 0 and 2pi
- [ iota ] keep [ / pi 2 * * ] curry map ;
-
-: draw-segment-vertex ( segment theta -- )
- over color>> gl-color segment-vertex-and-normal
- gl-normal gl-vertex ;
-
-:: draw-vertex-pair ( theta next-segment segment -- )
- segment theta draw-segment-vertex
- next-segment theta draw-segment-vertex ;
-
-: draw-segment ( next-segment segment -- )
- GL_QUAD_STRIP [
- [ draw-vertex-pair ] 2curry
- n-vertices equally-spaced-radians float-array{ 0.0 } append swap each
- ] do-state ;
-
-: draw-segments ( segments -- )
- 1 over length pick subseq swap [ draw-segment ] 2each ;
-
-: segments-to-render ( player -- segments )
- dup nearest-segment>> number>> dup n-segments-behind -
- swap n-segments-ahead + rot tunnel>> sub-tunnel ;
-
-: draw-tunnel ( player -- )
- segments-to-render draw-segments ;
-
-: init-graphics ( -- )
- GL_DEPTH_TEST glEnable
- GL_SCISSOR_TEST glDisable
- 1.0 glClearDepth
- 0.0 0.0 0.0 0.0 glClearColor
- GL_PROJECTION glMatrixMode glPushMatrix
- GL_MODELVIEW glMatrixMode glPushMatrix
- GL_LEQUAL glDepthFunc
- GL_LIGHTING glEnable
- GL_LIGHT0 glEnable
- GL_FOG glEnable
- GL_FOG_DENSITY 0.09 glFogf
- GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
- GL_COLOR_MATERIAL glEnable
- GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
- GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
-
-: cleanup-graphics ( -- )
- GL_DEPTH_TEST glDisable
- GL_SCISSOR_TEST glEnable
- GL_MODELVIEW glMatrixMode glPopMatrix
- GL_PROJECTION glMatrixMode glPopMatrix
- GL_LIGHTING glDisable
- GL_LIGHT0 glDisable
- GL_FOG glDisable
- GL_COLOR_MATERIAL glDisable ;
-
-: pre-draw ( width height -- )
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- GL_PROJECTION glMatrixMode glLoadIdentity
- dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
- GL_MODELVIEW glMatrixMode glLoadIdentity ;
-
-: player-view ( player -- )
- [ location>> ]
- [ [ location>> ] [ forward>> ] bi v+ ]
- [ up>> ] tri gl-look-at ;
-
-: draw-jamshred ( jamshred width height -- )
- pre-draw jamshred-player [ player-view ] [ draw-tunnel ] bi ;
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.rectangles math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
-IN: jamshred
-
-TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
-
-: <jamshred-gadget> ( jamshred -- gadget )
- jamshred-gadget new swap >>jamshred ;
-
-CONSTANT: default-width 800
-CONSTANT: default-height 600
-
-M: jamshred-gadget pref-dim*
- drop default-width default-height 2array ;
-
-M: jamshred-gadget draw-gadget* ( gadget -- )
- [ jamshred>> ] [ dim>> first2 draw-jamshred ] bi ;
-
-: jamshred-loop ( gadget -- )
- dup jamshred>> quit>> [
- drop
- ] [
- [ jamshred>> jamshred-update ]
- [ relayout-1 ]
- [ 100 milliseconds sleep jamshred-loop ] tri
- ] if ;
-
-M: jamshred-gadget graft* ( gadget -- )
- [ find-gl-context init-graphics ]
- [ [ jamshred-loop ] curry in-thread ] bi ;
-
-M: jamshred-gadget ungraft* ( gadget -- )
- dup find-gl-context cleanup-graphics jamshred>> t swap (>>quit) ;
-
-: jamshred-restart ( jamshred-gadget -- )
- <jamshred> >>jamshred drop ;
-
-: pix>radians ( n m -- theta )
- / pi 4 * * ; ! 2 / / pi 2 * * ;
-
-: x>radians ( x gadget -- theta )
- #! translate motion of x pixels to an angle
- dim>> first pix>radians neg ;
-
-: y>radians ( y gadget -- theta )
- #! translate motion of y pixels to an angle
- dim>> second pix>radians ;
-
-: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
- dupd [ first swap x>radians ] [ second swap y>radians ] 2bi
- rot jamshred>> mouse-moved ;
-
-: handle-mouse-motion ( jamshred-gadget -- )
- hand-loc get [
- over last-hand-loc>> [
- v- (handle-mouse-motion)
- ] [ 2drop ] if*
- ] 2keep >>last-hand-loc drop ;
-
-: handle-mouse-scroll ( jamshred-gadget -- )
- jamshred>> scroll-direction get
- [ first mouse-scroll-x ]
- [ second mouse-scroll-y ] 2bi ;
-
-: quit ( gadget -- )
- [ f set-fullscreen ] [ close-window ] bi ;
-
-jamshred-gadget H{
- { T{ key-down f f "r" } [ jamshred-restart ] }
- { T{ key-down f f " " } [ jamshred>> toggle-running ] }
- { T{ key-down f f "f" } [ toggle-fullscreen ] }
- { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
- { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
- { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
- { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
- { T{ key-down f f "q" } [ quit ] }
- { motion [ handle-mouse-motion ] }
- { mouse-scroll [ handle-mouse-scroll ] }
-} set-gestures
-
-MAIN-WINDOW: jamshred-window { { title "Jamshred" } }
- <jamshred> <jamshred-gadget> >>gadgets ;
+++ /dev/null
-USING: kernel logging ;
-IN: jamshred.log
-
-LOG: (jamshred-log) DEBUG
-
-: with-jamshred-log ( quot -- )
- "jamshred" swap with-logging ; inline
-
-: jamshred-log ( message -- )
- [ (jamshred-log) ] with-jamshred-log ; ! ugly...
+++ /dev/null
-Alex Chapman
+++ /dev/null
-USING: jamshred.oint tools.test ;
-IN: jamshred.oint-tests
-
-[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
-[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
-[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
-[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
-[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
-IN: jamshred.oint
-
-! An oint is a point with three linearly independent unit vectors
-! given relative to that point. In jamshred a player's location and
-! direction are given by the player's oint. Similarly, a tunnel
-! segment's location and orientation are given by an oint.
-
-TUPLE: oint location forward up left ;
-C: <oint> oint
-
-: rotation-quaternion ( theta axis -- quaternion )
- swap 2 / dup cos swap sin rot n*v first3 rect> [ rect> ] dip 2array ;
-
-: rotate-vector ( q qrecip v -- v )
- v>q swap q* q* q>v ;
-
-: rotate-oint ( oint theta axis -- )
- rotation-quaternion dup qrecip pick
- [ forward>> rotate-vector >>forward ]
- [ up>> rotate-vector >>up ]
- [ left>> rotate-vector >>left ] 3tri drop ;
-
-: left-pivot ( oint theta -- )
- over left>> rotate-oint ;
-
-: up-pivot ( oint theta -- )
- over up>> rotate-oint ;
-
-: forward-pivot ( oint theta -- )
- over forward>> rotate-oint ;
-
-: random-float+- ( n -- m )
- #! find a random float between -n/2 and n/2
- dup 10000 * >integer random 10000 / swap 2 / - ;
-
-: random-turn ( oint theta -- )
- 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
-
-: location+ ( v oint -- )
- [ location>> v+ ] [ (>>location) ] bi ;
-
-: go-forward ( distance oint -- )
- [ forward>> n*v ] [ location+ ] bi ;
-
-: distance-vector ( oint oint -- vector )
- [ location>> ] bi@ swap v- ;
-
-: distance ( oint oint -- distance )
- distance-vector norm ;
-
-: scalar-projection ( v1 v2 -- n )
- #! the scalar projection of v1 onto v2
- [ v. ] [ norm ] bi / ;
-
-: proj-perp ( u v -- w )
- dupd proj v- ;
-
-: perpendicular-distance ( oint oint -- distance )
- [ distance-vector ] keep 2dup left>> scalar-projection abs
- -rot up>> scalar-projection abs + ;
-
-:: reflect ( v n -- v' )
- #! bounce v on a surface with normal n
- v v n v. n n v. / 2 * n n*v v- ;
-
-: half-way ( p1 p2 -- p3 )
- over v- 2 v/n v+ ;
-
-: half-way-between-oints ( o1 o2 -- p )
- [ location>> ] bi@ half-way ;
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors colors.constants combinators jamshred.log
-jamshred.oint jamshred.sound jamshred.tunnel kernel locals math
-math.constants math.order math.ranges math.vectors math.matrices
-sequences shuffle specialized-arrays strings system ;
-QUALIFIED-WITH: alien.c-types c
-SPECIALIZED-ARRAY: c:float
-IN: jamshred.player
-
-TUPLE: player < oint
- { name string }
- { sounds sounds }
- tunnel
- nearest-segment
- { last-move integer }
- { speed float } ;
-
-! speeds are in GL units / second
-CONSTANT: default-speed 1.0
-CONSTANT: max-speed 30.0
-
-: <player> ( name sounds -- player )
- [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
- f f 0 default-speed player boa ;
-
-: turn-player ( player x-radians y-radians -- )
- [ over ] dip left-pivot up-pivot ;
-
-: roll-player ( player z-radians -- )
- forward-pivot ;
-
-: to-tunnel-start ( player -- )
- dup tunnel>> first
- [ >>nearest-segment ]
- [ location>> >>location ] bi drop ;
-
-: play-in-tunnel ( player segments -- )
- >>tunnel to-tunnel-start ;
-
-: update-time ( player -- seconds-passed )
- system-micros swap [ last-move>> - 1000000 / ] [ (>>last-move) ] 2bi ;
-
-: moved ( player -- ) system-micros swap (>>last-move) ;
-
-: speed-range ( -- range )
- max-speed [0,b] ;
-
-: change-player-speed ( inc player -- )
- [ + 0 max-speed clamp ] change-speed drop ;
-
-: multiply-player-speed ( n player -- )
- [ * 0 max-speed clamp ] change-speed drop ;
-
-: distance-to-move ( seconds-passed player -- distance )
- speed>> * ;
-
-: bounce ( d-left player -- d-left' player )
- {
- [ dup nearest-segment>> bounce-off-wall ]
- [ sounds>> bang ]
- [ 3/4 swap multiply-player-speed ]
- [ ]
- } cleave ;
-
-:: (distance) ( heading player -- current next location heading )
- player nearest-segment>>
- player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
- player location>> heading ;
-
-: distance-to-heading-segment ( heading player -- distance )
- (distance) distance-to-next-segment ;
-
-: distance-to-heading-segment-area ( heading player -- distance )
- (distance) distance-to-next-segment-area ;
-
-: distance-to-collision ( player -- distance )
- dup nearest-segment>> (distance-to-collision) ;
-
-: almost-to-collision ( player -- distance )
- distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
-
-: from ( player -- radius distance-from-centre )
- [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
- distance-from-centre ;
-
-: distance-from-wall ( player -- distance ) from - ;
-: fraction-from-centre ( player -- fraction ) from swap / ;
-: fraction-from-wall ( player -- fraction )
- fraction-from-centre 1 swap - ;
-
-: update-nearest-segment2 ( heading player -- )
- 2dup distance-to-heading-segment-area 0 <= [
- [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
- [ (>>nearest-segment) ] tri
- ] [
- 2drop
- ] if ;
-
-:: move-player-on-heading ( d-left player distance heading -- d-left' player )
- d-left distance min :> d-to-move
- d-to-move heading n*v :> move-v
-
- move-v player location+
- heading player update-nearest-segment2
- d-left d-to-move - player ;
-
-: distance-to-move-freely ( player -- distance )
- [ almost-to-collision ]
- [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
-
-: ?move-player-freely ( d-left player -- d-left' player )
- over 0 > [
- ! must make sure we are moving a significant distance, otherwise
- ! we can recurse endlessly due to floating-point imprecision.
- ! (at least I /think/ that's what causes it...)
- dup distance-to-move-freely dup 0.1 > [
- over forward>> move-player-on-heading ?move-player-freely
- ] [ drop ] if
- ] when ;
-
-: drag-heading ( player -- heading )
- [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
-
-: drag-player ( d-left player -- d-left' player )
- dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
- [ drag-heading move-player-on-heading ] bi ;
-
-: (move-player) ( d-left player -- d-left' player )
- ?move-player-freely over 0 > [
- ! bounce
- drag-player
- (move-player)
- ] when ;
-
-: move-player ( player -- )
- [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
-
-: update-player ( player -- )
- [ move-player ] [ nearest-segment>> "white" named-color swap (>>color) ] bi ;
+++ /dev/null
-! Copyright (C) 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors io.pathnames kernel openal sequences ;
-IN: jamshred.sound
-
-TUPLE: sounds bang ;
-
-: assign-sound ( source wav-path -- )
- resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
-
-: <sounds> ( -- sounds )
- init-openal 1 gen-sources first sounds boa
- dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
-
-: bang ( sounds -- ) bang>> source-play check-error ;
+++ /dev/null
-A simple 3d tunnel racing game
+++ /dev/null
-applications
-games
+++ /dev/null
-Alex Chapman
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays jamshred.oint jamshred.tunnel kernel
-math.vectors sequences specialized-arrays tools.test
-alien.c-types ;
-SPECIALIZED-ARRAY: float
-IN: jamshred.tunnel.tests
-
-: test-segment-oint ( -- oint )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
-
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
-[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
-[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
-[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
-[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
-
-: simplest-straight-ahead ( -- oint segment )
- { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
-[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
-
-: simple-collision-up ( -- oint segment )
- { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
- initial-segment ;
-
-[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
-[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
-[ { 0.0 1.0 0.0 } ]
-[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
+++ /dev/null
-! Copyright (C) 2007, 2008 Alex Chapman
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays colors combinators fry jamshred.oint
-kernel literals locals math math.constants math.matrices
-math.order math.quadratic math.ranges math.vectors random
-sequences specialized-arrays vectors ;
-FROM: jamshred.oint => distance ;
-FROM: alien.c-types => float ;
-SPECIALIZED-ARRAY: float
-IN: jamshred.tunnel
-
-CONSTANT: n-segments 5000
-
-TUPLE: segment < oint number color radius ;
-C: <segment> segment
-
-: segment-number++ ( segment -- )
- [ number>> 1 + ] keep (>>number) ;
-
-: clamp-length ( n seq -- n' )
- 0 swap length clamp ;
-
-: random-color ( -- color )
- { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
-
-CONSTANT: tunnel-segment-distance 0.4
-CONSTANT: random-rotation-angle $[ pi 20 / ]
-
-: random-segment ( previous-segment -- segment )
- clone dup random-rotation-angle random-turn
- tunnel-segment-distance over go-forward
- random-color >>color dup segment-number++ ;
-
-: (random-segments) ( segments n -- segments )
- dup 0 > [
- [ dup last random-segment over push ] dip 1 - (random-segments)
- ] [ drop ] if ;
-
-CONSTANT: default-segment-radius 1
-
-: initial-segment ( -- segment )
- float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
- 0 random-color default-segment-radius <segment> ;
-
-: random-segments ( n -- segments )
- initial-segment 1vector swap (random-segments) ;
-
-: simple-segment ( n -- segment )
- [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
- random-color default-segment-radius <segment> ;
-
-: simple-segments ( n -- segments )
- [ simple-segment ] map ;
-
-: <random-tunnel> ( -- segments )
- n-segments random-segments ;
-
-: <straight-tunnel> ( -- segments )
- n-segments simple-segments ;
-
-: sub-tunnel ( from to segments -- segments )
- #! return segments between from and to, after clamping from and to to
- #! valid values
- [ '[ _ clamp-length ] bi@ ] keep <slice> ;
-
-: get-segment ( segments n -- segment )
- over clamp-length swap nth ;
-
-: next-segment ( segments current-segment -- segment )
- number>> 1 + get-segment ;
-
-: previous-segment ( segments current-segment -- segment )
- number>> 1 - get-segment ;
-
-: heading-segment ( segments current-segment heading -- segment )
- #! the next segment on the given heading
- over forward>> v. 0 <=> {
- { +gt+ [ next-segment ] }
- { +lt+ [ previous-segment ] }
- { +eq+ [ nip ] } ! current segment
- } case ;
-
-:: distance-to-next-segment ( current next location heading -- distance )
- current forward>> :> cf
- cf next location>> v. cf location v. - cf heading v. / ;
-
-:: distance-to-next-segment-area ( current next location heading -- distance )
- current forward>> :> cf
- next current half-way-between-oints :> h
- cf h v. cf location v. - cf heading v. / ;
-
-: vector-to-centre ( seg loc -- v )
- over location>> swap v- swap forward>> proj-perp ;
-
-: distance-from-centre ( seg loc -- distance )
- vector-to-centre norm ;
-
-: wall-normal ( seg oint -- n )
- location>> vector-to-centre normalize ;
-
-CONSTANT: distant 1000
-
-: max-real ( a b -- c )
- #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
- dup real? [
- over real? [ max ] [ nip ] if
- ] [
- drop dup real? [ drop distant ] unless
- ] if ;
-
-:: collision-coefficient ( v w r -- c )
- v norm 0 = [
- distant
- ] [
- v dup v. :> a
- v w v. 2 * :> b
- w dup v. r sq - :> c
- c b a quadratic max-real
- ] if ;
-
-: sideways-heading ( oint segment -- v )
- [ forward>> ] bi@ proj-perp ;
-
-: sideways-relative-location ( oint segment -- loc )
- [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
-
-: (distance-to-collision) ( oint segment -- distance )
- [ sideways-heading ] [ sideways-relative-location ]
- [ nip radius>> ] 2tri collision-coefficient ;
-
-: collision-vector ( oint segment -- v )
- dupd (distance-to-collision) swap forward>> n*v ;
-
-: bounce-forward ( segment oint -- )
- [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
-
-: bounce-left ( segment oint -- )
- #! must be done after forward
- [ forward>> vneg ] dip [ left>> swap reflect ]
- [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
-
-: bounce-up ( segment oint -- )
- #! must be done after forward and left!
- nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
-
-: bounce-off-wall ( oint segment -- )
- swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
-
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 -- )
M: word word-vocabulary vocabulary>> ;
-M: method-body word-vocabulary "method-generic" word-prop word-vocabulary ;
+M: method word-vocabulary "method-generic" word-prop word-vocabulary ;
:: do-step ( errors summary-file details-file -- )
errors
[ t ] [ 2 gammaln 1.110223024625157e-16 eps ~ ] unit-test
[ t ] [ 3 gammaln 0.6931471805599456 eps ~ ] unit-test
[ t ] [ 11 gammaln 15.10441257307984 eps ~ ] unit-test
-[ t ] [ 9000000000000000000000000000000000000000000 gammaln 8.811521863477754e+44 eps ~ ] unit-test
+[ t ] [ 9000000000000000000000000000000000000000000 gammaln 8.811521863477754e44 eps ~ ] unit-test
float-4{ 0.5 0.5 0.5 1.0 } scale-matrix4 m4.
float-4{ 2.0 3.0 4.0 1.0 } m4.v
] unit-test
+
+[
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 0.0 }
+ float-4{ 0.0 1.0 0.0 0.0 }
+ float-4{ 0.0 0.0 1.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+] [
+ float-4{ 1.0 0.0 0.0 0.0 } q>matrix4
+] unit-test
+
+[ t ] [
+ pi 0.5 * 0.0 0.0 euler4 q>matrix4
+ S{ matrix4 f
+ float-4-array{
+ float-4{ 1.0 0.0 0.0 0.0 }
+ float-4{ 0.0 0.0 1.0 0.0 }
+ float-4{ 0.0 -1.0 0.0 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ 1.0e-7 m~
+] unit-test
+
+[ t ] [
+ 0.0 pi 0.25 * 0.0 euler4 q>matrix4
+ S{ matrix4 f
+ float-4-array{
+ float-4{ $[ 1/2. sqrt ] 0.0 $[ 1/2. sqrt neg ] 0.0 }
+ float-4{ 0.0 1.0 0.0 0.0 }
+ float-4{ $[ 1/2. sqrt ] 0.0 $[ 1/2. sqrt ] 0.0 }
+ float-4{ 0.0 0.0 0.0 1.0 }
+ }
+ }
+ 1.0e-7 m~
+] unit-test
! (c)Joe Groff bsd license
USING: accessors classes.struct fry generalizations kernel locals
math math.combinatorics math.functions math.matrices.simd math.vectors
-math.vectors.simd sequences sequences.private specialized-arrays
+math.vectors.simd math.quaternions sequences sequences.private specialized-arrays
typed ;
+FROM: sequences.private => nth-unsafe ;
+FROM: math.quaternions.private => (q*sign) ;
QUALIFIED-WITH: alien.c-types c
SPECIALIZED-ARRAY: float-4
IN: math.matrices.simd
:: set-columns ( c1 c2 c3 c4 c -- c )
c columns>> :> columns
- c1 columns set-first
- c2 columns set-second
- c3 columns set-third
- c4 columns set-fourth
+ c1 c2 c3 c4 columns 4 set-firstn-unsafe
c ; inline
: make-matrix4 ( quot: ( -- c1 c2 c3 c4 ) -- c )
] dip
] make-matrix4 ;
+:: (rotation-matrix4) ( diagonal triangle-hi triangle-lo -- matrix )
+ matrix4 (struct) :> triangle-m
+ diagonal scale-matrix4 :> diagonal-m
+
+ triangle-hi { 3 2 1 3 } vshuffle
+ triangle-hi { 3 3 0 3 } vshuffle triangle-lo { 2 3 3 3 } vshuffle vbitor
+ triangle-lo { 1 0 3 3 } vshuffle
+ float-4 new
+
+ triangle-m set-columns drop
+
+ diagonal-m triangle-m m4+ ; inline
+
TYPED:: rotation-matrix4 ( axis: float-4 theta: float -- matrix: matrix4 )
! x*x + c*(1.0 - x*x) x*y*(1.0 - c) + s*z x*z*(1.0 - c) - s*y 0
! x*y*(1.0 - c) - s*z y*y + c*(1.0 - y*y) y*z*(1.0 - c) + s*x 0
! x*z*(1.0 - c) + s*y y*z*(1.0 - c) - s*x z*z + c*(1.0 - z*z) 0
! 0 0 0 1
- matrix4 (struct) :> triangle-m
theta cos :> c
theta sin :> s
triangle-a triangle-b v+ :> triangle-lo
triangle-a triangle-b v- :> triangle-hi
- diagonal scale-matrix4 :> diagonal-m
-
- triangle-hi { 3 2 1 3 } vshuffle
- triangle-hi { 3 3 0 3 } vshuffle triangle-lo { 2 3 3 3 } vshuffle v+
- triangle-lo { 1 0 3 3 } vshuffle
- float-4 new
-
- triangle-m set-columns drop
-
- diagonal-m triangle-m m4+ ;
-
+ diagonal triangle-hi triangle-lo (rotation-matrix4) ;
+
TYPED:: frustum-matrix4 ( xy: float-4 near: float far: float -- matrix: matrix4 )
[
near near near far + 2 near far * * float-4-boa ! num
[ negone (vmerge) ] bi*
] make-matrix4 ;
+! interface with quaternions
+M: float-4 (q*sign)
+ float-4{ -0.0 0.0 0.0 0.0 } vbitxor ; inline
+M: float-4 qconjugate
+ float-4{ 0.0 -0.0 -0.0 -0.0 } vbitxor ; inline
+
+: euler4 ( phi theta psi -- q )
+ float-4{ 0 0 0 0 } euler-like ; inline
+
+TYPED:: q>matrix4 ( q: float-4 -- matrix: matrix4 )
+ ! a*a + b*b - c*c - d*d 2*b*c - 2*a*d 2*b*d + 2*a*c 0
+ ! 2*b*c + 2*a*d a*a - b*b + c*c - d*d 2*c*d - 2*a*b 0
+ ! 2*b*d - 2*a*c 2*c*d + 2*a*b a*a - b*b - c*c + d*d 0
+ ! 0 0 0 1
+ q { 2 1 1 3 } vshuffle q { 3 3 2 3 } vshuffle v* :> triangle-a
+ q { 0 0 0 3 } vshuffle q { 1 2 3 3 } vshuffle v* :> triangle-b
+
+ triangle-a float-4{ 2.0 2.0 2.0 0.0 } v* triangle-b float-4{ -2.0 2.0 -2.0 0.0 } v*
+ [ v- ] [ v+ ] 2bi :> ( triangle-hi triangle-lo )
+
+ q q v* first4 {
+ [ [ + ] [ - ] [ - ] tri* ]
+ [ [ - ] [ + ] [ - ] tri* ]
+ [ [ - ] [ - ] [ + ] tri* ]
+ } 4 ncleave 1.0 float-4-boa :> diagonal
+
+ diagonal triangle-hi triangle-lo (rotation-matrix4) ;
--- /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
+sequences.deep destructors math.bitwise opengl.gl
+game.models game.models.obj game.models.loader game.models.collada
+prettyprint images.tga ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+SPECIALIZED-VECTOR: uint
+IN: model-viewer
+
+GLSL-SHADER: obj-vertex-shader vertex-shader
+uniform mat4 mv_matrix;
+uniform mat4 p_matrix;
+
+attribute vec3 POSITION;
+attribute vec3 TEXCOORD;
+attribute vec3 NORMAL;
+
+varying vec2 texcoord_fs;
+varying vec3 normal_fs;
+varying vec3 world_pos_fs;
+
+void main()
+{
+ vec4 position = mv_matrix * vec4(POSITION, 1.0);
+ gl_Position = p_matrix * position;
+ world_pos_fs = POSITION;
+ texcoord_fs = TEXCOORD;
+ normal_fs = NORMAL;
+}
+;
+
+GLSL-SHADER: obj-fragment-shader fragment-shader
+uniform mat4 mv_matrix, p_matrix;
+uniform sampler2D map_Ka;
+uniform sampler2D map_bump;
+uniform vec3 Ka;
+uniform vec3 view_pos;
+uniform vec3 light;
+varying vec2 texcoord_fs;
+varying vec3 normal_fs;
+varying vec3 world_pos_fs;
+void main()
+{
+ vec4 d = texture2D(map_Ka, texcoord_fs.xy);
+ vec3 b = texture2D(map_bump, texcoord_fs.xy).xyz;
+ vec3 n = normal_fs;
+ vec3 v = normalize(view_pos - world_pos_fs);
+ vec3 l = normalize(light);
+ vec3 h = normalize(v + l);
+ float cosTh = saturate(dot(n, l));
+ gl_FragColor = d * cosTh
+ + d * 0.5 * cosTh * pow(saturate(dot(n, h)), 10.0) ;
+}
+;
+
+GLSL-PROGRAM: obj-program
+ obj-vertex-shader obj-fragment-shader ;
+
+UNIFORM-TUPLE: model-uniforms < mvp-uniforms
+ { "map_Ka" texture-uniform f }
+ { "map_bump" texture-uniform f }
+ { "Ka" vec3-uniform f }
+ { "light" vec3-uniform f }
+ { "view_pos" vec3-uniform f }
+ ;
+
+TUPLE: model-state
+ models
+ vertex-arrays
+ index-vectors
+ textures
+ bumps
+ kas ;
+
+TUPLE: model-world < wasd-world model-path model-state ;
+
+TUPLE: vbo
+ vertex-buffer
+ index-buffer index-count vertex-format texture bump ka ;
+
+: white-image ( -- image )
+ { 1 1 } BGR ubyte-components f
+ B{ 255 255 255 } image boa ;
+
+: up-image ( -- image )
+ { 1 1 } BGR ubyte-components f
+ B{ 0 0 0 } image boa ;
+
+: make-texture ( pathname alt -- texture )
+ swap [ nip load-image ] [ ] if*
+ [
+ [ component-order>> ]
+ [ component-type>> ] bi
+ T{ texture-parameters
+ { wrap repeat-texcoord }
+ { min-filter filter-linear }
+ { min-mipmap-filter f } }
+ <texture-2d>
+ ]
+ [
+ 0 swap [ allocate-texture-image ] 3keep 2drop
+ ] bi ;
+
+: <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>> ]
+ [ material>> ambient-map>> white-image make-texture ]
+ [ material>> bump-map>> up-image make-texture ]
+ [ material>> ambient-reflectivity>> ]
+ } cleave vbo boa
+ ] map ;
+
+: fill-model-state ( model-state -- )
+ dup models>> <model-buffers>
+ {
+ [
+ [
+ [ vertex-buffer>> obj-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
+ ]
+ [ [ texture>> ] map >>textures drop ]
+ [ [ bump>> ] map >>bumps drop ]
+ [ [ ka>> ] map >>kas drop ]
+ } 2cleave ;
+
+: <model-state> ( model-world -- model-state )
+ model-path>> 1array model-state new swap
+ [ load-models ] [ append ] map-reduce >>models ;
+
+:: <model-uniforms> ( world -- uniforms )
+ world model-state>>
+ [ textures>> ] [ bumps>> ] [ kas>> ] tri
+ [| texture bump ka |
+ world wasd-mv-matrix
+ world wasd-p-matrix
+ texture bump ka
+ { 0.5 0.5 0.5 }
+ world location>>
+ model-uniforms boa
+ ] 3map ;
+
+: clear-screen ( -- )
+ 0 0 0 0 glClearColor
+ 1 glClearDepth
+ HEX: ffffffff glClearStencil
+ { GL_COLOR_BUFFER_BIT
+ GL_DEPTH_BUFFER_BIT
+ GL_STENCIL_BUFFER_BIT } flags glClear ;
+
+: draw-model ( world -- )
+ clear-screen
+ 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
+ ] 3each ;
+
+TUPLE: model-attributes < game-attributes model-path ;
+
+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 ;
+M: model-world begin-game-world
+ init-gpu
+ { 0.0 0.0 2.0 } 0 0 set-wasd-view
+ [ <model-state> [ fill-model-state ] keep ] [ (>>model-state) ] bi ;
+M: model-world apply-world-attributes
+ {
+ [ model-path>> >>model-path ]
+ [ call-next-method ]
+ } cleave ;
+
+:: open-model-viewer ( model-path -- )
+ [
+ f
+ T{ model-attributes
+ { world-class model-world }
+ { grab-input? t }
+ { title "Model Viewer" }
+ { pixel-format-attributes
+ { windowed double-buffered }
+ }
+ { pref-dim { 1024 768 } }
+ { tick-interval-micros 16666 }
+ { use-game-input? t }
+ { model-path model-path }
+ }
+ clone
+ open-window
+ ] with-ui ;
] assoc-map ;
: canonicalize-specializer-3 ( specializer -- specializer' )
- [ total get object <array> dup <enum> ] dip update ;
+ [ total get object <array> <enum> ] dip assoc-union! seq>> ;
: canonicalize-specializers ( methods -- methods' hooks )
[
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+IN: pairs.tests
+USING: namespaces assocs tools.test pairs ;
+
+SYMBOL: blah
+
+"blah" blah <pair> "b" set
+
+[ "blah" t ] [ blah "b" get at* ] unit-test
+[ f f ] [ "fdaf" "b" get at* ] unit-test
+[ 1 ] [ "b" get assoc-size ] unit-test
+[ { { blah "blah" } } ] [ "b" get >alist ] unit-test
+[ ] [ "bleah" blah "b" get set-at ] unit-test
+[ 1 ] [ "b" get assoc-size ] unit-test
+[ { { blah "bleah" } } ] [ "b" get >alist ] unit-test
+[ "bleah" t ] [ blah "b" get at* ] unit-test
+[ f f ] [ "fdaf" "b" get at* ] unit-test
+[ blah "b" get delete-at ] must-fail
+[ ] [ 1 2 "b" get set-at ] unit-test
+[ "bleah" t ] [ blah "b" get at* ] unit-test
+[ 1 t ] [ 2 "b" get at* ] unit-test
+[ f f ] [ "fdaf" "b" get at* ] unit-test
+[ 2 ] [ "b" get assoc-size ] unit-test
+[ { { 2 1 } { blah "bleah" } } ] [ "b" get >alist ] unit-test
--- /dev/null
+! Copyright (C) 2010 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: hashtables kernel assocs accessors math arrays sequences ;
+IN: pairs
+
+TUPLE: pair value key hash ;
+
+: <pair> ( value key -- assoc )
+ f pair boa ; inline
+
+: if-hash ( pair true-quot false-quot -- )
+ [ dup hash>> ] 2dip ?if ; inline
+
+M: pair assoc-size
+ [ assoc-size 1 + ] [ drop 1 ] if-hash ; inline
+
+: if-key ( key pair true-quot false-quot -- )
+ [ [ 2dup key>> eq? ] dip [ nip ] prepose ] dip if ; inline
+
+M: pair at*
+ [ value>> t ] [
+ [ at* ] [ 2drop f f ] if-hash
+ ] if-key ; inline
+
+M: pair set-at
+ [ (>>value) ] [
+ [ set-at ]
+ [ [ associate ] dip swap >>hash drop ] if-hash
+ ] if-key ; inline
+
+ERROR: cannot-delete-key pair ;
+
+M: pair delete-at
+ [ cannot-delete-key ] [
+ [ delete-at ] [ 2drop ] if-hash
+ ] if-key ; inline
+
+M: pair >alist
+ [ hash>> >alist ] [ [ key>> ] [ value>> ] bi 2array ] bi suffix ; inline
+
+INSTANCE: pair assoc
--- /dev/null
+Assoc implementation optimized for a single key/value pair
+++ /dev/null
-USING: help help.markup help.syntax kernel quotations ;
-IN: prettyprint.callables
-
-HELP: simplify-callable
-{ $values { "quot" callable } { "quot'" callable } }
-{ $description "Converts " { $snippet "quot" } " into an equivalent quotation by simplifying usages of " { $link dip } ", " { $link call } ", " { $link curry } ", and " { $link compose } " with literal parameters. This word is used when callable objects are prettyprinted." } ;
+++ /dev/null
-! (c) 2009 Joe Groff bsd license
-USING: kernel math prettyprint prettyprint.callables
-tools.test ;
-IN: prettyprint.callables.tests
-
-[ [ dip ] ] [ [ dip ] simplify-callable ] unit-test
-[ [ [ + ] dip ] ] [ [ [ + ] dip ] simplify-callable ] unit-test
-[ [ + 5 ] ] [ [ 5 [ + ] dip ] simplify-callable ] unit-test
-[ [ + ] ] [ [ [ + ] call ] simplify-callable ] unit-test
-[ [ call ] ] [ [ call ] simplify-callable ] unit-test
-[ [ 5 + ] ] [ [ 5 [ + ] curry call ] simplify-callable ] unit-test
-[ [ 4 5 + ] ] [ [ 4 5 [ + ] 2curry call ] simplify-callable ] unit-test
-[ [ 4 5 6 + ] ] [ [ 4 5 6 [ + ] 3curry call ] simplify-callable ] unit-test
-[ [ + . ] ] [ [ [ + ] [ . ] compose call ] simplify-callable ] unit-test
-[ [ . + ] ] [ [ [ + ] [ . ] prepose call ] simplify-callable ] unit-test
+++ /dev/null
-! (c) 2009 Joe Groff bsd license
-USING: combinators combinators.short-circuit generalizations
-kernel macros math math.ranges prettyprint.custom quotations
-sequences words ;
-IN: prettyprint.callables
-
-<PRIVATE
-
-CONSTANT: simple-combinators { dip call curry 2curry 3curry compose prepose }
-
-: literal? ( obj -- ? ) word? not ;
-
-MACRO: slice-match? ( quots -- quot: ( seq end -- ? ) )
- dup length
- [ 0 [a,b) [ [ - swap nth ] swap prefix prepend ] 2map ]
- [ nip \ nip swap \ >= [ ] 3sequence ] 2bi
- prefix \ 2&& [ ] 2sequence ;
-
-: end-len>from-to ( seq end len -- from to seq )
- [ - ] [ drop 1 + ] 2bi rot ;
-
-: slice-change ( seq end len quot -- seq' )
- [ end-len>from-to ] dip
- [ [ subseq ] dip call ] curry
- [ replace-slice ] 3bi ; inline
-
-: when-slice-match ( seq i criteria quot -- seq' )
- [ [ 2dup ] dip slice-match? ] dip [ drop ] if ; inline
-
-: simplify-dip ( quot i -- quot' )
- { [ literal? ] [ callable? ] }
- [ 2 [ first2 swap suffix ] slice-change ] when-slice-match ;
-
-: simplify-call ( quot i -- quot' )
- { [ callable? ] }
- [ 1 [ first ] slice-change ] when-slice-match ;
-
-: simplify-curry ( quot i -- quot' )
- { [ literal? ] [ callable? ] }
- [ 2 [ first2 swap prefix 1quotation ] slice-change ] when-slice-match ;
-
-: simplify-2curry ( quot i -- quot' )
- { [ literal? ] [ literal? ] [ callable? ] }
- [ 3 [ [ 2 head ] [ third ] bi append 1quotation ] slice-change ] when-slice-match ;
-
-: simplify-3curry ( quot i -- quot' )
- { [ literal? ] [ literal? ] [ literal? ] [ callable? ] }
- [ 4 [ [ 3 head ] [ fourth ] bi append 1quotation ] slice-change ] when-slice-match ;
-
-: simplify-compose ( quot i -- quot' )
- { [ callable? ] [ callable? ] }
- [ 2 [ first2 append 1quotation ] slice-change ] when-slice-match ;
-
-: simplify-prepose ( quot i -- quot' )
- { [ callable? ] [ callable? ] }
- [ 2 [ first2 swap append 1quotation ] slice-change ] when-slice-match ;
-
-: (simplify-callable) ( quot -- quot' )
- dup [ simple-combinators member? ] find {
- { \ dip [ simplify-dip ] }
- { \ call [ simplify-call ] }
- { \ curry [ simplify-curry ] }
- { \ 2curry [ simplify-2curry ] }
- { \ 3curry [ simplify-3curry ] }
- { \ compose [ simplify-compose ] }
- { \ prepose [ simplify-prepose ] }
- [ 2drop ]
- } case ;
-
-PRIVATE>
-
-: simplify-callable ( quot -- quot' )
- [ (simplify-callable) ] to-fixed-point ;
-
-M: callable >pprint-sequence simplify-callable ;
+++ /dev/null
-Quotation simplification for prettyprinting automatically-constructed callable objects
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: assocs kernel sequences sequences.inserters tools.test
+unicode.case ;
+IN: sequences.inserters.tests
+
+[ V{ 1 2 "Three" "Four" "Five" } ] [
+ { "three" "four" "five" }
+ [ >title ] V{ 1 2 } clone <appender> map-as
+] unit-test
+
+[ t ] [
+ { "three" "four" "five" }
+ [ >title ] V{ 1 2 } clone [ <appender> map-as ] keep eq?
+] unit-test
+
+[ V{ 1 2 "Three" "Four" "Five" } ] [
+ { { "Th" "ree" } { "Fo" "ur" } { "Fi" "ve" } }
+ [ append ] V{ 1 2 } clone <appender> assoc>map
+] unit-test
+
+[ t ] [
+ { { "Th" "ree" } { "Fo" "ur" } { "Fi" "ve" } }
+ [ append ] V{ 1 2 } clone [ <appender> assoc>map ] keep eq?
+] unit-test
+
+[ V{ "Three" "Four" "Five" } ] [
+ { "three" "four" "five" }
+ [ >title ] V{ 1 2 } clone <replacer> map-as
+] unit-test
+
+[ t ] [
+ { "three" "four" "five" }
+ [ >title ] V{ 1 2 } clone [ <replacer> map-as ] keep eq?
+] unit-test
+
+[ V{ "Three" "Four" "Five" } ] [
+ { { "Th" "ree" } { "Fo" "ur" } { "Fi" "ve" } }
+ [ append ] V{ 1 2 } clone <replacer> assoc>map
+] unit-test
+
+[ t ] [
+ { { "Th" "ree" } { "Fo" "ur" } { "Fi" "ve" } }
+ [ append ] V{ 1 2 } clone [ <replacer> assoc>map ] keep eq?
+] unit-test
+
--- /dev/null
+! (c)2010 Joe Groff bsd license
+USING: accessors fry growable kernel locals math sequences ;
+IN: sequences.inserters
+
+TUPLE: offset-growable { underlying read-only } { offset read-only } ;
+C: <offset-growable> offset-growable
+INSTANCE: offset-growable virtual-sequence
+M: offset-growable length
+ [ underlying>> length ] [ offset>> ] bi - ; inline
+M: offset-growable virtual-exemplar
+ underlying>> ; inline
+M: offset-growable virtual@
+ [ offset>> + ] [ underlying>> ] bi ; inline
+M: offset-growable set-length
+ [ offset>> + ] [ underlying>> ] bi set-length ; inline
+
+MIXIN: inserter
+M: inserter like
+ nip underlying>> ; inline
+M: inserter new-resizable
+ [ drop 0 ] dip new-sequence ; inline
+M: inserter length
+ drop 0 ; inline
+
+TUPLE: appender { underlying read-only } ;
+C: <appender> appender
+
+INSTANCE: appender inserter
+
+M:: appender new-sequence ( len inserter -- sequence )
+ inserter underlying>> :> underlying
+ underlying length :> old-length
+ old-length len + :> new-length
+ new-length underlying set-length
+ underlying old-length <offset-growable> ; inline
+
+TUPLE: replacer { underlying read-only } ;
+C: <replacer> replacer
+
+INSTANCE: replacer inserter
+
+M: replacer new-sequence
+ underlying>> [ set-length ] keep ; inline
+
--- /dev/null
+Direct the output of map-as, filter-as, etc. combinators into existing growable sequences
|-----------------+------------------------------------------------------------|
| C-cz | switch to listener (run-factor) |
| C-co | cycle between code, tests and docs files |
+ | C-ct | run the unit tests for a vocabulary |
| C-cr | switch to listener and refresh all loaded vocabs |
| C-cs | switch to other factor buffer (fuel-switch-to-buffer) |
| C-x4s | switch to other factor buffer in other window |
(defvar fuel-completion--vocab-history nil)
-(defun fuel-completion--read-vocab (refresh)
+(defun fuel-completion--read-vocab (refresh &optional init-input)
(let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)
(vocabs (fuel-completion--vocabs refresh))
(prompt "Vocabulary name: "))
(if vocabs
- (completing-read prompt vocabs nil nil nil fuel-completion--vocab-history)
- (read-string prompt nil fuel-completion--vocab-history))))
+ (completing-read prompt vocabs nil nil init-input fuel-completion--vocab-history)
+ (read-string prompt init-input fuel-completion--vocab-history))))
(defun fuel-completion--complete-symbol ()
"Complete the symbol at point.
(comint-send-string nil "\"Refreshing loaded vocabs...\" write nl flush")
(comint-send-string nil " refresh-all \"Done!\" write nl flush\n")))
+(defun fuel-test-vocab (vocab)
+ "Run the unit tests for the specified vocabulary."
+ (interactive (list (fuel-completion--read-vocab nil (fuel-syntax--current-vocab))))
+ (comint-send-string (fuel-listener--process)
+ (concat "\"" vocab "\" reload nl flush\n"
+ "\"" vocab "\" test nl flush\n")))
+
\f
;;; Completion support
(fuel-mode--key-1 ?k 'fuel-run-file)
(fuel-mode--key-1 ?l 'fuel-run-file)
(fuel-mode--key-1 ?r 'fuel-refresh-all)
+(fuel-mode--key-1 ?t 'fuel-test-vocab)
(fuel-mode--key-1 ?z 'run-factor)
(fuel-mode--key-1 ?s 'fuel-switch-to-buffer)
(define-key fuel-mode-map "\C-x4s" 'fuel-switch-to-buffer-other-window)
"DEFER:"
"EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
"f" "FORGET:" "FROM:" "FUNCTION:"
- "GENERIC#" "GENERIC:"
+ "GAME:" "GENERIC#" "GENERIC:"
+ "GLSL-SHADER:" "GLSL-PROGRAM:"
"HELP:" "HEX:" "HOOK:"
"IN:" "initial:" "INSTANCE:" "INTERSECTION:"
"LIBRARY:"
"POSTPONE:" "PREDICATE:" "PRIMITIVE:" "PRIVATE>" "PROVIDE:"
"QUALIFIED-WITH:" "QUALIFIED:"
"read-only" "RENAME:" "REQUIRE:" "REQUIRES:"
- "SINGLETON:" "SINGLETONS:" "SLOT:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
- "TUPLE:" "t" "t?" "TYPEDEF:"
- "UNION:" "USE:" "USING:"
- "VARS:"))
+ "SINGLETON:" "SINGLETONS:" "SLOT:" "STRING:" "SYMBOL:" "SYMBOLS:" "SYNTAX:"
+ "TUPLE:" "t" "t?" "TYPEDEF:" "TYPED:" "TYPED::"
+ "UNIFORM-TUPLE:" "UNION:" "USE:" "USING:"
+ "VARS:" "VERTEX-FORMAT:"))
(defconst fuel-syntax--parsing-words-regex
(regexp-opt fuel-syntax--parsing-words 'words))
(format "\\_<\\(%s\\)?: +\\_<\\(\\w+\\)\\_>"
(regexp-opt
'(":" "GENERIC" "DEFER" "HOOK" "MAIN" "MATH" "POSTPONE"
- "SYMBOL" "SYNTAX" "RENAME"))))
+ "SYMBOL" "SYNTAX" "TYPED" "RENAME"))))
(defconst fuel-syntax--alias-definition-regex
"^ALIAS: +\\(\\_<.+?\\_>\\) +\\(\\_<.+?\\_>\\)")
"MEMO" "MEMO:" "METHOD"
"SYNTAX"
"PREDICATE" "PRIMITIVE"
- "UNION"))
+ "STRUCT" "TAG" "TUPLE"
+ "TYPED" "TYPED:"
+ "UNIFORM-TUPLE"
+ "UNION-STRUCT" "UNION"
+ "VERTEX-FORMAT"))
(defconst fuel-syntax--no-indent-def-starts '("ARTICLE"
"HELP"
"SINGLETONS"
"SYMBOLS"
- "TUPLE"
"VARS"))
(defconst fuel-syntax--indent-def-start-regex
"CONSTANT:" "C:"
"DEFER:"
"FORGET:"
- "GENERIC:" "GENERIC#"
+ "GAME:" "GENERIC:" "GENERIC#" "GLSL-PROGRAM:"
"HEX:" "HOOK:"
"IN:" "INSTANCE:"
"LIBRARY:"
("\\_<\\()\\))\\_>" (1 ")("))
;; Quotations:
("\\_<'\\(\\[\\)\\_>" (1 "(]")) ; fried
+ ("\\_<$\\(\\[\\)\\_>" (1 "(]")) ; parse-time
("\\_<\\(\\[\\)\\_>" (1 "(]"))
("\\_<\\(\\]\\)\\_>" (1 ")["))))
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: tools.deploy.config ;
+V{
+ { deploy-ui? t }
+ { deploy-io 1 }
+ { deploy-reflection 1 }
+ { deploy-math? t }
+ { deploy-word-props? f }
+ { deploy-c-types? f }
+ { "stop-after-last-window?" t }
+ { deploy-name "Jamshred" }
+}
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors kernel opengl arrays sequences jamshred.log jamshred.player jamshred.sound jamshred.tunnel math math.constants math.vectors ;
+IN: jamshred.game
+
+TUPLE: jamshred sounds tunnel players running quit ;
+
+: <jamshred> ( -- jamshred )
+ <sounds> <random-tunnel> "Player 1" pick <player>
+ 2dup swap play-in-tunnel 1array f f jamshred boa ;
+
+: jamshred-player ( jamshred -- player )
+ ! TODO: support more than one player
+ players>> first ;
+
+: jamshred-update ( jamshred -- )
+ dup running>> [
+ jamshred-player update-player
+ ] [ drop ] if ;
+
+: toggle-running ( jamshred -- )
+ dup running>> [
+ f >>running drop
+ ] [
+ [ jamshred-player moved ]
+ [ t >>running drop ] bi
+ ] if ;
+
+: mouse-moved ( x-radians y-radians jamshred -- )
+ jamshred-player -rot turn-player ;
+
+CONSTANT: units-per-full-roll 50
+
+: jamshred-roll ( jamshred n -- )
+ [ jamshred-player ] dip 2 pi * * units-per-full-roll / roll-player ;
+
+: mouse-scroll-x ( jamshred x -- ) jamshred-roll ;
+
+: mouse-scroll-y ( jamshred y -- )
+ neg swap jamshred-player change-player-speed ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.c-types jamshred.game jamshred.oint
+jamshred.player jamshred.tunnel kernel math math.constants
+math.functions math.vectors opengl opengl.gl opengl.glu
+opengl.demo-support sequences specialized-arrays locals ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+IN: jamshred.gl
+
+CONSTANT: min-vertices 6
+CONSTANT: max-vertices 32
+
+CONSTANT: n-vertices 32
+
+! render enough of the tunnel that it looks continuous
+CONSTANT: n-segments-ahead 60
+CONSTANT: n-segments-behind 40
+
+! so that we can't see through the wall, we draw it a bit further away
+CONSTANT: wall-drawing-offset 0.15
+
+: wall-drawing-radius ( segment -- r )
+ radius>> wall-drawing-offset + ;
+
+: wall-up ( segment -- v )
+ [ wall-drawing-radius ] [ up>> ] bi n*v ;
+
+: wall-left ( segment -- v )
+ [ wall-drawing-radius ] [ left>> ] bi n*v ;
+
+: segment-vertex ( theta segment -- vertex )
+ [
+ [ wall-up swap sin v*n ] [ wall-left swap cos v*n ] 2bi v+
+ ] [
+ location>> v+
+ ] bi ;
+
+: segment-vertex-normal ( vertex segment -- normal )
+ location>> swap v- normalize ;
+
+: segment-vertex-and-normal ( segment theta -- vertex normal )
+ swap [ segment-vertex ] keep dupd segment-vertex-normal ;
+
+: equally-spaced-radians ( n -- seq )
+ #! return a sequence of n numbers between 0 and 2pi
+ [ iota ] keep [ / pi 2 * * ] curry map ;
+
+: draw-segment-vertex ( segment theta -- )
+ over color>> gl-color segment-vertex-and-normal
+ gl-normal gl-vertex ;
+
+:: draw-vertex-pair ( theta next-segment segment -- )
+ segment theta draw-segment-vertex
+ next-segment theta draw-segment-vertex ;
+
+: draw-segment ( next-segment segment -- )
+ GL_QUAD_STRIP [
+ [ draw-vertex-pair ] 2curry
+ n-vertices equally-spaced-radians float-array{ 0.0 } append swap each
+ ] do-state ;
+
+: draw-segments ( segments -- )
+ 1 over length pick subseq swap [ draw-segment ] 2each ;
+
+: segments-to-render ( player -- segments )
+ dup nearest-segment>> number>> dup n-segments-behind -
+ swap n-segments-ahead + rot tunnel>> sub-tunnel ;
+
+: draw-tunnel ( player -- )
+ segments-to-render draw-segments ;
+
+: init-graphics ( -- )
+ GL_DEPTH_TEST glEnable
+ GL_SCISSOR_TEST glDisable
+ 1.0 glClearDepth
+ 0.0 0.0 0.0 0.0 glClearColor
+ GL_PROJECTION glMatrixMode glPushMatrix
+ GL_MODELVIEW glMatrixMode glPushMatrix
+ GL_LEQUAL glDepthFunc
+ GL_LIGHTING glEnable
+ GL_LIGHT0 glEnable
+ GL_FOG glEnable
+ GL_FOG_DENSITY 0.09 glFogf
+ GL_FRONT GL_AMBIENT_AND_DIFFUSE glColorMaterial
+ GL_COLOR_MATERIAL glEnable
+ GL_LIGHT0 GL_POSITION float-array{ 0.0 0.0 0.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_AMBIENT float-array{ 0.2 0.2 0.2 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_DIFFUSE float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv
+ GL_LIGHT0 GL_SPECULAR float-array{ 1.0 1.0 1.0 1.0 } underlying>> glLightfv ;
+
+: cleanup-graphics ( -- )
+ GL_DEPTH_TEST glDisable
+ GL_SCISSOR_TEST glEnable
+ GL_MODELVIEW glMatrixMode glPopMatrix
+ GL_PROJECTION glMatrixMode glPopMatrix
+ GL_LIGHTING glDisable
+ GL_LIGHT0 glDisable
+ GL_FOG glDisable
+ GL_COLOR_MATERIAL glDisable ;
+
+: pre-draw ( width height -- )
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_PROJECTION glMatrixMode glLoadIdentity
+ dup 0 = [ 2drop ] [ / >float 45.0 swap 0.1 100.0 gluPerspective ] if
+ GL_MODELVIEW glMatrixMode glLoadIdentity ;
+
+: player-view ( player -- )
+ [ location>> ]
+ [ [ location>> ] [ forward>> ] bi v+ ]
+ [ up>> ] tri gl-look-at ;
+
+: draw-jamshred ( jamshred width height -- )
+ pre-draw jamshred-player [ player-view ] [ draw-tunnel ] bi ;
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays calendar jamshred.game jamshred.gl jamshred.player jamshred.log kernel math math.constants math.rectangles math.vectors namespaces sequences threads ui ui.backend ui.gadgets ui.gadgets.worlds ui.gestures ui.render ;
+IN: jamshred
+
+TUPLE: jamshred-gadget < gadget { jamshred jamshred } last-hand-loc ;
+
+: <jamshred-gadget> ( jamshred -- gadget )
+ jamshred-gadget new swap >>jamshred ;
+
+CONSTANT: default-width 800
+CONSTANT: default-height 600
+
+M: jamshred-gadget pref-dim*
+ drop default-width default-height 2array ;
+
+M: jamshred-gadget draw-gadget* ( gadget -- )
+ [ jamshred>> ] [ dim>> first2 draw-jamshred ] bi ;
+
+: jamshred-loop ( gadget -- )
+ dup jamshred>> quit>> [
+ drop
+ ] [
+ [ jamshred>> jamshred-update ]
+ [ relayout-1 ]
+ [ 100 milliseconds sleep jamshred-loop ] tri
+ ] if ;
+
+M: jamshred-gadget graft* ( gadget -- )
+ [ find-gl-context init-graphics ]
+ [ [ jamshred-loop ] curry in-thread ] bi ;
+
+M: jamshred-gadget ungraft* ( gadget -- )
+ dup find-gl-context cleanup-graphics jamshred>> t swap (>>quit) ;
+
+: jamshred-restart ( jamshred-gadget -- )
+ <jamshred> >>jamshred drop ;
+
+: pix>radians ( n m -- theta )
+ / pi 4 * * ; ! 2 / / pi 2 * * ;
+
+: x>radians ( x gadget -- theta )
+ #! translate motion of x pixels to an angle
+ dim>> first pix>radians neg ;
+
+: y>radians ( y gadget -- theta )
+ #! translate motion of y pixels to an angle
+ dim>> second pix>radians ;
+
+: (handle-mouse-motion) ( jamshred-gadget mouse-motion -- )
+ dupd [ first swap x>radians ] [ second swap y>radians ] 2bi
+ rot jamshred>> mouse-moved ;
+
+: handle-mouse-motion ( jamshred-gadget -- )
+ hand-loc get [
+ over last-hand-loc>> [
+ v- (handle-mouse-motion)
+ ] [ 2drop ] if*
+ ] 2keep >>last-hand-loc drop ;
+
+: handle-mouse-scroll ( jamshred-gadget -- )
+ jamshred>> scroll-direction get
+ [ first mouse-scroll-x ]
+ [ second mouse-scroll-y ] 2bi ;
+
+: quit ( gadget -- )
+ [ f set-fullscreen ] [ close-window ] bi ;
+
+jamshred-gadget H{
+ { T{ key-down f f "r" } [ jamshred-restart ] }
+ { T{ key-down f f " " } [ jamshred>> toggle-running ] }
+ { T{ key-down f f "f" } [ toggle-fullscreen ] }
+ { T{ key-down f f "UP" } [ jamshred>> jamshred-player 1 swap change-player-speed ] }
+ { T{ key-down f f "DOWN" } [ jamshred>> jamshred-player -1 swap change-player-speed ] }
+ { T{ key-down f f "LEFT" } [ jamshred>> 1 jamshred-roll ] }
+ { T{ key-down f f "RIGHT" } [ jamshred>> -1 jamshred-roll ] }
+ { T{ key-down f f "q" } [ quit ] }
+ { motion [ handle-mouse-motion ] }
+ { mouse-scroll [ handle-mouse-scroll ] }
+} set-gestures
+
+MAIN-WINDOW: jamshred-window { { title "Jamshred" } }
+ <jamshred> <jamshred-gadget> >>gadgets ;
--- /dev/null
+USING: kernel logging ;
+IN: jamshred.log
+
+LOG: (jamshred-log) DEBUG
+
+: with-jamshred-log ( quot -- )
+ "jamshred" swap with-logging ; inline
+
+: jamshred-log ( message -- )
+ [ (jamshred-log) ] with-jamshred-log ; ! ugly...
--- /dev/null
+Alex Chapman
--- /dev/null
+USING: jamshred.oint tools.test ;
+IN: jamshred.oint-tests
+
+[ { 0 -1 -1 } ] [ { 0 1 -1 } { 0 -1 0 } reflect ] unit-test
+[ { 0 1 0 } ] [ { 1 1 0 } { 1 0 0 } proj-perp ] unit-test
+[ { 1 0 0 } ] [ { 1 1 0 } { 0 1 0 } proj-perp ] unit-test
+[ { 1/2 -1/2 0 } ] [ { 1 0 0 } { 1 1 0 } proj-perp ] unit-test
+[ { -1/2 1/2 0 } ] [ { 0 1 0 } { 1 1 0 } proj-perp ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel locals math math.constants math.functions math.matrices math.vectors math.quaternions random sequences ;
+IN: jamshred.oint
+
+! An oint is a point with three linearly independent unit vectors
+! given relative to that point. In jamshred a player's location and
+! direction are given by the player's oint. Similarly, a tunnel
+! segment's location and orientation are given by an oint.
+
+TUPLE: oint location forward up left ;
+C: <oint> oint
+
+: rotation-quaternion ( theta axis -- quaternion )
+ swap 2 / dup cos swap sin rot n*v first3 rect> [ rect> ] dip 2array ;
+
+: rotate-vector ( q qrecip v -- v )
+ v>q swap q* q* q>v ;
+
+: rotate-oint ( oint theta axis -- )
+ rotation-quaternion dup qrecip pick
+ [ forward>> rotate-vector >>forward ]
+ [ up>> rotate-vector >>up ]
+ [ left>> rotate-vector >>left ] 3tri drop ;
+
+: left-pivot ( oint theta -- )
+ over left>> rotate-oint ;
+
+: up-pivot ( oint theta -- )
+ over up>> rotate-oint ;
+
+: forward-pivot ( oint theta -- )
+ over forward>> rotate-oint ;
+
+: random-float+- ( n -- m )
+ #! find a random float between -n/2 and n/2
+ dup 10000 * >integer random 10000 / swap 2 / - ;
+
+: random-turn ( oint theta -- )
+ 2 / 2dup random-float+- left-pivot random-float+- up-pivot ;
+
+: location+ ( v oint -- )
+ [ location>> v+ ] [ (>>location) ] bi ;
+
+: go-forward ( distance oint -- )
+ [ forward>> n*v ] [ location+ ] bi ;
+
+: distance-vector ( oint oint -- vector )
+ [ location>> ] bi@ swap v- ;
+
+: distance ( oint oint -- distance )
+ distance-vector norm ;
+
+: scalar-projection ( v1 v2 -- n )
+ #! the scalar projection of v1 onto v2
+ [ v. ] [ norm ] bi / ;
+
+: proj-perp ( u v -- w )
+ dupd proj v- ;
+
+: perpendicular-distance ( oint oint -- distance )
+ [ distance-vector ] keep 2dup left>> scalar-projection abs
+ -rot up>> scalar-projection abs + ;
+
+:: reflect ( v n -- v' )
+ #! bounce v on a surface with normal n
+ v v n v. n n v. / 2 * n n*v v- ;
+
+: half-way ( p1 p2 -- p3 )
+ over v- 2 v/n v+ ;
+
+: half-way-between-oints ( o1 o2 -- p )
+ [ location>> ] bi@ half-way ;
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors colors.constants combinators jamshred.log
+jamshred.oint jamshred.sound jamshred.tunnel kernel locals math
+math.constants math.order math.ranges math.vectors math.matrices
+sequences shuffle specialized-arrays strings system ;
+QUALIFIED-WITH: alien.c-types c
+SPECIALIZED-ARRAY: c:float
+IN: jamshred.player
+
+TUPLE: player < oint
+ { name string }
+ { sounds sounds }
+ tunnel
+ nearest-segment
+ { last-move integer }
+ { speed float } ;
+
+! speeds are in GL units / second
+CONSTANT: default-speed 1.0
+CONSTANT: max-speed 30.0
+
+: <player> ( name sounds -- player )
+ [ float-array{ 0 0 5 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] 2dip
+ f f 0 default-speed player boa ;
+
+: turn-player ( player x-radians y-radians -- )
+ [ over ] dip left-pivot up-pivot ;
+
+: roll-player ( player z-radians -- )
+ forward-pivot ;
+
+: to-tunnel-start ( player -- )
+ dup tunnel>> first
+ [ >>nearest-segment ]
+ [ location>> >>location ] bi drop ;
+
+: play-in-tunnel ( player segments -- )
+ >>tunnel to-tunnel-start ;
+
+: update-time ( player -- seconds-passed )
+ system-micros swap [ last-move>> - 1000000 / ] [ (>>last-move) ] 2bi ;
+
+: moved ( player -- ) system-micros swap (>>last-move) ;
+
+: speed-range ( -- range )
+ max-speed [0,b] ;
+
+: change-player-speed ( inc player -- )
+ [ + 0 max-speed clamp ] change-speed drop ;
+
+: multiply-player-speed ( n player -- )
+ [ * 0 max-speed clamp ] change-speed drop ;
+
+: distance-to-move ( seconds-passed player -- distance )
+ speed>> * ;
+
+: bounce ( d-left player -- d-left' player )
+ {
+ [ dup nearest-segment>> bounce-off-wall ]
+ [ sounds>> bang ]
+ [ 3/4 swap multiply-player-speed ]
+ [ ]
+ } cleave ;
+
+:: (distance) ( heading player -- current next location heading )
+ player nearest-segment>>
+ player [ tunnel>> ] [ nearest-segment>> ] bi heading heading-segment
+ player location>> heading ;
+
+: distance-to-heading-segment ( heading player -- distance )
+ (distance) distance-to-next-segment ;
+
+: distance-to-heading-segment-area ( heading player -- distance )
+ (distance) distance-to-next-segment-area ;
+
+: distance-to-collision ( player -- distance )
+ dup nearest-segment>> (distance-to-collision) ;
+
+: almost-to-collision ( player -- distance )
+ distance-to-collision 0.1 - dup 0 < [ drop 0 ] when ;
+
+: from ( player -- radius distance-from-centre )
+ [ nearest-segment>> dup radius>> swap ] [ location>> ] bi
+ distance-from-centre ;
+
+: distance-from-wall ( player -- distance ) from - ;
+: fraction-from-centre ( player -- fraction ) from swap / ;
+: fraction-from-wall ( player -- fraction )
+ fraction-from-centre 1 swap - ;
+
+: update-nearest-segment2 ( heading player -- )
+ 2dup distance-to-heading-segment-area 0 <= [
+ [ tunnel>> ] [ nearest-segment>> rot heading-segment ]
+ [ (>>nearest-segment) ] tri
+ ] [
+ 2drop
+ ] if ;
+
+:: move-player-on-heading ( d-left player distance heading -- d-left' player )
+ d-left distance min :> d-to-move
+ d-to-move heading n*v :> move-v
+
+ move-v player location+
+ heading player update-nearest-segment2
+ d-left d-to-move - player ;
+
+: distance-to-move-freely ( player -- distance )
+ [ almost-to-collision ]
+ [ [ forward>> ] keep distance-to-heading-segment-area ] bi min ;
+
+: ?move-player-freely ( d-left player -- d-left' player )
+ over 0 > [
+ ! must make sure we are moving a significant distance, otherwise
+ ! we can recurse endlessly due to floating-point imprecision.
+ ! (at least I /think/ that's what causes it...)
+ dup distance-to-move-freely dup 0.1 > [
+ over forward>> move-player-on-heading ?move-player-freely
+ ] [ drop ] if
+ ] when ;
+
+: drag-heading ( player -- heading )
+ [ forward>> ] [ nearest-segment>> forward>> proj ] bi ;
+
+: drag-player ( d-left player -- d-left' player )
+ dup [ [ drag-heading ] keep distance-to-heading-segment-area ]
+ [ drag-heading move-player-on-heading ] bi ;
+
+: (move-player) ( d-left player -- d-left' player )
+ ?move-player-freely over 0 > [
+ ! bounce
+ drag-player
+ (move-player)
+ ] when ;
+
+: move-player ( player -- )
+ [ update-time ] [ distance-to-move ] [ (move-player) 2drop ] tri ;
+
+: update-player ( player -- )
+ [ move-player ] [ nearest-segment>> "white" named-color swap (>>color) ] bi ;
--- /dev/null
+! Copyright (C) 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors io.pathnames kernel openal sequences ;
+IN: jamshred.sound
+
+TUPLE: sounds bang ;
+
+: assign-sound ( source wav-path -- )
+ resource-path create-buffer-from-wav AL_BUFFER swap set-source-param ;
+
+: <sounds> ( -- sounds )
+ init-openal 1 gen-sources first sounds boa
+ dup bang>> "extra/jamshred/sound/bang.wav" assign-sound ;
+
+: bang ( sounds -- ) bang>> source-play check-error ;
--- /dev/null
+A simple 3d tunnel racing game
--- /dev/null
+applications
+games
--- /dev/null
+Alex Chapman
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays jamshred.oint jamshred.tunnel kernel
+math.vectors sequences specialized-arrays tools.test
+alien.c-types ;
+SPECIALIZED-ARRAY: float
+IN: jamshred.tunnel.tests
+
+: test-segment-oint ( -- oint )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint> ;
+
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 0 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 0 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 0 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 0 } vector-to-centre ] unit-test
+[ { -1 0 0 } ] [ test-segment-oint { 1 0 -1 } vector-to-centre ] unit-test
+[ { 1 0 0 } ] [ test-segment-oint { -1 0 -1 } vector-to-centre ] unit-test
+[ { 0 -1 0 } ] [ test-segment-oint { 0 1 -1 } vector-to-centre ] unit-test
+[ { 0 1 0 } ] [ test-segment-oint { 0 -1 -1 } vector-to-centre ] unit-test
+
+: simplest-straight-ahead ( -- oint segment )
+ { 0 0 0 } { 0 0 -1 } { 0 1 0 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simplest-straight-ahead sideways-relative-location ] unit-test
+
+: simple-collision-up ( -- oint segment )
+ { 0 0 0 } { 0 1 0 } { 0 0 1 } { -1 0 0 } <oint>
+ initial-segment ;
+
+[ { 0.0 1.0 0.0 } ] [ simple-collision-up sideways-heading ] unit-test
+[ { 0.0 0.0 0.0 } ] [ simple-collision-up sideways-relative-location ] unit-test
+[ { 0.0 1.0 0.0 } ]
+[ simple-collision-up collision-vector 0 0 0 3array v+ ] unit-test
--- /dev/null
+! Copyright (C) 2007, 2008 Alex Chapman
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays colors combinators fry jamshred.oint
+kernel literals locals math math.constants math.matrices
+math.order math.quadratic math.ranges math.vectors random
+sequences specialized-arrays vectors ;
+FROM: jamshred.oint => distance ;
+FROM: alien.c-types => float ;
+SPECIALIZED-ARRAY: float
+IN: jamshred.tunnel
+
+CONSTANT: n-segments 5000
+
+TUPLE: segment < oint number color radius ;
+C: <segment> segment
+
+: segment-number++ ( segment -- )
+ [ number>> 1 + ] keep (>>number) ;
+
+: clamp-length ( n seq -- n' )
+ 0 swap length clamp ;
+
+: random-color ( -- color )
+ { 100 100 100 } [ random 100 / >float ] map first3 1.0 <rgba> ;
+
+CONSTANT: tunnel-segment-distance 0.4
+CONSTANT: random-rotation-angle $[ pi 20 / ]
+
+: random-segment ( previous-segment -- segment )
+ clone dup random-rotation-angle random-turn
+ tunnel-segment-distance over go-forward
+ random-color >>color dup segment-number++ ;
+
+: (random-segments) ( segments n -- segments )
+ dup 0 > [
+ [ dup last random-segment over push ] dip 1 - (random-segments)
+ ] [ drop ] if ;
+
+CONSTANT: default-segment-radius 1
+
+: initial-segment ( -- segment )
+ float-array{ 0 0 0 } float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 }
+ 0 random-color default-segment-radius <segment> ;
+
+: random-segments ( n -- segments )
+ initial-segment 1vector swap (random-segments) ;
+
+: simple-segment ( n -- segment )
+ [ float-array{ 0 0 -1 } n*v float-array{ 0 0 -1 } float-array{ 0 1 0 } float-array{ -1 0 0 } ] keep
+ random-color default-segment-radius <segment> ;
+
+: simple-segments ( n -- segments )
+ [ simple-segment ] map ;
+
+: <random-tunnel> ( -- segments )
+ n-segments random-segments ;
+
+: <straight-tunnel> ( -- segments )
+ n-segments simple-segments ;
+
+: sub-tunnel ( from to segments -- segments )
+ #! return segments between from and to, after clamping from and to to
+ #! valid values
+ [ '[ _ clamp-length ] bi@ ] keep <slice> ;
+
+: get-segment ( segments n -- segment )
+ over clamp-length swap nth ;
+
+: next-segment ( segments current-segment -- segment )
+ number>> 1 + get-segment ;
+
+: previous-segment ( segments current-segment -- segment )
+ number>> 1 - get-segment ;
+
+: heading-segment ( segments current-segment heading -- segment )
+ #! the next segment on the given heading
+ over forward>> v. 0 <=> {
+ { +gt+ [ next-segment ] }
+ { +lt+ [ previous-segment ] }
+ { +eq+ [ nip ] } ! current segment
+ } case ;
+
+:: distance-to-next-segment ( current next location heading -- distance )
+ current forward>> :> cf
+ cf next location>> v. cf location v. - cf heading v. / ;
+
+:: distance-to-next-segment-area ( current next location heading -- distance )
+ current forward>> :> cf
+ next current half-way-between-oints :> h
+ cf h v. cf location v. - cf heading v. / ;
+
+: vector-to-centre ( seg loc -- v )
+ over location>> swap v- swap forward>> proj-perp ;
+
+: distance-from-centre ( seg loc -- distance )
+ vector-to-centre norm ;
+
+: wall-normal ( seg oint -- n )
+ location>> vector-to-centre normalize ;
+
+CONSTANT: distant 1000
+
+: max-real ( a b -- c )
+ #! sometimes collision-coefficient yields complex roots, so we ignore these (hack)
+ dup real? [
+ over real? [ max ] [ nip ] if
+ ] [
+ drop dup real? [ drop distant ] unless
+ ] if ;
+
+:: collision-coefficient ( v w r -- c )
+ v norm 0 = [
+ distant
+ ] [
+ v dup v. :> a
+ v w v. 2 * :> b
+ w dup v. r sq - :> c
+ c b a quadratic max-real
+ ] if ;
+
+: sideways-heading ( oint segment -- v )
+ [ forward>> ] bi@ proj-perp ;
+
+: sideways-relative-location ( oint segment -- loc )
+ [ [ location>> ] bi@ v- ] keep forward>> proj-perp ;
+
+: (distance-to-collision) ( oint segment -- distance )
+ [ sideways-heading ] [ sideways-relative-location ]
+ [ nip radius>> ] 2tri collision-coefficient ;
+
+: collision-vector ( oint segment -- v )
+ dupd (distance-to-collision) swap forward>> n*v ;
+
+: bounce-forward ( segment oint -- )
+ [ wall-normal ] [ forward>> swap reflect ] [ (>>forward) ] tri ;
+
+: bounce-left ( segment oint -- )
+ #! must be done after forward
+ [ forward>> vneg ] dip [ left>> swap reflect ]
+ [ forward>> proj-perp normalize ] [ (>>left) ] tri ;
+
+: bounce-up ( segment oint -- )
+ #! must be done after forward and left!
+ nip [ forward>> ] [ left>> cross ] [ (>>up) ] tri ;
+
+: bounce-off-wall ( oint segment -- )
+ swap [ bounce-forward ] [ bounce-left ] [ bounce-up ] 2tri ;
+
-! 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 ;
ifdef X11
LIBS = -lm -framework Cocoa -L/opt/local/lib $(X11_UI_LIBS) -Wl,-dylib_file,/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib:/System/Library/Frameworks/OpenGL.framework/Versions/A/Libraries/libGL.dylib
else
- LIBS = -lm -framework Cocoa -framework AppKit
+ LIBS = -lm -framework Cocoa -framework AppKit
endif
LINKER = $(CPP) $(CFLAGS) -dynamiclib -single_module -std=gnu99 \
ctx->push(tag<array>(reallot_array(a.untagged(),capacity)));
}
+cell factor_vm::std_vector_to_array(std::vector<cell> &elements)
+{
+ cell element_count = elements.size();
+ data_roots.push_back(data_root_range(&elements[0],element_count));
+
+ tagged<array> objects(allot_uninitialized_array<array>(element_count));
+ memcpy(objects->data(),&elements[0],element_count * sizeof(cell));
+
+ data_roots.pop_back();
+
+ return objects.value();
+}
+
void growable_array::add(cell elt_)
{
factor_vm *parent = elements.parent;
#define BIGNUM_ASSERT(expression) \
{ \
if (! (expression)) \
- BIGNUM_EXCEPTION (); \
+ BIGNUM_EXCEPTION (); \
}
#endif /* not BIGNUM_DISABLE_ASSERTION_CHECKS */
void operator()(stack_frame *frame)
{
- data_root<object> executing(parent->frame_executing_quot(frame),parent);
+ data_root<object> executing_quot(parent->frame_executing_quot(frame),parent);
+ data_root<object> executing(parent->frame_executing(frame),parent);
data_root<object> scan(parent->frame_scan(frame),parent);
frames.add(executing.value());
+ frames.add(executing_quot.value());
frames.add(scan.value());
}
};
struct update_word_references_relocation_visitor {
factor_vm *parent;
+ bool reset_inline_caches;
- explicit update_word_references_relocation_visitor(factor_vm *parent_) : parent(parent_) {}
+ update_word_references_relocation_visitor(
+ factor_vm *parent_,
+ bool reset_inline_caches_) :
+ parent(parent_),
+ reset_inline_caches(reset_inline_caches_) {}
void operator()(instruction_operand op)
{
case RT_ENTRY_POINT_PIC:
{
code_block *compiled = op.load_code_block();
- cell owner = parent->code_block_owner(compiled);
- if(to_boolean(owner))
- op.store_value(parent->compute_entry_point_pic_address(owner));
+ if(reset_inline_caches || !compiled->pic_p())
+ {
+ cell owner = parent->code_block_owner(compiled);
+ if(to_boolean(owner))
+ op.store_value(parent->compute_entry_point_pic_address(owner));
+ }
break;
}
case RT_ENTRY_POINT_PIC_TAIL:
{
code_block *compiled = op.load_code_block();
- cell owner = parent->code_block_owner(compiled);
- if(to_boolean(owner))
- op.store_value(parent->compute_entry_point_pic_tail_address(owner));
+ if(reset_inline_caches || !compiled->pic_p())
+ {
+ cell owner = parent->code_block_owner(compiled);
+ if(to_boolean(owner))
+ op.store_value(parent->compute_entry_point_pic_tail_address(owner));
+ }
break;
}
default:
dlsyms, and words. For all other words in the code heap, we only need
to update references to other words, without worrying about literals
or dlsyms. */
-void factor_vm::update_word_references(code_block *compiled)
+void factor_vm::update_word_references(code_block *compiled, bool reset_inline_caches)
{
if(code->uninitialized_p(compiled))
initialize_code_block(compiled);
are referenced after this is done. So instead of polluting
the code heap with dead PICs that will be freed on the next
GC, we add them to the free list immediately. */
- else if(compiled->pic_p())
+ else if(reset_inline_caches && compiled->pic_p())
code->free(compiled);
else
{
- update_word_references_relocation_visitor visitor(this);
+ update_word_references_relocation_visitor visitor(this,reset_inline_caches);
compiled->each_instruction_operand(visitor);
compiled->flush_icache();
}
};
/* Perform all fixups on a code block */
-void factor_vm::initialize_code_block(code_block *compiled)
+void factor_vm::initialize_code_block(code_block *compiled, cell literals)
{
- std::map<code_block *,cell>::iterator iter = code->uninitialized_blocks.find(compiled);
-
- initial_code_block_visitor visitor(this,iter->second);
+ initial_code_block_visitor visitor(this,literals);
compiled->each_instruction_operand(visitor);
compiled->flush_icache();
- code->uninitialized_blocks.erase(iter);
-
/* next time we do a minor GC, we have to trace this code block, since
the newly-installed instruction operands might point to literals in
nursery or aging */
code->write_barrier(compiled);
}
+void factor_vm::initialize_code_block(code_block *compiled)
+{
+ std::map<code_block *,cell>::iterator iter = code->uninitialized_blocks.find(compiled);
+ initialize_code_block(compiled,iter->second);
+ code->uninitialized_blocks.erase(iter);
+}
+
/* Fixup labels. This is done at compile time, not image load time */
void factor_vm::fixup_labels(array *labels, code_block *compiled)
{
struct word_updater {
factor_vm *parent;
+ bool reset_inline_caches;
- explicit word_updater(factor_vm *parent_) : parent(parent_) {}
+ word_updater(factor_vm *parent_, bool reset_inline_caches_) :
+ parent(parent_), reset_inline_caches(reset_inline_caches_) {}
void operator()(code_block *compiled, cell size)
{
- parent->update_word_references(compiled);
+ parent->update_word_references(compiled,reset_inline_caches);
}
};
-/* Update pointers to words referenced from all code blocks. Only after
-defining a new word. */
-void factor_vm::update_code_heap_words()
+/* Update pointers to words referenced from all code blocks.
+Only needed after redefining an existing word.
+If generic words were redefined, inline caches need to be reset. */
+void factor_vm::update_code_heap_words(bool reset_inline_caches)
{
- word_updater updater(this);
+ word_updater updater(this,reset_inline_caches);
each_code_block(updater);
}
+/* Fix up new words only.
+Fast path for compilation units that only define new words. */
+void factor_vm::initialize_code_blocks()
+{
+ std::map<code_block *, cell>::const_iterator iter = code->uninitialized_blocks.begin();
+ std::map<code_block *, cell>::const_iterator end = code->uninitialized_blocks.end();
+
+ for(; iter != end; iter++)
+ initialize_code_block(iter->first,iter->second);
+
+ code->uninitialized_blocks.clear();
+}
+
void factor_vm::primitive_modify_code_heap()
{
+ bool reset_inline_caches = to_boolean(ctx->pop());
+ bool update_existing_words = to_boolean(ctx->pop());
data_root<array> alist(ctx->pop(),this);
cell count = array_capacity(alist.untagged());
update_word_entry_point(word.untagged());
}
- update_code_heap_words();
+ if(update_existing_words)
+ update_code_heap_words(reset_inline_caches);
+ else
+ initialize_code_blocks();
}
code_heap_room factor_vm::code_room()
each_code_block(stripper);
}
+struct code_block_accumulator {
+ std::vector<cell> objects;
+
+ void operator()(code_block *compiled, cell size)
+ {
+ objects.push_back(compiled->owner);
+ objects.push_back(compiled->parameters);
+ objects.push_back(compiled->relocation);
+
+ objects.push_back(tag_fixnum(compiled->type()));
+ objects.push_back(tag_fixnum(compiled->size()));
+
+ /* Note: the entry point is always a multiple of the heap
+ alignment (16 bytes). We cannot allocate while iterating
+ through the code heap, so it is not possible to call allot_cell()
+ here. It is OK, however, to add it as if it were a fixnum, and
+ have library code shift it to the left by 4. */
+ cell entry_point = (cell)compiled->entry_point();
+ assert((entry_point & (data_alignment - 1)) == 0);
+ assert((entry_point & TAG_MASK) == FIXNUM_TYPE);
+ objects.push_back(entry_point);
+ }
+};
+
+cell factor_vm::code_blocks()
+{
+ code_block_accumulator accum;
+ each_code_block(accum);
+ return std_vector_to_array(accum.objects);
+}
+
+void factor_vm::primitive_code_blocks()
+{
+ ctx->push(code_blocks());
+}
+
}
inline static void check_call_site(cell return_address)
{
-#ifdef FACTOR_DEBUG
cell insn = *(cell *)return_address;
/* Check that absolute bit is 0 */
assert((insn & 0x2) == 0x0);
/* Check that instruction is branch */
assert((insn >> 26) == 0x12);
-#endif
}
static const cell b_mask = 0x3fffffc;
inline static unsigned int fpu_status(unsigned int status)
{
- unsigned int r = 0;
+ unsigned int r = 0;
- if (status & 0x20000000)
+ if (status & 0x20000000)
r |= FP_TRAP_INVALID_OPERATION;
- if (status & 0x10000000)
+ if (status & 0x10000000)
r |= FP_TRAP_OVERFLOW;
- if (status & 0x08000000)
+ if (status & 0x08000000)
r |= FP_TRAP_UNDERFLOW;
- if (status & 0x04000000)
+ if (status & 0x04000000)
r |= FP_TRAP_ZERO_DIVIDE;
- if (status & 0x02000000)
+ if (status & 0x02000000)
r |= FP_TRAP_INEXACT;
- return r;
+ return r;
}
/* Defined in assembly */
inline static void check_call_site(cell return_address)
{
-#ifdef FACTOR_DEBUG
unsigned char opcode = call_site_opcode(return_address);
assert(opcode == call_opcode || opcode == jmp_opcode);
-#endif
}
inline static void *get_call_target(cell return_address)
inline static unsigned int fpu_status(unsigned int status)
{
- unsigned int r = 0;
+ unsigned int r = 0;
- if (status & 0x01)
+ if (status & 0x01)
r |= FP_TRAP_INVALID_OPERATION;
- if (status & 0x04)
+ if (status & 0x04)
r |= FP_TRAP_ZERO_DIVIDE;
- if (status & 0x08)
+ if (status & 0x08)
r |= FP_TRAP_OVERFLOW;
- if (status & 0x10)
+ if (status & 0x10)
r |= FP_TRAP_UNDERFLOW;
- if (status & 0x20)
+ if (status & 0x20)
r |= FP_TRAP_INEXACT;
- return r;
+ return r;
}
}
return sizeof(wrapper);
default:
critical_error("Invalid header",(cell)this);
- return 0; /* can't happen */
+ return 0; /* can't happen */
}
}
{
object_accumulator accum(type);
each_object(accum);
- cell object_count = accum.objects.size();
-
- data_roots.push_back(data_root_range(&accum.objects[0],object_count));
-
- array *objects = allot_array(object_count,false_object);
- memcpy(objects->data(),&accum.objects[0],object_count * sizeof(cell));
-
- data_roots.pop_back();
-
- return tag<array>(objects);
+ return std_vector_to_array(accum.objects);
}
void factor_vm::primitive_all_instances()
fflush(stdout);
compile_all_words();
- update_code_heap_words();
+ update_code_heap_words(true);
initialize_all_quotations();
special_objects[OBJ_STAGE2] = true_object;
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
data->tenured->clear_mark_bits();
collector.trace_roots();
- if(trace_contexts_p)
+ if(trace_contexts_p)
{
collector.trace_contexts();
collector.trace_context_code_blocks();
struct gc_state {
gc_op op;
u64 start_time;
- jmp_buf gc_unwind;
+ jmp_buf gc_unwind;
gc_event *event;
explicit gc_state(gc_op op_, factor_vm *parent);
if(safe_fwrite(&h,sizeof(image_header),1,file) != 1) ok = false;
if(safe_fwrite((void*)data->tenured->start,h.data_size,1,file) != 1) ok = false;
if(safe_fwrite(code->allocator->first_block(),h.code_size,1,file) != 1) ok = false;
- if(safe_fclose(file)) ok = false;
+ safe_fclose(file);
if(!ok)
std::cout << "save-image failed: " << strerror(errno) << std::endl;
else
- MOVE_FILE(saving_filename,filename);
+ move_file(saving_filename,filename);
return ok;
}
general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL);
}
-size_t safe_fread(void *ptr, size_t size, size_t nitems, FILE *stream)
+FILE *factor_vm::safe_fopen(char *filename, char *mode)
+{
+ FILE *file;
+ do {
+ file = fopen(filename,mode);
+ if(file == NULL)
+ io_error();
+ else
+ break;
+ } while(errno == EINTR);
+ return file;
+}
+
+int factor_vm::safe_fgetc(FILE *stream)
+{
+ int c;
+ do {
+ c = fgetc(stream);
+ if(c == EOF)
+ {
+ if(feof(stream))
+ return EOF;
+ else
+ io_error();
+ }
+ else
+ break;
+ } while(errno == EINTR);
+ return c;
+}
+
+size_t factor_vm::safe_fread(void *ptr, size_t size, size_t nitems, FILE *stream)
{
size_t items_read = 0;
return items_read;
}
-size_t safe_fwrite(void *ptr, size_t size, size_t nitems, FILE *stream)
+void factor_vm::safe_fputc(int c, FILE *stream)
+{
+ do {
+ if(fputc(c,stream) == EOF)
+ io_error();
+ else
+ break;
+ } while(errno == EINTR);
+}
+
+size_t factor_vm::safe_fwrite(void *ptr, size_t size, size_t nitems, FILE *stream)
{
size_t items_written = 0;
return items_written;
}
-int safe_fclose(FILE *stream)
+int factor_vm::safe_ftell(FILE *stream)
{
- int ret = 0;
+ off_t offset;
+ do {
+ if((offset = FTELL(stream)) == -1)
+ io_error();
+ else
+ break;
+ } while(errno == EINTR);
+ return offset;
+}
+
+void factor_vm::safe_fseek(FILE *stream, off_t offset, int whence)
+{
+ switch(whence)
+ {
+ case 0: whence = SEEK_SET; break;
+ case 1: whence = SEEK_CUR; break;
+ case 2: whence = SEEK_END; break;
+ default:
+ critical_error("Bad value for whence",whence);
+ }
do {
- ret = fclose(stream);
- } while(ret != 0 && errno == EINTR);
+ if(FSEEK(stream,offset,whence) == -1)
+ io_error();
+ else
+ break;
+ } while(errno == EINTR);
+}
- return ret;
+void factor_vm::safe_fflush(FILE *stream)
+{
+ do {
+ if(fflush(stream) == EOF)
+ io_error();
+ else
+ break;
+ } while(errno == EINTR);
+}
+
+void factor_vm::safe_fclose(FILE *stream)
+{
+ do {
+ if(fclose(stream) == EOF)
+ io_error();
+ else
+ break;
+ } while(errno == EINTR);
}
void factor_vm::primitive_fopen()
path.untag_check(this);
FILE *file;
- do {
- file = fopen((char *)(path.untagged() + 1),
- (char *)(mode.untagged() + 1));
- if(file == NULL)
- io_error();
- } while(errno == EINTR);
-
+ file = safe_fopen((char *)(path.untagged() + 1),
+ (char *)(mode.untagged() + 1));
ctx->push(allot_alien(file));
}
{
FILE *file = pop_file_handle();
- do {
- int c = fgetc(file);
- if(c == EOF)
- {
- if(feof(file))
- {
- ctx->push(false_object);
- break;
- }
- else
- io_error();
- }
- else
- {
- ctx->push(tag_fixnum(c));
- break;
- }
- } while(errno == EINTR);
+ int c = safe_fgetc(file);
+ if(c == EOF && feof(file))
+ ctx->push(false_object);
+ else
+ ctx->push(tag_fixnum(c));
}
void factor_vm::primitive_fread()
data_root<byte_array> buf(allot_uninitialized_array<byte_array>(size),this);
- for(;;)
+ int c = safe_fread(buf.untagged() + 1,1,size,file);
+ if(c == 0)
{
- int c = safe_fread(buf.untagged() + 1,1,size,file);
- if(c == 0)
- {
- if(feof(file))
- {
- ctx->push(false_object);
- break;
- }
- else
- io_error();
- }
+ if(feof(file))
+ ctx->push(false_object);
else
+ io_error();
+ }
+ else
+ {
+ if(feof(file))
{
- if(feof(file))
- {
- byte_array *new_buf = allot_byte_array(c);
- memcpy(new_buf + 1, buf.untagged() + 1,c);
- buf = new_buf;
- }
-
- ctx->push(buf.value());
- break;
+ byte_array *new_buf = allot_byte_array(c);
+ memcpy(new_buf + 1, buf.untagged() + 1,c);
+ buf = new_buf;
}
+
+ ctx->push(buf.value());
}
}
{
FILE *file = pop_file_handle();
fixnum ch = to_fixnum(ctx->pop());
-
- do {
- if(fputc(ch,file) == EOF)
- io_error();
- else
- break;
- } while(errno == EINTR);
+ safe_fputc(ch, file);
}
void factor_vm::primitive_fwrite()
void factor_vm::primitive_ftell()
{
FILE *file = pop_file_handle();
- off_t offset;
-
- do {
- if((offset = FTELL(file)) == -1)
- io_error();
- else
- break;
- } while(errno == EINTR);
-
- ctx->push(from_signed_8(offset));
+ ctx->push(from_signed_8(safe_ftell(file)));
}
void factor_vm::primitive_fseek()
int whence = to_fixnum(ctx->pop());
FILE *file = pop_file_handle();
off_t offset = to_signed_8(ctx->pop());
-
- switch(whence)
- {
- case 0: whence = SEEK_SET; break;
- case 1: whence = SEEK_CUR; break;
- case 2: whence = SEEK_END; break;
- default:
- critical_error("Bad value for whence",whence);
- break;
- }
-
- do {
- if(FSEEK(file,offset,whence) == -1)
- io_error();
- else
- break;
- } while(errno == EINTR);
+ safe_fseek(file,offset,whence);
}
void factor_vm::primitive_fflush()
{
FILE *file = pop_file_handle();
- do {
- if(fflush(file) == EOF)
- io_error();
- else
- break;
- } while(errno == EINTR);
+ safe_fflush(file);
}
void factor_vm::primitive_fclose()
{
FILE *file = pop_file_handle();
- if(safe_fclose(file) == EOF)
- io_error();
+ safe_fclose(file);
}
/* This function is used by FFI I/O. Accessing the errno global directly is
return errno;
}
-VM_C_API void clear_err_no()
+VM_C_API void set_err_no(int err)
{
- errno = 0;
+ errno = err;
}
}
namespace factor
{
-size_t safe_fread(void *ptr, size_t size, size_t nitems, FILE *stream);
-size_t safe_fwrite(void *ptr, size_t size, size_t nitems, FILE *stream);
-int safe_fclose(FILE *stream);
-
/* Platform specific primitives */
VM_C_API int err_no();
-VM_C_API void clear_err_no();
+VM_C_API void set_err_no(int err);
}
void word_jump(cell word_)
{
data_root<word> word(word_,parent);
+#ifndef FACTOR_AMD64
literal(tag_fixnum(xt_tail_pic_offset));
+#endif
literal(word.value());
emit(parent->special_objects[JIT_WORD_JUMP]);
}
return position;
}
- void set_position(fixnum position_)
+ void set_position(fixnum position_)
{
if(computing_offset_p)
position = position_;
void factor_vm::primitive_bignum_shift()
{
fixnum y = untag_fixnum(ctx->pop());
- bignum* x = untag<bignum>(ctx->pop());
+ bignum* x = untag<bignum>(ctx->pop());
ctx->push(tag<bignum>(bignum_arithmetic_shift(x,y)));
}
ctx->replace(allot_float(bignum_to_float(ctx->peek())));
}
-void factor_vm::primitive_str_to_float()
-{
- byte_array *bytes = untag_check<byte_array>(ctx->peek());
- cell capacity = array_capacity(bytes);
-
- char *c_str = (char *)(bytes + 1);
- char *end = c_str;
- double f = strtod(c_str,&end);
- if(end == c_str + capacity - 1)
- ctx->replace(allot_float(f));
- else
- ctx->replace(false_object);
-}
-
void factor_vm::primitive_float_to_str()
{
byte_array *array = allot_byte_array(33);
}
};
+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);
+ }
}
}
inline static unsigned int uap_fpu_status(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387)
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387)
{
struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate);
return x87->sv_env.en_sw;
- }
+ }
else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
{
struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate);
return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr;
- }
+ }
else
return 0;
}
inline static void uap_clear_fpu_status(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387)
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_387)
{
struct save87 *x87 = (struct save87 *)(&ucontext->uc_mcontext.mc_fpstate);
x87->sv_env.en_sw = 0;
- }
+ }
else if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
{
struct savexmm *xmm = (struct savexmm *)(&ucontext->uc_mcontext.mc_fpstate);
xmm->sv_env.en_sw = 0;
xmm->sv_env.en_mxcsr &= 0xffffffc0;
- }
+ }
}
inline static unsigned int uap_fpu_status(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
{
struct savefpu *xmm = (struct savefpu *)(&ucontext->uc_mcontext.mc_fpstate);
return xmm->sv_env.en_sw | xmm->sv_env.en_mxcsr;
- }
+ }
else
return 0;
}
inline static void uap_clear_fpu_status(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ if (ucontext->uc_mcontext.mc_fpformat == _MC_FPFMT_XMM)
{
struct savefpu *xmm = (struct savefpu *)(&ucontext->uc_mcontext.mc_fpstate);
xmm->sv_env.en_sw = 0;
xmm->sv_env.en_mxcsr &= 0xffffffc0;
- }
+ }
}
inline static unsigned int uap_fpu_status(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- return ucontext->uc_mcontext.fpregs->swd
- | ucontext->uc_mcontext.fpregs->mxcsr;
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ return ucontext->uc_mcontext.fpregs->swd
+ | ucontext->uc_mcontext.fpregs->mxcsr;
}
inline static void uap_clear_fpu_status(void *uap)
{
- ucontext_t *ucontext = (ucontext_t *)uap;
- ucontext->uc_mcontext.fpregs->swd = 0;
- ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0;
+ ucontext_t *ucontext = (ucontext_t *)uap;
+ ucontext->uc_mcontext.fpregs->swd = 0;
+ ucontext->uc_mcontext.fpregs->mxcsr &= 0xffffffc0;
}
#define UAP_STACK_POINTER(ucontext) (((ucontext_t *)ucontext)->uc_mcontext.gregs[15])
ctx->push(tag_boolean(stat(path,&sb) >= 0));
}
+void factor_vm::move_file(const vm_char *path1, const vm_char *path2)
+{
+ int ret = 0;
+ do {
+ ret = rename((path1),(path2));
+ } while(ret < 0 && errno == EINTR);
+ if(ret < 0)
+ general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL);
+}
+
segment::segment(cell size_, bool executable_p)
{
size = size_;
#define OPEN_READ(path) fopen(path,"rb")
#define OPEN_WRITE(path) fopen(path,"wb")
-#define MOVE_FILE(path1,path2) \
-do {\
- int ret = 0;\
- do {\
- ret = rename((path1),(path2));\
- } while(ret < 0 && errno == EINTR);\
- if(ret < 0)\
- general_error(ERROR_IO,tag_fixnum(errno),false_object,NULL);\
-}while(0)
#define print_native_string(string) print_string(string)
factor_vm *tls_vm();
void open_console();
+void move_file(const vm_char *path1, const vm_char *path2);
+
}
- EPOCH_OFFSET) / 10;
}
-/* On VirtualBox, QueryPerformanceCounter does not increment
-the high part every time the low part overflows. Workaround. */
u64 nano_count()
{
LARGE_INTEGER count;
if(ret == 0)
fatal_error("QueryPerformanceFrequency", 0);
- if(count.LowPart < lo)
- hi += 1;
+#ifdef FACTOR_64
+ hi = count.HighPart;
+#else
+ /* On VirtualBox, QueryPerformanceCounter does not increment
+ the high part every time the low part overflows. Workaround. */
+ if(lo > count.LowPart)
+ hi++;
+#endif
lo = count.LowPart;
return (u64)((((u64)hi << 32) | (u64)lo)*(1000000000.0/frequency.QuadPart));
else
signal_callstack_top = NULL;
- switch (e->ExceptionCode)
- {
- case EXCEPTION_ACCESS_VIOLATION:
+ switch (e->ExceptionCode)
+ {
+ case EXCEPTION_ACCESS_VIOLATION:
signal_fault_addr = e->ExceptionInformation[1];
c->EIP = (cell)factor::memory_signal_handler_impl;
- break;
+ break;
case STATUS_FLOAT_DENORMAL_OPERAND:
case STATUS_FLOAT_DIVIDE_BY_ZERO:
case STATUS_FLOAT_UNDERFLOW:
case STATUS_FLOAT_MULTIPLE_FAULTS:
case STATUS_FLOAT_MULTIPLE_TRAPS:
-#ifdef FACTOR_AMD64
+#ifdef FACTOR_64
signal_fpu_status = fpu_status(MXCSR(c));
#else
signal_fpu_status = fpu_status(X87SW(c) | MXCSR(c));
long getpagesize()
{
static long g_pagesize = 0;
- if (! g_pagesize)
+ if(!g_pagesize)
{
SYSTEM_INFO system_info;
GetSystemInfo (&system_info);
return g_pagesize;
}
+void factor_vm::move_file(const vm_char *path1, const vm_char *path2)
+{
+ if(MoveFileEx((path1),(path2),MOVEFILE_REPLACE_EXISTING) == false)
+ general_error(ERROR_IO,tag_fixnum(GetLastError()),false_object,NULL);
+}
+
}
#define OPEN_READ(path) _wfopen((path),L"rb")
#define OPEN_WRITE(path) _wfopen((path),L"wb")
-#define MOVE_FILE(path1,path2)\
-do {\
- if(MoveFileEx((path1),(path2),MOVEFILE_REPLACE_EXISTING) == false)\
- std::cout << "MoveFile() failed: error " << GetLastError() << std::endl;\
-} while(0)
/* Difference between Jan 1 00:00:00 1601 and Jan 1 00:00:00 1970 */
#define EPOCH_OFFSET 0x019db1ded53e8000LL
u64 nano_count();
void sleep_nanos(u64 nsec);
long getpagesize();
+void move_file(const vm_char *path1, const vm_char *path2);
}
PRIMITIVE(callstack_to_array)
PRIMITIVE(check_datastack)
PRIMITIVE(clone)
+PRIMITIVE(code_blocks)
PRIMITIVE(code_room)
PRIMITIVE(compact_gc)
PRIMITIVE(compute_identity_hashcode)
PRIMITIVE(size)
PRIMITIVE(sleep)
PRIMITIVE(special_object)
-PRIMITIVE(str_to_float)
PRIMITIVE(string)
PRIMITIVE(string_nth)
PRIMITIVE(strip_stack_traces)
DECLARE_PRIMITIVE(callstack_to_array)
DECLARE_PRIMITIVE(check_datastack)
DECLARE_PRIMITIVE(clone)
+DECLARE_PRIMITIVE(code_blocks)
DECLARE_PRIMITIVE(code_room)
DECLARE_PRIMITIVE(compact_gc)
DECLARE_PRIMITIVE(compute_identity_hashcode)
DECLARE_PRIMITIVE(size)
DECLARE_PRIMITIVE(sleep)
DECLARE_PRIMITIVE(special_object)
-DECLARE_PRIMITIVE(str_to_float)
DECLARE_PRIMITIVE(string)
DECLARE_PRIMITIVE(string_nth)
DECLARE_PRIMITIVE(strip_stack_traces)
update_word_entry_point(word.untagged());
}
- update_code_heap_words();
+ update_code_heap_words(false);
}
void factor_vm::primitive_profiling()
-#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();
+}
+
+}
void bignum_destructive_add(bignum * bignum, bignum_digit_type n);
void bignum_destructive_scale_up(bignum * bignum, bignum_digit_type factor);
void bignum_divide_unsigned_large_denominator(bignum * numerator, bignum * denominator,
- bignum * * quotient, bignum * * remainder, int q_negative_p, int r_negative_p);
+ bignum * * quotient, bignum * * remainder, int q_negative_p, int r_negative_p);
void bignum_divide_unsigned_normalized(bignum * u, bignum * v, bignum * q);
bignum_digit_type bignum_divide_subtract(bignum_digit_type * v_start, bignum_digit_type * v_end,
- bignum_digit_type guess, bignum_digit_type * u_start);
+ bignum_digit_type guess, bignum_digit_type * u_start);
void bignum_divide_unsigned_medium_denominator(bignum * numerator,bignum_digit_type denominator,
- bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p);
+ bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p);
void bignum_destructive_normalization(bignum * source, bignum * target, int shift_left);
void bignum_destructive_unnormalization(bignum * bignum, int shift_right);
bignum_digit_type bignum_digit_divide(bignum_digit_type uh, bignum_digit_type ul,
- bignum_digit_type v, bignum_digit_type * q) /* return value */;
+ bignum_digit_type v, bignum_digit_type * q) /* return value */;
bignum_digit_type bignum_digit_divide_subtract(bignum_digit_type v1, bignum_digit_type v2,
- bignum_digit_type guess, bignum_digit_type * u);
+ bignum_digit_type guess, bignum_digit_type * u);
void bignum_divide_unsigned_small_denominator(bignum * numerator, bignum_digit_type denominator,
- bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p);
+ bignum * * quotient, bignum * * remainder,int q_negative_p, int r_negative_p);
bignum_digit_type bignum_destructive_scale_down(bignum * bignum, bignum_digit_type denominator);
bignum * bignum_remainder_unsigned_small_denominator(bignum * n, bignum_digit_type d, int negative_p);
bignum *bignum_digit_to_bignum(bignum_digit_type digit, int negative_p);
if(!(current_gc && current_gc->op == collect_growing_heap_op))
{
assert((cell)pointer >= data->seg->start
- && (cell)pointer < data->seg->end);
+ && (cell)pointer < data->seg->end);
}
#endif
}
void primitive_die();
//arrays
+ inline void set_array_nth(array *array, cell slot, cell value);
array *allot_array(cell capacity, cell fill_);
void primitive_array();
cell allot_array_1(cell obj_);
cell allot_array_2(cell v1_, cell v2_);
cell allot_array_4(cell v1_, cell v2_, cell v3_, cell v4_);
void primitive_resize_array();
- inline void set_array_nth(array *array, cell slot, cell value);
+ cell std_vector_to_array(std::vector<cell> &elements);
//strings
cell string_nth(const string *str, cell index);
cell unbox_array_size_slow();
void primitive_fixnum_to_float();
void primitive_bignum_to_float();
- void primitive_str_to_float();
void primitive_float_to_str();
void primitive_float_eq();
void primitive_float_add();
//io
void init_c_io();
void io_error();
+ FILE* safe_fopen(char *filename, char *mode);
+ int safe_fgetc(FILE *stream);
+ size_t safe_fread(void *ptr, size_t size, size_t nitems, FILE *stream);
+ void safe_fputc(int c, FILE* stream);
+ size_t safe_fwrite(void *ptr, size_t size, size_t nitems, FILE *stream);
+ int safe_ftell(FILE *stream);
+ void safe_fseek(FILE *stream, off_t offset, int whence);
+ void safe_fflush(FILE *stream);
+ void safe_fclose(FILE *stream);
void primitive_fopen();
FILE *pop_file_handle();
void primitive_fgetc();
cell compute_entry_point_pic_address(cell w_);
cell compute_entry_point_pic_tail_address(cell w_);
cell code_block_owner(code_block *compiled);
- void update_word_references(code_block *compiled);
+ void update_word_references(code_block *compiled, bool reset_inline_caches);
void undefined_symbol();
cell compute_dlsym_address(array *literals, cell index);
cell compute_vm_address(cell arg);
void store_external_address(instruction_operand op);
cell compute_here_address(cell arg, cell offset, code_block *compiled);
+ void initialize_code_block(code_block *compiled, cell literals);
void initialize_code_block(code_block *compiled);
void fixup_labels(array *labels, code_block *compiled);
code_block *allot_code_block(cell size, code_block_type type);
code_block *add_code_block(code_block_type type, cell code_, cell labels_, cell owner_, cell relocation_, cell parameters_, cell literals_);
//code heap
- inline void check_code_pointer(cell ptr)
+ inline void check_code_pointer(cell ptr) { }
+
+ template<typename Iterator> void each_code_block(Iterator &iter)
{
- #ifdef FACTOR_DEBUG
- //assert(in_code_heap_p(ptr));
- #endif
+ code->allocator->iterate(iter);
}
void init_code_heap(cell size);
bool in_code_heap_p(cell ptr);
- void update_code_heap_words();
+ void update_code_heap_words(bool reset_inline_caches);
+ void initialize_code_blocks();
void primitive_modify_code_heap();
code_heap_room code_room();
void primitive_code_room();
void primitive_strip_stack_traces();
-
- template<typename Iterator> void each_code_block(Iterator &iter)
- {
- code->allocator->iterate(iter);
- }
+ cell code_blocks();
+ void primitive_code_blocks();
//callbacks
void init_callbacks(cell size);
// os-*
void primitive_existsp();
+ void move_file(const vm_char *path1, const vm_char *path2);
void init_ffi();
void ffi_dlopen(dll *dll);
void *ffi_dlsym(dll *dll, symbol_char *symbol);
projects / factor.git / commitdiff