Merge branch 'master' of git://factorcode.org/git/factor
Aaron Schaefer
commit
6e3812b563
basis
alien
binary-search
bootstrap
compiler
image
download
collada/viewer
combinators
short-circuit
smart
compiler
codegen
crossref
test
tree
debugger
escape-analysis/simple
propagation
compression/lzw
core-foundation/arrays
db
errors
postgresql
sqlite/lib
debugger
delegate
eval
ftp/server
functors
furnace
generalizations
help
apropos
handbook
home
topics
vocabs
hints
html/forms
images/tga
io
directories
launcher
windows
styles
json
reader
libc
listener
locals
definitions
math
opengl/gl
prettyprint
regexp/negation
see
serialize
|
|
@ -8,7 +8,9 @@ Factor/factor
|
|||
*.a
|
||||
*.dll
|
||||
*.lib
|
||||
*.exp
|
||||
*.res
|
||||
*.RES
|
||||
*.image
|
||||
*.dylib
|
||||
factor
|
||||
|
|
|
|||
|
|
@ -61,7 +61,7 @@ DLL_OBJS = vm\os-windows-nt.obj \
|
|||
.rs.res:
|
||||
rc $<
|
||||
|
||||
all: factor.com factor.exe
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
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
|
||||
|
|
@ -100,3 +101,12 @@ DEFER: struct-redefined
|
|||
\ 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
|
||||
|
|
|
|||
|
|
@ -78,6 +78,9 @@ M: string resolve-pointer-type
|
|||
[ 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 ;
|
||||
|
|
@ -551,9 +554,6 @@ M: ulonglong-2-rep rep-component-type drop ulonglong ;
|
|||
M: float-4-rep rep-component-type drop float ;
|
||||
M: double-2-rep rep-component-type drop double ;
|
||||
|
||||
: rep-length ( rep -- n )
|
||||
16 swap rep-component-type heap-size /i ; foldable
|
||||
|
||||
: (unsigned-interval) ( bytes -- from to ) [ 0 ] dip 8 * 2^ 1 - ; foldable
|
||||
: unsigned-interval ( c-type -- from to ) heap-size (unsigned-interval) ; foldable
|
||||
: (signed-interval) ( bytes -- from to ) 8 * 1 - 2^ [ neg ] [ 1 - ] bi ; foldable
|
||||
|
|
|
|||
|
|
@ -3,12 +3,13 @@ USING: accessors alien alien.c-types alien.complex
|
|||
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] } ;
|
||||
|
|
@ -23,148 +24,163 @@ intel-unix-abi fortran-abi [
|
|||
|
||||
! 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
|
||||
|
||||
|
|
@ -184,8 +200,8 @@ intel-unix-abi fortran-abi [
|
|||
} 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>]
|
||||
|
|
@ -210,7 +226,7 @@ intel-unix-abi fortran-abi [
|
|||
[ { [ 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 )
|
||||
|
|
@ -222,13 +238,13 @@ intel-unix-abi fortran-abi [
|
|||
|
||||
[ [
|
||||
! [<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>]
|
||||
|
|
@ -244,8 +260,8 @@ intel-unix-abi fortran-abi [
|
|||
[ 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>]
|
||||
|
|
@ -270,8 +286,8 @@ intel-unix-abi fortran-abi [
|
|||
} 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>]
|
||||
|
|
@ -302,19 +318,19 @@ intel-windows-abi fortran-abi [
|
|||
|
||||
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
|
||||
|
|
@ -325,34 +341,34 @@ f2c-abi fortran-abi [
|
|||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -1,11 +1,12 @@
|
|||
! (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 ;
|
||||
|
|
@ -101,8 +102,7 @@ CONSTANT: fortran>c-types H{
|
|||
}
|
||||
|
||||
: 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
|
||||
|
|
@ -118,35 +118,35 @@ MACRO: size-case-type ( cases -- )
|
|||
|
||||
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&& ;
|
||||
|
|
@ -158,7 +158,7 @@ M: misc-type (fortran-type>c-type)
|
|||
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 ;
|
||||
|
|
@ -181,13 +181,10 @@ M: character-type (fortran-type>c-type)
|
|||
: 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 -- ? )
|
||||
|
||||
|
|
@ -200,10 +197,10 @@ M: complex-type returns-by-value?
|
|||
|
||||
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 )
|
||||
|
||||
|
|
@ -354,7 +351,7 @@ M: character-type (<fortran-result>)
|
|||
|
||||
: (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
|
||||
|
|
@ -395,13 +392,13 @@ PRIVATE>
|
|||
|
||||
: 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 )
|
||||
|
|
@ -433,7 +430,7 @@ MACRO: fortran-invoke ( return library function parameters -- )
|
|||
|
||||
:: 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:
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! 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
|
||||
|
|
@ -22,7 +22,7 @@ SYNTAX: CALLBACK:
|
|||
(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
|
||||
|
|
|
|||
|
|
@ -8,7 +8,21 @@ $nl
|
|||
"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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! Copyright (C) 2007, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors cpu.architecture vocabs.loader system
|
||||
sequences namespaces parser kernel kernel.private classes
|
||||
|
|
@ -33,6 +33,7 @@ enable-optimizer
|
|||
gc
|
||||
|
||||
: compile-unoptimized ( words -- )
|
||||
[ [ subwords ] map ] keep suffix concat
|
||||
[ optimized? not ] filter compile ;
|
||||
|
||||
"debug-compiler" get [
|
||||
|
|
@ -102,7 +103,7 @@ gc
|
|||
"." 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
|
||||
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: http.client checksums checksums.md5 splitting assocs
|
||||
kernel io.files bootstrap.image sequences io urls ;
|
||||
|
|
@ -19,9 +19,11 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
|
|||
] [ drop t ] if ;
|
||||
|
||||
: download-image ( arch -- )
|
||||
boot-image-name dup need-new-image? [
|
||||
"Downloading " write dup write "..." print
|
||||
url over >url derive-url download
|
||||
url swap boot-image-name >url derive-url download ;
|
||||
|
||||
: maybe-download-image ( arch -- )
|
||||
dup boot-image-name need-new-image? [
|
||||
dup download-image
|
||||
need-new-image? [
|
||||
"Boot image corrupt, or checksums.txt on server out of date" throw
|
||||
] when
|
||||
|
|
@ -30,6 +32,6 @@ CONSTANT: url URL" http://factorcode.org/images/latest/"
|
|||
drop
|
||||
] if ;
|
||||
|
||||
: download-my-image ( -- ) my-arch download-image ;
|
||||
: download-my-image ( -- ) my-arch maybe-download-image ;
|
||||
|
||||
MAIN: download-my-image
|
||||
|
|
|
|||
|
|
@ -545,7 +545,7 @@ M: quotation '
|
|||
\ 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 ;
|
||||
|
|
|
|||
|
|
@ -1,195 +0,0 @@
|
|||
! 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 collada fry xml xml.traversal sequences.deep
|
||||
|
||||
opengl.gl
|
||||
prettyprint ;
|
||||
FROM: alien.c-types => float ;
|
||||
SPECIALIZED-ARRAY: float
|
||||
SPECIALIZED-VECTOR: uint
|
||||
IN: collada.viewer
|
||||
|
||||
GLSL-SHADER: collada-vertex-shader vertex-shader
|
||||
uniform mat4 mv_matrix, p_matrix;
|
||||
uniform vec3 light_position;
|
||||
|
||||
attribute vec3 POSITION;
|
||||
attribute vec3 NORMAL;
|
||||
|
||||
void main()
|
||||
{
|
||||
vec4 position = mv_matrix * vec4(POSITION, 1.0);
|
||||
gl_Position = p_matrix * position;
|
||||
}
|
||||
;
|
||||
|
||||
GLSL-SHADER: collada-fragment-shader fragment-shader
|
||||
void main()
|
||||
{
|
||||
gl_FragColor = vec4(1, 1, 0, 1);
|
||||
}
|
||||
;
|
||||
|
||||
GLSL-PROGRAM: collada-program
|
||||
collada-vertex-shader collada-fragment-shader ;
|
||||
|
||||
GLSL-SHADER: debug-vertex-shader vertex-shader
|
||||
uniform mat4 mv_matrix, p_matrix;
|
||||
uniform vec3 light_position;
|
||||
|
||||
attribute vec3 POSITION;
|
||||
attribute vec3 COLOR;
|
||||
varying vec4 color;
|
||||
|
||||
void main()
|
||||
{
|
||||
gl_Position = p_matrix * mv_matrix * vec4(POSITION, 1.0);
|
||||
color = vec4(COLOR, 1);
|
||||
}
|
||||
;
|
||||
|
||||
GLSL-SHADER: debug-fragment-shader fragment-shader
|
||||
varying vec4 color;
|
||||
void main()
|
||||
{
|
||||
gl_FragColor = color;
|
||||
}
|
||||
;
|
||||
|
||||
GLSL-PROGRAM: debug-program debug-vertex-shader debug-fragment-shader ;
|
||||
|
||||
UNIFORM-TUPLE: collada-uniforms < mvp-uniforms
|
||||
{ "light-position" vec3-uniform f } ;
|
||||
|
||||
TUPLE: collada-state
|
||||
models
|
||||
vertex-arrays
|
||||
index-vectors ;
|
||||
|
||||
TUPLE: collada-world < wasd-world
|
||||
{ collada collada-state } ;
|
||||
|
||||
VERTEX-FORMAT: collada-vertex
|
||||
{ "POSITION" float-components 3 f }
|
||||
{ "NORMAL" float-components 3 f } ;
|
||||
|
||||
VERTEX-FORMAT: debug-vertex
|
||||
{ "POSITION" float-components 3 f }
|
||||
{ "COLOR" float-components 3 f } ;
|
||||
|
||||
: <collada-buffers> ( models -- buffers )
|
||||
! drop
|
||||
! float-array{ -0.5 0 0 1 0 0 0 1 0 0 1 0 0.5 0 0 0 0 1 }
|
||||
! uint-array{ 0 1 2 }
|
||||
! f model boa 1array
|
||||
[
|
||||
[ 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 ] tri 3array
|
||||
] map ;
|
||||
|
||||
: fill-collada-state ( collada-state -- )
|
||||
dup models>> <collada-buffers>
|
||||
[
|
||||
[
|
||||
first collada-program <program-instance> collada-vertex buffer>vertex-array
|
||||
] map >>vertex-arrays drop
|
||||
]
|
||||
[
|
||||
[
|
||||
[ second ] [ third ] bi
|
||||
'[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
|
||||
] map >>index-vectors drop
|
||||
] 2bi ;
|
||||
|
||||
: <collada-state> ( -- collada-state )
|
||||
collada-state new
|
||||
#! "C:/Users/erikc/Downloads/mech.dae"
|
||||
"/Users/erikc/Documents/mech.dae"
|
||||
file>xml "mesh" deep-tags-named [ mesh>models ] map flatten >>models ;
|
||||
|
||||
M: collada-world begin-game-world
|
||||
init-gpu
|
||||
{ 0.0 0.0 2.0 } 0 0 set-wasd-view
|
||||
<collada-state> [ fill-collada-state drop ] [ >>collada drop ] 2bi ;
|
||||
|
||||
: <collada-uniforms> ( world -- uniforms )
|
||||
[ wasd-mv-matrix ] [ wasd-p-matrix ] bi
|
||||
{ -10000.0 10000.0 10000.0 } ! light position
|
||||
collada-uniforms boa ;
|
||||
|
||||
: draw-line ( world from to color -- )
|
||||
[ 3 head ] tri@ dup -rot append -rot append swap append >float-array
|
||||
underlying>> stream-upload draw-usage vertex-buffer byte-array>buffer
|
||||
debug-program <program-instance> debug-vertex buffer>vertex-array
|
||||
|
||||
{ 0 1 } >uint-array stream-upload draw-usage index-buffer byte-array>buffer
|
||||
2 '[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
|
||||
|
||||
rot <collada-uniforms>
|
||||
|
||||
{
|
||||
{ "primitive-mode" [ 3drop lines-mode ] }
|
||||
{ "uniforms" [ nip nip ] }
|
||||
{ "vertex-array" [ drop drop ] }
|
||||
{ "indexes" [ drop nip ] }
|
||||
} 3<render-set> render ;
|
||||
|
||||
: draw-lines ( world lines -- )
|
||||
3 <groups> [ first3 draw-line ] with each ; inline
|
||||
|
||||
: draw-axes ( world -- )
|
||||
{ { 0 0 0 } { 1 0 0 } { 1 0 0 }
|
||||
{ 0 0 0 } { 0 1 0 } { 0 1 0 }
|
||||
{ 0 0 0 } { 0 0 1 } { 0 0 1 } } draw-lines ;
|
||||
|
||||
: draw-collada ( world -- )
|
||||
GL_COLOR_BUFFER_BIT glClear
|
||||
|
||||
[
|
||||
triangle-lines dup t <triangle-state> set-gpu-state
|
||||
[ collada>> vertex-arrays>> ]
|
||||
[ collada>> index-vectors>> ]
|
||||
[ <collada-uniforms> ]
|
||||
tri
|
||||
[
|
||||
{
|
||||
{ "primitive-mode" [ 3drop triangles-mode ] }
|
||||
{ "uniforms" [ nip nip ] }
|
||||
{ "vertex-array" [ drop drop ] }
|
||||
{ "indexes" [ drop nip ] }
|
||||
} 3<render-set> render
|
||||
] curry 2each
|
||||
]
|
||||
[
|
||||
draw-axes
|
||||
]
|
||||
bi ;
|
||||
|
||||
M: collada-world draw-world*
|
||||
draw-collada ;
|
||||
|
||||
M: collada-world wasd-movement-speed drop 1/16. ;
|
||||
M: collada-world wasd-near-plane drop 1/32. ;
|
||||
M: collada-world wasd-far-plane drop 1024.0 ;
|
||||
|
||||
GAME: collada-game {
|
||||
{ world-class collada-world }
|
||||
{ title "Collada Viewer" }
|
||||
{ pixel-format-attributes {
|
||||
windowed
|
||||
double-buffered
|
||||
} }
|
||||
{ grab-input? t }
|
||||
{ use-game-input? t }
|
||||
{ pref-dim { 1024 768 } }
|
||||
{ tick-interval-micros $[ 60 fps ] }
|
||||
} ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: kernel math tools.test combinators.short-circuit ;
|
||||
USING: kernel math tools.test combinators.short-circuit accessors ;
|
||||
IN: combinators.short-circuit.tests
|
||||
|
||||
[ 3 ] [ { [ 1 ] [ 2 ] [ 3 ] } 0&& ] unit-test
|
||||
|
|
@ -22,4 +22,19 @@ IN: combinators.short-circuit.tests
|
|||
: compiled-|| ( a b -- ? ) { [ + odd? ] [ + 100 > ] [ + ] } 2|| ;
|
||||
|
||||
[ 30 ] [ 10 20 compiled-|| ] unit-test
|
||||
[ 2 ] [ 1 1 compiled-|| ] unit-test
|
||||
[ 2 ] [ 1 1 compiled-|| ] unit-test
|
||||
|
||||
! && and || should be row-polymorphic both when compiled and when interpreted
|
||||
|
||||
: row-&& ( -- ? )
|
||||
f t { [ drop dup ] } 1&& nip ;
|
||||
|
||||
[ f ] [ row-&& ] unit-test
|
||||
[ f ] [ \ row-&& def>> call ] unit-test
|
||||
|
||||
: row-|| ( -- ? )
|
||||
f t { [ drop dup ] } 1|| nip ;
|
||||
|
||||
[ f ] [ row-|| ] unit-test
|
||||
[ f ] [ \ row-|| def>> call ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,11 +1,19 @@
|
|||
USING: kernel combinators quotations arrays sequences assocs
|
||||
generalizations macros fry ;
|
||||
generalizations macros fry math ;
|
||||
IN: combinators.short-circuit
|
||||
|
||||
<PRIVATE
|
||||
|
||||
MACRO: keeping ( n quot -- quot' )
|
||||
swap dup 1 +
|
||||
'[ _ _ nkeep _ nrot ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: n&& ( quots n -- quot )
|
||||
[
|
||||
[ [ f ] ] 2dip swap [
|
||||
[ '[ drop _ ndup @ dup not ] ]
|
||||
[ '[ drop _ _ keeping dup not ] ]
|
||||
[ drop '[ drop _ ndrop f ] ]
|
||||
2bi 2array
|
||||
] with map
|
||||
|
|
@ -27,7 +35,7 @@ PRIVATE>
|
|||
MACRO: n|| ( quots n -- quot )
|
||||
[
|
||||
[ [ f ] ] 2dip swap [
|
||||
[ '[ drop _ ndup @ dup ] ]
|
||||
[ '[ drop _ _ keeping dup ] ]
|
||||
[ drop '[ _ nnip ] ]
|
||||
2bi 2array
|
||||
] with map
|
||||
|
|
|
|||
|
|
@ -53,4 +53,4 @@ MACRO: smart-if ( pred true false -- )
|
|||
'[ _ preserving _ _ if ] ;
|
||||
|
||||
MACRO: smart-apply ( quot n -- )
|
||||
[ dup inputs ] dip '[ _ _ mnapply ] ;
|
||||
[ dup inputs ] dip '[ _ _ _ mnapply ] ;
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ kernel kernel.private layouts assocs words summary arrays
|
|||
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
|
||||
|
|
@ -24,24 +24,12 @@ H{ } clone insn-counts set-global
|
|||
|
||||
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 ]
|
||||
|
|
@ -49,22 +37,12 @@ SYMBOL: labels
|
|||
] 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> %
|
||||
|
|
@ -104,6 +82,8 @@ CODEGEN: ##peek %peek
|
|||
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
|
||||
|
|
@ -409,20 +389,28 @@ M: c-type-name flatten-value-type c-type flatten-value-type ;
|
|||
: 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
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
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
|
||||
|
|
@ -21,8 +21,6 @@ ARTICLE: "compiler-usage" "Calling the optimizing compiler"
|
|||
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:"
|
||||
|
|
@ -30,7 +28,7 @@ $nl
|
|||
{ "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
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! 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
|
||||
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
|
||||
|
|
@ -21,29 +21,15 @@ compiler.cfg.mr
|
|||
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 ( word -- )
|
||||
#! If a word's stack effect changed, recompile all words
|
||||
#! that have compiled calls to it.
|
||||
dup recompile-callers?
|
||||
[ effect-dependencies-of keys [ queue-compile ] each ] [ drop ] if ;
|
||||
|
||||
: compiler-message ( string -- )
|
||||
"trace-compilation" get [ global [ print flush ] bind ] [ drop ] if ;
|
||||
|
||||
|
|
@ -54,7 +40,7 @@ SYMBOL: compiled
|
|||
|
||||
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? ;
|
||||
|
||||
|
|
@ -63,7 +49,7 @@ M: word 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? ;
|
||||
|
||||
|
|
@ -81,7 +67,6 @@ M: word combinator? inline? ;
|
|||
#! 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? [
|
||||
|
|
@ -89,7 +74,7 @@ M: word combinator? inline? ;
|
|||
[ 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
|
||||
|
|
@ -138,29 +123,10 @@ M: word combinator? inline? ;
|
|||
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 -- )
|
||||
|
|
@ -175,36 +141,31 @@ t compile-dependencies? set-global
|
|||
} 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'
|
||||
compiled-generic-usage swap '[
|
||||
nip dup classoid?
|
||||
[ _ classes-intersect? ] [ drop f ] if
|
||||
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
|
||||
maybe-changed get outdated-conditional-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 ;
|
||||
|
|
|
|||
|
|
@ -9,9 +9,9 @@ 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
|
||||
|
||||
: effect-dependencies-of ( word -- assoc )
|
||||
compiled-crossref get at ;
|
||||
|
|
@ -22,9 +22,13 @@ compiled-generic-crossref [ H{ } clone ] initialize
|
|||
: conditional-dependencies-of ( word -- assoc )
|
||||
effect-dependencies-of [ nip conditional-dependency dependency>= ] assoc-filter ;
|
||||
|
||||
: compiled-usages ( assoc -- assocs )
|
||||
: outdated-definition-usages ( assoc -- assocs )
|
||||
[ drop word? ] assoc-filter
|
||||
[ [ drop definition-dependencies-of ] { } assoc>map ] keep suffix ;
|
||||
[ drop definition-dependencies-of ] { } assoc>map ;
|
||||
|
||||
: outdated-effect-usages ( assoc -- assocs )
|
||||
[ drop word? ] assoc-filter
|
||||
[ drop effect-dependencies-of ] { } assoc>map ;
|
||||
|
||||
: dependencies-satisfied? ( word cache -- ? )
|
||||
[ "dependency-checks" word-prop ] dip
|
||||
|
|
@ -37,14 +41,14 @@ compiled-generic-crossref [ H{ } clone ] initialize
|
|||
[ drop _ dependencies-satisfied? not ] assoc-filter
|
||||
] { } assoc>map ;
|
||||
|
||||
: compiled-generic-usage ( word -- assoc )
|
||||
compiled-generic-crossref get at ;
|
||||
: generic-call-sites-of ( word -- assoc )
|
||||
generic-call-site-crossref get at ;
|
||||
|
||||
: only-xref ( assoc -- assoc' )
|
||||
[ drop crossref? ] { } assoc-filter-as ;
|
||||
|
||||
: set-compiled-generic-uses ( word alist -- )
|
||||
concat f like "compiled-generic-uses" set-word-prop ;
|
||||
: set-generic-call-sites ( word alist -- )
|
||||
concat f like "generic-call-sites" set-word-prop ;
|
||||
|
||||
: split-dependencies ( assoc -- effect-deps cond-deps def-deps )
|
||||
[ nip effect-dependency eq? ] assoc-partition
|
||||
|
|
@ -59,12 +63,12 @@ compiled-generic-crossref [ H{ } clone ] initialize
|
|||
[ (store-dependencies) ] tri-curry@ tri-curry* tri ;
|
||||
|
||||
: (compiled-xref) ( word dependencies generic-dependencies -- )
|
||||
compiled-crossref compiled-generic-crossref
|
||||
compiled-crossref generic-call-site-crossref
|
||||
[ get add-vertex* ] bi-curry@ bi-curry* bi ;
|
||||
|
||||
: compiled-xref ( word dependencies generic-dependencies -- )
|
||||
[ only-xref ] bi@
|
||||
[ nip set-compiled-generic-uses ]
|
||||
[ nip set-generic-call-sites ]
|
||||
[ drop store-dependencies ]
|
||||
[ (compiled-xref) ]
|
||||
3tri ;
|
||||
|
|
@ -88,23 +92,23 @@ compiled-generic-crossref [ H{ } clone ] initialize
|
|||
: (compiled-unxref) ( word dependencies variable -- )
|
||||
get remove-vertex* ;
|
||||
|
||||
: compiled-generic-uses ( word -- alist )
|
||||
"compiled-generic-uses" word-prop 2 <groups> ;
|
||||
: generic-call-sites ( word -- alist )
|
||||
"generic-call-sites" word-prop 2 <groups> ;
|
||||
|
||||
: compiled-unxref ( word -- )
|
||||
{
|
||||
[ dup load-dependencies compiled-crossref (compiled-unxref) ]
|
||||
[ dup compiled-generic-uses compiled-generic-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 ]
|
||||
[ "compiled-generic-uses" 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 -- )
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ sequences vocabs words tools.test tools.test.private ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -556,6 +556,9 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline
|
|||
|
||||
[ ] [ 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
|
||||
|
|
@ -585,6 +588,8 @@ FUNCTION: short ffi_test_48 ( bool-field-test x ) ;
|
|||
ffi_test_48
|
||||
] unit-test
|
||||
|
||||
] unless
|
||||
|
||||
! Regression: calling an undefined function would raise a protection fault
|
||||
FUNCTION: void this_does_not_exist ( ) ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,8 +8,8 @@ IN: compiler.tests.low-level-ir
|
|||
|
||||
: 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
|
||||
|
|
|
|||
|
|
@ -77,8 +77,8 @@ M: integer test-7 + ;
|
|||
! 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
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ IN: compiler.tests.redefine13
|
|||
|
||||
: breakage-word ( a b -- c ) + ;
|
||||
|
||||
MACRO: breakage-macro ( a -- ) '[ _ breakage-word ] ;
|
||||
<< MACRO: breakage-macro ( a -- ) '[ _ breakage-word ] ; >>
|
||||
|
||||
GENERIC: breakage-caller ( a -- c )
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1,10 @@
|
|||
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
|
||||
|
|
@ -5,7 +5,7 @@ IN: compiler.tests.stack-trace
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -162,7 +162,7 @@ SYMBOL: node-count
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors sequences classes.tuple
|
||||
classes.tuple.private arrays math math.private slots.private
|
||||
|
|
@ -50,7 +50,10 @@ DEFER: record-literal-allocation
|
|||
if* ;
|
||||
|
||||
M: #push escape-analysis*
|
||||
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
|
||||
dup literal>> layout-up-to-date?
|
||||
[ [ out-d>> first ] [ literal>> ] bi record-literal-allocation ]
|
||||
[ out-d>> unknown-allocations ]
|
||||
if ;
|
||||
|
||||
: record-unknown-allocation ( #call -- )
|
||||
[ in-d>> add-escaping-values ]
|
||||
|
|
|
|||
|
|
@ -78,7 +78,7 @@ TUPLE: a-tuple x ;
|
|||
|
||||
[ ] [ "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 ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
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
|
||||
|
|
@ -63,7 +63,11 @@ M: compose cached-effect
|
|||
[ first>> ] [ second>> ] bi [ cached-effect ] bi@ compose-effects* ;
|
||||
|
||||
: safe-infer ( quot -- effect )
|
||||
[ [ infer ] [ 2drop +unknown+ ] recover ] without-dependencies ;
|
||||
! 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
|
||||
|
|
@ -81,17 +85,9 @@ M: quotation cached-effect
|
|||
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 ;
|
||||
|
||||
|
|
@ -118,7 +114,10 @@ M: quotation cached-effect
|
|||
[ '[ _ 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?
|
||||
|
|
|
|||
|
|
@ -79,14 +79,6 @@ M: callable splicing-nodes splicing-body ;
|
|||
: inline-math-method ( #call word -- ? )
|
||||
dupd inlining-math-method eliminate-dispatch ;
|
||||
|
||||
: inlining-math-partial ( #call word -- class/f quot/f )
|
||||
[ "derived-from" word-prop first inlining-math-method ]
|
||||
[ nip 1quotation ] 2bi
|
||||
[ = not ] [ drop ] 2bi and ;
|
||||
|
||||
: inline-math-partial ( #call word -- ? )
|
||||
dupd inlining-math-partial eliminate-dispatch ;
|
||||
|
||||
! Method body inlining
|
||||
SYMBOL: history
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: fry assocs arrays byte-arrays strings accessors sequences
|
||||
kernel slots classes.algebra classes.tuple classes.tuple.private
|
||||
words math math.private combinators sequences.private namespaces
|
||||
slots.private classes compiler.tree.propagation.info ;
|
||||
combinators.short-circuit words math math.private combinators
|
||||
sequences.private namespaces slots.private classes
|
||||
compiler.tree.propagation.info ;
|
||||
IN: compiler.tree.propagation.slots
|
||||
|
||||
! Propagation of immutable slots and array lengths
|
||||
|
|
@ -52,8 +53,18 @@ UNION: fixed-length-sequence array byte-array string ;
|
|||
dup [ read-only>> ] when ;
|
||||
|
||||
: literal-info-slot ( slot object -- info/f )
|
||||
2dup class read-only-slot?
|
||||
[ swap slot <literal-info> ] [ 2drop f ] if ;
|
||||
#! literal-info-slot makes an unsafe call to 'slot'.
|
||||
#! Check that the layout is up to date to avoid accessing the
|
||||
#! wrong slot during a compilation unit where reshaping took
|
||||
#! place. This could happen otherwise because the "slots" word
|
||||
#! property would reflect the new layout, but instances in the
|
||||
#! heap would use the old layout since instances are updated
|
||||
#! immediately after compilation.
|
||||
{
|
||||
[ class read-only-slot? ]
|
||||
[ nip layout-up-to-date? ]
|
||||
[ swap slot <literal-info> ]
|
||||
} 2&& ;
|
||||
|
||||
: length-accessor? ( slot info -- ? )
|
||||
[ 1 = ] [ length>> ] bi* and ;
|
||||
|
|
|
|||
|
|
@ -26,9 +26,11 @@ TUPLE: gif-lzw < lzw ;
|
|||
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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,11 @@
|
|||
IN: core-foundation.arrays.tests
|
||||
USING: core-foundation core-foundation.arrays
|
||||
core-foundation.strings destructors sequences tools.test ;
|
||||
|
||||
[ { "1" "2" "3" } ] [
|
||||
[
|
||||
{ "1" "2" "3" }
|
||||
[ <CFString> &CFRelease ] map
|
||||
<CFArray> CF>string-array
|
||||
] with-destructors
|
||||
] unit-test
|
||||
|
|
@ -15,7 +15,8 @@ FUNCTION: void CFArraySetValueAtIndex ( CFArrayRef array, CFIndex index, void* v
|
|||
FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
|
||||
|
||||
: CF>array ( alien -- array )
|
||||
dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
|
||||
dup CFArrayGetCount
|
||||
[ CFArrayGetValueAtIndex ] with { } map-integers ;
|
||||
|
||||
: <CFArray> ( seq -- alien )
|
||||
f over length &: kCFTypeArrayCallBacks CFArrayCreateMutable
|
||||
|
|
|
|||
|
|
@ -169,6 +169,19 @@ M: uint-scalar-rep rep-size drop 4 ;
|
|||
M: longlong-scalar-rep rep-size drop 8 ;
|
||||
M: ulonglong-scalar-rep rep-size drop 8 ;
|
||||
|
||||
GENERIC: rep-length ( rep -- n ) foldable
|
||||
|
||||
M: char-16-rep rep-length drop 16 ;
|
||||
M: uchar-16-rep rep-length drop 16 ;
|
||||
M: short-8-rep rep-length drop 8 ;
|
||||
M: ushort-8-rep rep-length drop 8 ;
|
||||
M: int-4-rep rep-length drop 4 ;
|
||||
M: uint-4-rep rep-length drop 4 ;
|
||||
M: longlong-2-rep rep-length drop 2 ;
|
||||
M: ulonglong-2-rep rep-length drop 2 ;
|
||||
M: float-4-rep rep-length drop 4 ;
|
||||
M: double-2-rep rep-length drop 2 ;
|
||||
|
||||
GENERIC: rep-component-type ( rep -- n )
|
||||
|
||||
! Methods defined in alien.c-types
|
||||
|
|
@ -434,6 +447,7 @@ HOOK: %set-alien-double cpu ( ptr offset value -- )
|
|||
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 -- )
|
||||
|
|
|
|||
|
|
@ -97,11 +97,11 @@ CONSTANT: ctx-reg 16
|
|||
rs-reg ctx-reg context-retainstack-offset LWZ ;
|
||||
|
||||
[
|
||||
0 3 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
|
||||
11 3 profile-count-offset LWZ
|
||||
0 12 LOAD32 rc-absolute-ppc-2/2 rt-literal jit-rel
|
||||
11 12 profile-count-offset LWZ
|
||||
11 11 1 tag-fixnum ADDI
|
||||
11 3 profile-count-offset STW
|
||||
11 3 word-code-offset LWZ
|
||||
11 12 profile-count-offset STW
|
||||
11 12 word-code-offset LWZ
|
||||
11 11 compiled-header-size ADDI
|
||||
11 MTCTR
|
||||
BCTR
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! 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
|
||||
|
|
@ -57,10 +57,11 @@ CONSTANT: vm-reg 15
|
|||
|
||||
: %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 )
|
||||
|
||||
|
|
@ -383,7 +384,7 @@ M: ppc %set-alien-float -rot STFS ;
|
|||
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 ;
|
||||
|
|
@ -601,26 +602,19 @@ M: ppc %push-stack ( -- )
|
|||
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
|
||||
|
|
@ -682,19 +676,17 @@ M: ppc %box-large-struct ( n c-type -- )
|
|||
"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 ;
|
||||
|
|
|
|||
|
|
@ -27,6 +27,9 @@ M: x86.32 temp-reg ECX ;
|
|||
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 ;
|
||||
|
||||
|
|
@ -102,6 +105,9 @@ M: x86.32 %prologue ( n -- )
|
|||
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
|
||||
|
|
@ -160,10 +166,10 @@ M: x86.32 %pop-stack ( n -- )
|
|||
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
|
||||
|
|
@ -287,6 +293,15 @@ M:: x86.32 %binary-float-function ( dst src1 src2 func -- )
|
|||
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
|
||||
|
|
@ -294,13 +309,8 @@ M: x86.32 %cleanup ( params -- )
|
|||
#! 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 ;
|
||||
|
||||
|
|
@ -323,11 +333,8 @@ M: x86.32 callback-return-rewind ( params -- n )
|
|||
#! 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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -36,6 +36,11 @@ IN: bootstrap.x86
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -42,17 +42,23 @@ M: x86.64 machine-registers
|
|||
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 ;
|
||||
|
||||
|
|
@ -104,10 +110,10 @@ M: x86.64 %pop-stack ( n -- )
|
|||
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
|
||||
|
|
|
|||
|
|
@ -37,6 +37,11 @@ IN: bootstrap.x86
|
|||
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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -56,15 +56,15 @@ big-endian off
|
|||
|
||||
[
|
||||
! 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
|
||||
|
||||
[
|
||||
|
|
@ -76,11 +76,6 @@ big-endian off
|
|||
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
|
||||
|
|
|
|||
|
|
@ -88,8 +88,10 @@ M: x86 %call ( word -- ) 0 CALL rc-relative rel-word-pic ;
|
|||
#! 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 ;
|
||||
|
|
@ -474,17 +476,10 @@ M: x86 %push-stack ( -- )
|
|||
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 ;
|
||||
|
|
@ -1409,8 +1404,7 @@ M: x86 %loop-entry 16 code-alignment [ NOP ] times ;
|
|||
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
|
||||
|
|
@ -1420,8 +1414,7 @@ M:: x86 %save-context ( temp1 temp2 -- )
|
|||
#! 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
|
||||
|
|
|
|||
|
|
@ -4,36 +4,36 @@ USING: accessors kernel continuations fry words ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -34,7 +34,7 @@ PostgresqlSqlError = (TableError | FunctionError | SyntaxError | UnknownError)
|
|||
;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
|
||||
|
|
|
|||
|
|
@ -11,17 +11,12 @@ IN: db.sqlite.lib
|
|||
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 -- )
|
||||
{
|
||||
|
|
|
|||
|
|
@ -50,7 +50,7 @@ M: string error. print ;
|
|||
|
||||
: restart. ( restart n -- )
|
||||
[
|
||||
1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
|
||||
1 + dup 3 <= [ ":" % # " " % ] [ # " :res " % ] if
|
||||
name>> %
|
||||
] "" make print ;
|
||||
|
||||
|
|
@ -236,7 +236,10 @@ M: redefine-error error.
|
|||
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
|
||||
|
|
@ -336,7 +339,7 @@ M: check-mixin-class summary drop "Not a mixin class" ;
|
|||
|
||||
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 “--”" ;
|
||||
|
||||
|
|
|
|||
|
|
@ -39,7 +39,7 @@ TUPLE: consultation group class quot loc ;
|
|||
[ 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 ;
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ ARTICLE: "eval-vocabs" "Evaluating strings with a different vocabulary search pa
|
|||
(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
|
||||
}
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ C: <ftp-disconnect> ftp-disconnect
|
|||
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&& ;
|
||||
|
|
@ -343,7 +343,7 @@ M: ftp-server handle-client* ( server -- )
|
|||
: <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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ M: array (fake-quotations>)
|
|||
[ [ (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>) , ;
|
||||
|
||||
|
|
@ -74,7 +74,7 @@ FUNCTOR-SYNTAX: MIXIN:
|
|||
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! ;
|
||||
|
||||
|
|
|
|||
|
|
@ -28,10 +28,10 @@ TUPLE: action rest init authorize display validate submit ;
|
|||
action new-action ;
|
||||
|
||||
: merge-forms ( form -- )
|
||||
form get
|
||||
[ [ errors>> ] bi@ push-all ]
|
||||
[ [ values>> ] bi@ swap update ]
|
||||
[ swap validation-failed>> >>validation-failed drop ]
|
||||
[ form get ] dip
|
||||
[ [ errors>> ] bi@ append! drop ]
|
||||
[ [ values>> ] bi@ assoc-union! drop ]
|
||||
[ validation-failed>> >>validation-failed drop ]
|
||||
2tri ;
|
||||
|
||||
: set-nested-form ( form name -- )
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: namespaces assocs kernel sequences accessors hashtables
|
||||
urls db.types db.tuples math.parser fry logging combinators
|
||||
|
|
@ -51,7 +51,7 @@ SYMBOL: aside-id
|
|||
set-aside ;
|
||||
|
||||
M: asides call-responder*
|
||||
[ init-asides ] [ asides set ] [ call-next-method ] tri ;
|
||||
[ init-asides ] [ call-next-method ] bi ;
|
||||
|
||||
: touch-aside ( aside -- )
|
||||
asides get touch-state ;
|
||||
|
|
@ -65,14 +65,13 @@ M: asides call-responder*
|
|||
[ touch-aside ] [ insert-tuple ] [ set-aside ] tri ;
|
||||
|
||||
: end-aside-post ( aside -- response )
|
||||
[ url>> ] [ post-data>> ] bi
|
||||
request [
|
||||
clone
|
||||
swap >>post-data
|
||||
over >>url
|
||||
over post-data>> >>post-data
|
||||
over url>> >>url
|
||||
] change
|
||||
[ url set ] [ path>> split-path ] bi
|
||||
asides get responder>> call-responder ;
|
||||
[ [ post-data>> params>> params set ] [ url>> url set ] bi ]
|
||||
[ url>> path>> split-path asides get responder>> call-responder ] bi ;
|
||||
|
||||
\ end-aside-post DEBUG add-input-logging
|
||||
|
||||
|
|
|
|||
|
|
@ -136,7 +136,7 @@ CHLOE: form
|
|||
XML> body>> clone ;
|
||||
|
||||
: add-tag-attrs ( attrs tag -- )
|
||||
attrs>> swap update ;
|
||||
attrs>> swap assoc-union! drop ;
|
||||
|
||||
CHLOE: button
|
||||
button-tag-markup
|
||||
|
|
|
|||
|
|
@ -113,3 +113,12 @@ IN: generalizations.tests
|
|||
|
||||
[ { 1 2 3 } { 4 5 6 } ]
|
||||
[ 1 2 3 4 5 6 [ 3array ] 3 2 mnapply ] unit-test
|
||||
|
||||
[ { 1 2 3 } { 4 5 6 } ]
|
||||
[ 1 2 3 4 5 6 [ 3array ] [ 3array ] 3 2 nspread* ] unit-test
|
||||
|
||||
[ ]
|
||||
[ [ 2array ] 2 0 mnapply ] unit-test
|
||||
|
||||
[ ]
|
||||
[ 2 0 nspread* ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
! 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
|
||||
|
||||
<<
|
||||
|
|
@ -100,10 +100,20 @@ MACRO: nspread ( quots n -- )
|
|||
|
||||
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 ]
|
||||
|
|
@ -112,6 +122,9 @@ MACRO: cleave* ( n -- )
|
|||
: 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
|
||||
|
||||
|
|
@ -124,10 +137,6 @@ MACRO: cleave* ( n -- )
|
|||
MACRO: mnswap ( m n -- )
|
||||
1 + '[ _ -nrot ] swap '[ _ _ napply ] ;
|
||||
|
||||
MACRO: mnapply ( quot m n -- )
|
||||
swap
|
||||
[ swap '[ _ ] replicate ] dip '[ _ _ nspread ] ;
|
||||
|
||||
MACRO: nweave ( n -- )
|
||||
[ dup iota <reversed> [ '[ _ _ mnswap ] ] with map ] keep
|
||||
'[ _ _ ncleave ] ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2008, 2009 Slava Pestov.
|
||||
! Copyright (C) 2008, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs fry help.markup help.topics io
|
||||
kernel make math math.parser namespaces sequences sorting
|
||||
|
|
@ -19,6 +19,8 @@ TUPLE: more-completions seq ;
|
|||
|
||||
CONSTANT: max-completions 5
|
||||
|
||||
M: more-completions valid-article? drop t ;
|
||||
|
||||
M: more-completions article-title
|
||||
seq>> length number>string " results" append ;
|
||||
|
||||
|
|
@ -60,6 +62,8 @@ TUPLE: apropos search ;
|
|||
|
||||
C: <apropos> apropos
|
||||
|
||||
M: apropos valid-article? drop t ;
|
||||
|
||||
M: apropos article-title
|
||||
search>> "Search results for “" "”" surround ;
|
||||
|
||||
|
|
|
|||
|
|
@ -51,6 +51,7 @@ $nl
|
|||
{ $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 } } }
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! Copyright (C) 2005, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays io io.styles kernel namespaces make
|
||||
parser prettyprint sequences words words.symbol assocs
|
||||
|
|
@ -48,6 +48,8 @@ M: predicate word-help* drop \ $predicate ;
|
|||
: all-errors ( -- seq )
|
||||
all-words [ error? ] filter sort-articles ;
|
||||
|
||||
M: word valid-article? drop t ;
|
||||
|
||||
M: word article-name name>> ;
|
||||
|
||||
M: word article-title
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! Copyright (C) 2009, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays compiler.units fry hashtables help.topics io
|
||||
kernel math namespaces sequences sets help.vocabs
|
||||
|
|
@ -21,7 +21,8 @@ M: apropos add-recent-where recent-searches ;
|
|||
M: object add-recent-where f ;
|
||||
|
||||
: $recent ( element -- )
|
||||
first get reverse [ nl ] [ 1array $pretty-link ] interleave ;
|
||||
first get [ valid-article? ] filter <reversed>
|
||||
[ nl ] [ 1array $pretty-link ] interleave ;
|
||||
|
||||
: $recent-searches ( element -- )
|
||||
drop recent-searches get [ <$link> ] map $list ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.x
|
||||
USING: accessors arrays definitions generic assocs
|
||||
io kernel namespaces make prettyprint prettyprint.sections
|
||||
|
|
@ -38,6 +38,7 @@ SYMBOL: article-xref
|
|||
|
||||
article-xref [ H{ } clone ] initialize
|
||||
|
||||
GENERIC: valid-article? ( topic -- ? )
|
||||
GENERIC: article-name ( topic -- string )
|
||||
GENERIC: article-title ( topic -- string )
|
||||
GENERIC: article-content ( topic -- content )
|
||||
|
|
@ -49,6 +50,7 @@ TUPLE: article title content loc ;
|
|||
: <article> ( title content -- article )
|
||||
f \ article boa ;
|
||||
|
||||
M: article valid-article? drop t ;
|
||||
M: article article-name title>> ;
|
||||
M: article article-title title>> ;
|
||||
M: article article-content content>> ;
|
||||
|
|
@ -61,12 +63,14 @@ M: no-article summary
|
|||
: article ( name -- article )
|
||||
articles get ?at [ no-article ] unless ;
|
||||
|
||||
M: object valid-article? articles get key? ;
|
||||
M: object article-name article article-name ;
|
||||
M: object article-title article article-title ;
|
||||
M: object article-content article article-content ;
|
||||
M: object article-parent article-xref get at ;
|
||||
M: object set-article-parent article-xref get set-at ;
|
||||
|
||||
M: link valid-article? name>> valid-article? ;
|
||||
M: link article-name name>> article-name ;
|
||||
M: link article-title name>> article-title ;
|
||||
M: link article-content name>> article-content ;
|
||||
|
|
@ -74,6 +78,7 @@ M: link article-parent name>> article-parent ;
|
|||
M: link set-article-parent name>> set-article-parent ;
|
||||
|
||||
! Special case: f help
|
||||
M: f valid-article? drop t ;
|
||||
M: f article-name drop \ f article-name ;
|
||||
M: f article-title drop \ f article-title ;
|
||||
M: f article-content drop \ f article-content ;
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! Copyright (C) 2007, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays assocs classes classes.builtin
|
||||
classes.intersection classes.mixin classes.predicate
|
||||
|
|
@ -278,6 +278,8 @@ INSTANCE: vocab topic
|
|||
|
||||
INSTANCE: vocab-link topic
|
||||
|
||||
M: vocab-spec valid-article? drop t ;
|
||||
|
||||
M: vocab-spec article-title vocab-name " vocabulary" append ;
|
||||
|
||||
M: vocab-spec article-name vocab-name ;
|
||||
|
|
@ -289,6 +291,8 @@ M: vocab-spec article-parent drop "vocab-index" ;
|
|||
|
||||
M: vocab-tag >link ;
|
||||
|
||||
M: vocab-tag valid-article? drop t ;
|
||||
|
||||
M: vocab-tag article-title
|
||||
name>> "Vocabularies tagged “" "”" surround ;
|
||||
|
||||
|
|
@ -303,6 +307,8 @@ M: vocab-tag summary article-title ;
|
|||
|
||||
M: vocab-author >link ;
|
||||
|
||||
M: vocab-author valid-article? drop t ;
|
||||
|
||||
M: vocab-author article-title
|
||||
name>> "Vocabularies by " prepend ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
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
|
||||
|
|
@ -52,7 +52,7 @@ M: object specializer-declaration class ;
|
|||
specializer [ specialize-quot ] when* ;
|
||||
|
||||
: standard-method? ( method -- ? )
|
||||
dup method-body? [
|
||||
dup method? [
|
||||
"method-generic" word-prop standard-generic?
|
||||
] [ drop f ] if ;
|
||||
|
||||
|
|
@ -130,10 +130,4 @@ M\ hashtable at* { { fixnum object } { word object } } "specializer" set-word-pr
|
|||
|
||||
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
|
||||
|
|
|
|||
|
|
@ -35,10 +35,10 @@ M: form clone
|
|||
[ [ 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 '[
|
||||
|
|
|
|||
|
|
@ -238,7 +238,7 @@ ERROR: bad-tga-unsupported ;
|
|||
] unless
|
||||
] ignore-errors
|
||||
|
||||
#! Only 24-bit uncompressed RGB and 32-bit uncompressed ARGB are supported.
|
||||
#! 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
|
||||
|
|
@ -247,7 +247,7 @@ ERROR: bad-tga-unsupported ;
|
|||
|
||||
#! Create image instance
|
||||
image new
|
||||
alpha-bits 0 = [ RGB ] [ ARGB ] if >>component-order
|
||||
alpha-bits 0 = [ BGR ] [ BGRA ] if >>component-order
|
||||
{ image-width image-height } >>dim
|
||||
pixel-order 0 = >>upside-down?
|
||||
image-data >>bitmap
|
||||
|
|
@ -259,7 +259,7 @@ M: tga-image stream>image
|
|||
M: tga-image image>stream
|
||||
drop
|
||||
[
|
||||
component-order>> { RGB ARGB } member? [ bad-tga-unsupported ] unless
|
||||
component-order>> { BGRA BGRA } member? [ bad-tga-unsupported ] unless
|
||||
] keep
|
||||
|
||||
B{ 0 } write #! id-length
|
||||
|
|
@ -272,15 +272,15 @@ M: tga-image image>stream
|
|||
[ dim>> second 2 >le write ]
|
||||
[ component-order>>
|
||||
{
|
||||
{ RGB [ B{ 24 } write ] }
|
||||
{ ARGB [ B{ 32 } write ] }
|
||||
{ BGR [ B{ 24 } write ] }
|
||||
{ BGRA [ B{ 32 } write ] }
|
||||
} case
|
||||
]
|
||||
[
|
||||
dup component-order>>
|
||||
{
|
||||
{ RGB [ 0 ] }
|
||||
{ ARGB [ 8 ] }
|
||||
{ BGR [ 0 ] }
|
||||
{ BGRA [ 8 ] }
|
||||
} case swap
|
||||
upside-down?>> [ 0 ] [ 2 ] if 3 shift bitor
|
||||
1 >le write
|
||||
|
|
|
|||
|
|
@ -142,11 +142,6 @@ ARTICLE: "io.directories.create" "Creating directories"
|
|||
} ;
|
||||
|
||||
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." }
|
||||
|
|
@ -175,7 +170,7 @@ $nl
|
|||
"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"
|
||||
|
|
|
|||
|
|
@ -26,6 +26,11 @@ HELP: copy-trees-into
|
|||
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:"
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@ USING: io.files io.files.temp io.directories io.pathnames
|
|||
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
|
||||
|
|
@ -134,7 +134,7 @@ concurrency.promises threads unix.process calendar ;
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -91,7 +91,7 @@ M: unix kill-process* ( pid -- )
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! 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
|
||||
|
|
@ -6,7 +6,8 @@ io.ports windows.types math windows.kernel32 namespaces make
|
|||
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
|
||||
|
|
@ -127,15 +128,25 @@ M: wince fill-redirection 2drop ;
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -204,7 +204,7 @@ HELP: foreground
|
|||
{ $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"
|
||||
|
|
@ -215,9 +215,9 @@ HELP: background
|
|||
{ $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"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -1,7 +1,15 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -1,18 +1,13 @@
|
|||
! 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
|
||||
|
||||
|
|
|
|||
|
|
@ -9,8 +9,14 @@ IN: libc
|
|||
: 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
|
||||
|
||||
|
|
|
|||
|
|
@ -48,7 +48,7 @@ SYMBOL: error-hook
|
|||
|
||||
: call-error-hook ( error -- )
|
||||
error-continuation get error-hook get
|
||||
call( error continuation -- ) ;
|
||||
call( continuation error -- ) ;
|
||||
|
||||
[ drop print-error-and-restarts ] error-hook set-global
|
||||
|
||||
|
|
@ -131,7 +131,6 @@ SYMBOL: interactive-vocabs
|
|||
"arrays"
|
||||
"assocs"
|
||||
"combinators"
|
||||
"compiler"
|
||||
"compiler.errors"
|
||||
"compiler.units"
|
||||
"continuations"
|
||||
|
|
@ -173,6 +172,7 @@ SYMBOL: interactive-vocabs
|
|||
"tools.test"
|
||||
"tools.threads"
|
||||
"tools.time"
|
||||
"tools.walker"
|
||||
"vocabs"
|
||||
"vocabs.loader"
|
||||
"vocabs.refresh"
|
||||
|
|
|
|||
|
|
@ -24,7 +24,7 @@ M: lambda-macro definition
|
|||
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:: \ ; ;
|
||||
|
||||
|
|
|
|||
|
|
@ -14,9 +14,9 @@ HELP: [let
|
|||
|
||||
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
|
||||
|
|
@ -112,7 +112,7 @@ $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
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
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 ) + ;
|
||||
|
||||
|
|
@ -19,7 +20,21 @@ unit-test
|
|||
|
||||
[ 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
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! 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
|
||||
|
||||
|
|
@ -14,7 +14,11 @@ PRIVATE>
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2004, 2010 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel math.constants math.private math.bits
|
||||
math.libm combinators math.order sequences ;
|
||||
math.libm combinators fry math.order sequences ;
|
||||
IN: math.functions
|
||||
|
||||
: >fraction ( a/b -- a b )
|
||||
|
|
@ -13,12 +13,13 @@ IN: math.functions
|
|||
GENERIC: sqrt ( x -- y ) foldable
|
||||
|
||||
M: real sqrt
|
||||
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ; inline
|
||||
>float dup 0.0 <
|
||||
[ neg fsqrt [ 0.0 ] dip rect> ] [ fsqrt ] if ; inline
|
||||
|
||||
: factor-2s ( n -- r s )
|
||||
#! factor an integer into 2^r * s
|
||||
dup 0 = [ 1 ] [
|
||||
0 swap [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
|
||||
[ 0 ] dip [ dup even? ] [ [ 1 + ] [ 2/ ] bi* ] while
|
||||
] if ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -26,13 +27,13 @@ M: real sqrt
|
|||
GENERIC# ^n 1 ( z w -- z^w ) foldable
|
||||
|
||||
: (^n) ( z w -- z^w )
|
||||
make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
|
||||
make-bits 1 [ [ over * ] when [ sq ] dip ] reduce nip ; inline
|
||||
|
||||
M: integer ^n
|
||||
[ factor-2s ] dip [ (^n) ] keep rot * shift ;
|
||||
|
||||
M: ratio ^n
|
||||
[ >fraction ] dip [ ^n ] curry bi@ / ;
|
||||
[ >fraction ] dip '[ _ ^n ] bi@ / ;
|
||||
|
||||
M: float ^n (^n) ;
|
||||
|
||||
|
|
@ -62,7 +63,7 @@ M: float exp fexp ; inline
|
|||
|
||||
M: real exp >float exp ; inline
|
||||
|
||||
M: complex exp >rect swap exp swap polar> ; inline
|
||||
M: complex exp >rect [ exp ] dip polar> ; inline
|
||||
|
||||
<PRIVATE
|
||||
|
||||
|
|
@ -84,10 +85,9 @@ M: complex exp >rect swap exp swap polar> ; inline
|
|||
: 0^ ( x -- z )
|
||||
[ 0/0. ] [ 0 < 1/0. 0 ? ] if-zero ; inline
|
||||
|
||||
: (^mod) ( n x y -- z )
|
||||
make-bits 1 [
|
||||
[ dupd * pick mod ] when [ sq over mod ] dip
|
||||
] reduce 2nip ; inline
|
||||
: (^mod) ( x y n -- z )
|
||||
[ make-bits 1 ] dip dup
|
||||
'[ [ over * _ mod ] when [ sq _ mod ] dip ] reduce nip ; inline
|
||||
|
||||
: (gcd) ( b a x y -- a d )
|
||||
over zero? [
|
||||
|
|
@ -125,11 +125,8 @@ ERROR: non-trivial-divisor n ;
|
|||
[ non-trivial-divisor ] if ; foldable
|
||||
|
||||
: ^mod ( x y n -- z )
|
||||
over 0 < [
|
||||
[ [ neg ] dip ^mod ] keep mod-inv
|
||||
] [
|
||||
-rot (^mod)
|
||||
] if ; foldable
|
||||
over 0 <
|
||||
[ [ [ neg ] dip ^mod ] keep mod-inv ] [ (^mod) ] if ; foldable
|
||||
|
||||
GENERIC: absq ( x -- y ) foldable
|
||||
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ ARTICLE: "polynomials" "Polynomials"
|
|||
p-
|
||||
p*
|
||||
p-sq
|
||||
p^
|
||||
powers
|
||||
n*p
|
||||
p/mod
|
||||
|
|
@ -74,6 +75,11 @@ HELP: p-sq
|
|||
{ $description "Squares a polynomial." }
|
||||
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 0 } p-sq ." "{ 1 4 4 0 0 }" } } ;
|
||||
|
||||
HELP: p^
|
||||
{ $values { "p" "a polynomial" } { "n" number } { "p^n" "a polynomial" } }
|
||||
{ $description "Computes " { $snippet "p" } " to the power of " { $snippet "n" } "." }
|
||||
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 2 0 } 3 p^ ." "{ 1 6 12 8 0 0 0 }" } } ;
|
||||
|
||||
HELP: p/mod
|
||||
{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } }
|
||||
{ $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." }
|
||||
|
|
|
|||
|
|
@ -15,6 +15,9 @@ IN: math.polynomials.tests
|
|||
[ { 0 0 0 } ] [ { 0 0 0 } { 0 0 0 } p- ] unit-test
|
||||
[ { 0 0 0 } ] [ 4 { 0 0 0 } n*p ] unit-test
|
||||
[ { 4 8 0 12 } ] [ 4 { 1 2 0 3 } n*p ] unit-test
|
||||
[ { 1 4 4 0 0 } ] [ { 1 2 0 } p-sq ] unit-test
|
||||
[ { 1 6 12 8 0 0 0 } ] [ { 1 2 0 } 3 p^ ] unit-test
|
||||
[ { 1 } ] [ { 1 2 0 } 0 p^ ] unit-test
|
||||
[ { 1 4 7 6 0 0 0 0 0 } ] [ { 1 2 3 0 0 0 } { 1 2 0 0 } p* ] unit-test
|
||||
[ V{ 7 -2 1 } V{ -20 0 0 } ] [ { 1 1 1 1 } { 3 1 } p/mod ] unit-test
|
||||
[ V{ 0 0 } V{ 1 1 } ] [ { 1 1 } { 1 1 1 1 } p/mod ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel make math math.order math.vectors sequences
|
||||
splitting vectors macros combinators ;
|
||||
splitting vectors macros combinators math.bits ;
|
||||
IN: math.polynomials
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -38,6 +38,16 @@ PRIVATE>
|
|||
: p-sq ( p -- p^2 )
|
||||
dup p* ;
|
||||
|
||||
ERROR: negative-power-polynomial p n ;
|
||||
|
||||
: (p^) ( p n -- p^n )
|
||||
make-bits { 1 } [ [ over p* ] when [ p-sq ] dip ] reduce nip ;
|
||||
|
||||
: p^ ( p n -- p^n )
|
||||
dup 0 >=
|
||||
[ (p^) ]
|
||||
[ negative-power-polynomial ] if ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: p/mod-setup ( p p -- p p n )
|
||||
|
|
|
|||
|
|
@ -4,17 +4,17 @@ IN: math.quaternions
|
|||
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" } }
|
||||
|
|
@ -27,28 +27,17 @@ HELP: qrecip
|
|||
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" } }
|
||||
|
|
|
|||
|
|
@ -2,6 +2,12 @@ IN: math.quaternions.tests
|
|||
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
|
||||
|
|
@ -10,18 +16,13 @@ math.constants ;
|
|||
[ 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
|
||||
|
|
|
|||
|
|
@ -1,72 +1,76 @@
|
|||
! 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
|
||||
|
||||
: n*q ( q n -- q )
|
||||
v*n ; inline
|
||||
|
||||
: q*n ( q n -- q )
|
||||
conjugate v*n ;
|
||||
v*n ; inline
|
||||
|
||||
: n>q ( n -- q )
|
||||
0 0 0 4array ; inline
|
||||
|
||||
: n>q-like ( c exemplar -- q )
|
||||
[ 0 0 0 ] dip 4sequence ; inline
|
||||
|
||||
: c>q ( c -- q )
|
||||
0 2array ;
|
||||
>rect 0 0 4array ; inline
|
||||
|
||||
: v>q ( v -- q )
|
||||
first3 rect> [ 0 swap rect> ] dip 2array ;
|
||||
|
||||
: q>v ( q -- v )
|
||||
first2 [ imaginary-part ] dip >rect 3array ;
|
||||
|
||||
! Zero
|
||||
CONSTANT: q0 { 0 0 }
|
||||
|
||||
! 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
|
||||
|
|
|
|||
|
|
@ -45,3 +45,5 @@ PRIVATE>
|
|||
: [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
|
||||
|
|
|
|||
|
|
@ -95,13 +95,14 @@ unit-test
|
|||
[ "-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
|
||||
|
|
|
|||
|
|
@ -84,7 +84,7 @@ HELP: histogram
|
|||
}
|
||||
{ $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 }
|
||||
|
|
@ -92,7 +92,7 @@ HELP: histogram*
|
|||
{ $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 } }"
|
||||
}
|
||||
}
|
||||
|
|
@ -125,7 +125,7 @@ HELP: sequence>assoc
|
|||
}
|
||||
{ $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 }
|
||||
|
|
@ -133,7 +133,7 @@ HELP: sequence>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 } }"
|
||||
}
|
||||
}
|
||||
|
|
@ -157,13 +157,13 @@ ARTICLE: "histogram" "Computing histograms"
|
|||
"Counting elements in a sequence:"
|
||||
{ $subsections
|
||||
histogram
|
||||
histogram*
|
||||
histogram!
|
||||
sorted-histogram
|
||||
}
|
||||
"Combinators for implementing histogram:"
|
||||
{ $subsections
|
||||
sequence>assoc
|
||||
sequence>assoc*
|
||||
sequence>assoc!
|
||||
sequence>hashtable
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -64,7 +64,7 @@ IN: math.statistics
|
|||
|
||||
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 )
|
||||
|
|
@ -73,8 +73,8 @@ PRIVATE>
|
|||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -2251,3 +2251,17 @@ CONSTANT: GL_LUMINANCE_ALPHA_INTEGER_EXT HEX: 8D9D
|
|||
GL-FUNCTION: void glClearColorIiEXT { } ( GLint r, GLint g, GLint b, GLint a ) ;
|
||||
GL-FUNCTION: void glClearColorIuiEXT { } ( GLuint r, GLuint g, GLuint b, GLuint a ) ;
|
||||
|
||||
! GL_EXT_texture_compression_s3tc, GL_EXT_texture_compression_dxt1
|
||||
|
||||
CONSTANT: GL_COMPRESSED_RGB_S3TC_DXT1_EXT HEX: 83F0
|
||||
CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT1_EXT HEX: 83F1
|
||||
CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT3_EXT HEX: 83F2
|
||||
CONSTANT: GL_COMPRESSED_RGBA_S3TC_DXT5_EXT HEX: 83F3
|
||||
|
||||
! GL_EXT_texture_compression_latc
|
||||
|
||||
CONSTANT: GL_COMPRESSED_LUMINANCE_LATC1_EXT HEX: 8C70
|
||||
CONSTANT: GL_COMPRESSED_SIGNED_LUMINANCE_LATC1_EXT HEX: 8C71
|
||||
CONSTANT: GL_COMPRESSED_LUMINANCE_ALPHA_LATC2_EXT HEX: 8C72
|
||||
CONSTANT: GL_COMPRESSED_SIGNED_LUMINANCE_ALPHA_LATC2_EXT HEX: 8C73
|
||||
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ M: parsing-word pprint*
|
|||
M: word pprint*
|
||||
[ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
|
||||
|
||||
M: method-body pprint*
|
||||
M: method pprint*
|
||||
[
|
||||
[
|
||||
[ "M\\ " % "method-class" word-prop word-name* % ]
|
||||
|
|
@ -229,7 +229,7 @@ M: compose pprint* pprint-object ;
|
|||
|
||||
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 ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,10 @@
|
|||
! 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 -- )
|
||||
|
|
@ -72,24 +72,55 @@ SYMBOL: ->
|
|||
] [ ] 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. ;
|
||||
|
||||
|
|
|
|||
|
|
@ -86,8 +86,9 @@ HELP: sample
|
|||
}
|
||||
{ $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 }"
|
||||
}
|
||||
} ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! 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
|
||||
|
|
@ -61,29 +62,20 @@ M: sequence random
|
|||
|
||||
: 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 ;
|
||||
|
||||
: randomize ( seq -- seq )
|
||||
dup length randomize-n-last ;
|
||||
|
||||
ERROR: too-many-samples seq n ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
:: 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>
|
||||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@ M:: sfmt generate ( sfmt -- )
|
|||
|
||||
: <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
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ CONSTANT: fail-state -1
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -76,7 +76,7 @@ M: hook-generic synopsis*
|
|||
[ stack-effect. ]
|
||||
} cleave ;
|
||||
|
||||
M: method-body synopsis*
|
||||
M: method synopsis*
|
||||
[ definer. ]
|
||||
[ "method-class" word-prop pprint-word ]
|
||||
[ "method-generic" word-prop pprint-word ] tri ;
|
||||
|
|
|
|||
|
|
@ -236,7 +236,7 @@ SYMBOL: deserialized
|
|||
: deserialize-hashtable ( -- hashtable )
|
||||
H{ } clone
|
||||
[ intern-object ]
|
||||
[ (deserialize) update ]
|
||||
[ (deserialize) assoc-union! drop ]
|
||||
[ ] tri ;
|
||||
|
||||
: copy-seq-to-tuple ( seq tuple -- )
|
||||
|
|
|
|||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue