Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
daa0f94db7
|
|
@ -24,3 +24,4 @@ build-support/wordsize
|
|||
*.bak
|
||||
.#*
|
||||
*.swo
|
||||
checksums.txt
|
||||
|
|
|
|||
14
README.txt
14
README.txt
|
|
@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI.
|
|||
|
||||
* Running Factor on Windows XP/Vista
|
||||
|
||||
The Factor runtime is compiled into two binaries:
|
||||
|
||||
factor.com - a Windows console application
|
||||
factor.exe - a Windows native application, without a console
|
||||
|
||||
If you did not download the binary package, you can bootstrap Factor in
|
||||
the command prompt:
|
||||
the command prompt using the console application:
|
||||
|
||||
factor.exe -i=boot.<cpu>.image
|
||||
factor.com -i=boot.<cpu>.image
|
||||
|
||||
Once bootstrapped, double-clicking factor.exe starts the Factor UI.
|
||||
Once bootstrapped, double-clicking factor.exe or factor.com starts
|
||||
the Factor UI.
|
||||
|
||||
To run the listener in the command prompt:
|
||||
|
||||
factor.exe -run=listener
|
||||
factor.com -run=listener
|
||||
|
||||
* The Factor FAQ
|
||||
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ;
|
|||
|
||||
M: array stack-size drop "void*" stack-size ;
|
||||
|
||||
M: array c-type-boxer-quot drop f ;
|
||||
M: array c-type-boxer-quot drop [ ] ;
|
||||
|
||||
M: array c-type-unboxer-quot drop [ >c-ptr ] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
|
|||
namespaces make parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
layouts system compiler.units io.files io.encodings.binary
|
||||
accessors combinators effects continuations fry ;
|
||||
accessors combinators effects continuations fry call classes ;
|
||||
IN: alien.c-types
|
||||
|
||||
DEFER: <int>
|
||||
|
|
@ -13,18 +13,20 @@ DEFER: *char
|
|||
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
|
||||
|
||||
TUPLE: c-type
|
||||
class
|
||||
boxer boxer-quot unboxer unboxer-quot
|
||||
getter setter
|
||||
reg-class size align stack-align? ;
|
||||
|
||||
: new-c-type ( class -- type )
|
||||
new
|
||||
int-regs >>reg-class
|
||||
object >>class ; inline
|
||||
{ class class initial: object }
|
||||
boxer
|
||||
{ boxer-quot callable }
|
||||
unboxer
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable }
|
||||
{ reg-class initial: int-regs }
|
||||
size
|
||||
align
|
||||
stack-align? ;
|
||||
|
||||
: <c-type> ( -- type )
|
||||
\ c-type new-c-type ;
|
||||
\ c-type new ;
|
||||
|
||||
SYMBOL: c-types
|
||||
|
||||
|
|
@ -185,6 +187,9 @@ M: f byte-length drop 0 ;
|
|||
[ "Cannot read struct fields with this type" throw ]
|
||||
] unless* ;
|
||||
|
||||
: c-type-getter-boxer ( name -- quot )
|
||||
[ c-getter ] [ c-type-boxer-quot ] bi append ;
|
||||
|
||||
: c-setter ( name -- quot )
|
||||
c-type-setter [
|
||||
[ "Cannot write struct fields with this type" throw ]
|
||||
|
|
@ -221,7 +226,7 @@ M: f byte-length drop 0 ;
|
|||
TUPLE: long-long-type < c-type ;
|
||||
|
||||
: <long-long-type> ( -- type )
|
||||
long-long-type new-c-type ;
|
||||
long-long-type new ;
|
||||
|
||||
M: long-long-type unbox-parameter ( n type -- )
|
||||
c-type-unboxer %unbox-long-long ;
|
||||
|
|
@ -258,7 +263,7 @@ M: long-long-type box-return ( type -- )
|
|||
unclip [
|
||||
[
|
||||
dup word? [
|
||||
def>> { } swap with-datastack first
|
||||
def>> call( -- object )
|
||||
] when
|
||||
] map
|
||||
] dip prefix
|
||||
|
|
|
|||
|
|
@ -15,4 +15,4 @@ C-STRUCT: complex-holder
|
|||
C{ 1.0 2.0 } <complex-holder> "h" set
|
||||
] unit-test
|
||||
|
||||
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
|
||||
[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,6 +1,13 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.complex.functor sequences kernel ;
|
||||
USING: alien.c-types alien.structs alien.complex.functor accessors
|
||||
sequences kernel ;
|
||||
IN: alien.complex
|
||||
|
||||
<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >>
|
||||
<<
|
||||
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
|
||||
|
||||
! This overrides the fact that small structures are never returned
|
||||
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
|
||||
"complex-float" c-type t >>return-in-registers? drop
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -12,15 +12,15 @@ T-imaginary DEFINES ${T}-imaginary
|
|||
set-T-real DEFINES set-${T}-real
|
||||
set-T-imaginary DEFINES set-${T}-imaginary
|
||||
|
||||
>T DEFINES >${T}
|
||||
T> DEFINES ${T}>
|
||||
<T> DEFINES <${T}>
|
||||
*T DEFINES *${T}
|
||||
|
||||
WHERE
|
||||
|
||||
: >T ( z -- alien )
|
||||
: <T> ( z -- alien )
|
||||
>rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
|
||||
|
||||
: T> ( alien -- z )
|
||||
: *T ( alien -- z )
|
||||
[ T-real ] [ T-imaginary ] bi rect> ; inline
|
||||
|
||||
T in get
|
||||
|
|
@ -28,8 +28,8 @@ T in get
|
|||
define-struct
|
||||
|
||||
T c-type
|
||||
T> 1quotation >>boxer-quot
|
||||
>T 1quotation >>unboxer-quot
|
||||
<T> 1quotation >>unboxer-quot
|
||||
*T 1quotation >>boxer-quot
|
||||
drop
|
||||
|
||||
;FUNCTOR
|
||||
;FUNCTOR
|
||||
|
|
|
|||
|
|
@ -0,0 +1,73 @@
|
|||
! Copyright (C) 2009 Joe Groff
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel quotations sequences strings words.symbol ;
|
||||
QUALIFIED-WITH: alien.syntax c
|
||||
IN: alien.fortran
|
||||
|
||||
ARTICLE: "alien.fortran-abis" "Fortran ABIs"
|
||||
"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
|
||||
{ $list
|
||||
{ { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
|
||||
{ { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
|
||||
{ { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
|
||||
{ { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
|
||||
}
|
||||
"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
|
||||
|
||||
ARTICLE: "alien.fortran-types" "Fortran types"
|
||||
"The Fortran FFI recognizes the following Fortran types:"
|
||||
{ $list
|
||||
{ { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." }
|
||||
{ { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." }
|
||||
{ { $snippet "REAL" } " specifies a single-precision floating-point real value." }
|
||||
{ { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." }
|
||||
{ { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." }
|
||||
{ { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." }
|
||||
{ { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." }
|
||||
{ "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." }
|
||||
{ "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." }
|
||||
}
|
||||
"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ;
|
||||
|
||||
HELP: FUNCTION:
|
||||
{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
|
||||
{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
|
||||
|
||||
HELP: SUBROUTINE:
|
||||
{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" }
|
||||
{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ;
|
||||
|
||||
HELP: LIBRARY:
|
||||
{ $syntax "LIBRARY: name" }
|
||||
{ $values { "name" "a logical library name" } }
|
||||
{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ;
|
||||
|
||||
HELP: RECORD:
|
||||
{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" }
|
||||
{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ;
|
||||
|
||||
HELP: add-fortran-library
|
||||
{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } }
|
||||
{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." }
|
||||
;
|
||||
|
||||
HELP: fortran-invoke
|
||||
{ $values
|
||||
{ "return" string } { "library" string } { "procedure" string } { "parameters" sequence }
|
||||
}
|
||||
{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." }
|
||||
;
|
||||
|
||||
ARTICLE: "alien.fortran" "Fortran FFI"
|
||||
"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran."
|
||||
{ $subsection "alien.fortran-types" }
|
||||
{ $subsection "alien.fortran-abis" }
|
||||
{ $subsection add-fortran-library }
|
||||
{ $subsection POSTPONE: LIBRARY: }
|
||||
{ $subsection POSTPONE: FUNCTION: }
|
||||
{ $subsection POSTPONE: SUBROUTINE: }
|
||||
{ $subsection POSTPONE: RECORD: }
|
||||
{ $subsection fortran-invoke }
|
||||
;
|
||||
|
||||
ABOUT: "alien.fortran"
|
||||
|
|
@ -0,0 +1,381 @@
|
|||
! (c) 2009 Joe Groff, see BSD license
|
||||
USING: accessors alien alien.c-types alien.complex
|
||||
alien.fortran alien.fortran.private alien.strings alien.structs
|
||||
arrays assocs byte-arrays combinators fry
|
||||
generalizations io.encodings.ascii kernel macros
|
||||
macros.expander namespaces sequences shuffle tools.test ;
|
||||
IN: alien.fortran.tests
|
||||
|
||||
<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >>
|
||||
LIBRARY: (alien.fortran-tests)
|
||||
RECORD: FORTRAN_TEST_RECORD
|
||||
{ "INTEGER" "FOO" }
|
||||
{ "REAL(2)" "BAR" }
|
||||
{ "CHARACTER*4" "BAS" } ;
|
||||
|
||||
intel-unix-abi fortran-abi [
|
||||
|
||||
! fortran-name>symbol-name
|
||||
|
||||
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
|
||||
[ "fun_times_" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
|
||||
[ "funtimes__" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
|
||||
|
||||
! fortran-type>c-type
|
||||
|
||||
[ "short" ]
|
||||
[ "integer*2" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int" ]
|
||||
[ "integer*4" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int" ]
|
||||
[ "INTEGER" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "longlong" ]
|
||||
[ "iNteger*8" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int[0]" ]
|
||||
[ "integer(*)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int[0]" ]
|
||||
[ "integer(3,*)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int[3]" ]
|
||||
[ "integer(3)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int[6]" ]
|
||||
[ "integer(3,2)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int[24]" ]
|
||||
[ "integer(4,3,2)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char" ]
|
||||
[ "character" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char" ]
|
||||
[ "character*1" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char[17]" ]
|
||||
[ "character*17" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char[17]" ]
|
||||
[ "character(17)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "int" ]
|
||||
[ "logical" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "float" ]
|
||||
[ "real" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "double" ]
|
||||
[ "double-precision" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "float" ]
|
||||
[ "real*4" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "double" ]
|
||||
[ "real*8" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "complex-float" ]
|
||||
[ "complex" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "complex-double" ]
|
||||
[ "double-complex" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "complex-float" ]
|
||||
[ "complex*8" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "complex-double" ]
|
||||
[ "complex*16" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "fortran_test_record" ]
|
||||
[ "fortran_test_record" fortran-type>c-type ] unit-test
|
||||
|
||||
! fortran-arg-type>c-type
|
||||
|
||||
[ "int*" { } ]
|
||||
[ "integer" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "int*" { } ]
|
||||
[ "integer(3)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "int*" { } ]
|
||||
[ "integer(*)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "fortran_test_record*" { } ]
|
||||
[ "fortran_test_record" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { } ]
|
||||
[ "character" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { } ]
|
||||
[ "character(1)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { "long" } ]
|
||||
[ "character(17)" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
! fortran-ret-type>c-type
|
||||
|
||||
[ "char" { } ]
|
||||
[ "character(1)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "char*" "long" } ]
|
||||
[ "character(17)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "int" { } ]
|
||||
[ "integer" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "int" { } ]
|
||||
[ "logical" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "float" { } ]
|
||||
[ "real" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "float*" } ]
|
||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "double" { } ]
|
||||
[ "double-precision" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "complex-float*" } ]
|
||||
[ "complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "complex-double*" } ]
|
||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "int*" } ]
|
||||
[ "integer(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "fortran_test_record*" } ]
|
||||
[ "fortran_test_record" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
! fortran-sig>c-sig
|
||||
|
||||
[ "float" { "int*" "char*" "float*" "double*" "long" } ]
|
||||
[ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ "char" { "char*" "char*" "int*" "long" } ]
|
||||
[ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ "void" { "char*" "long" "char*" "char*" "int*" "long" } ]
|
||||
[ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
[ "void" { "complex-float*" "char*" "char*" "int*" "long" } ]
|
||||
[ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ]
|
||||
unit-test
|
||||
|
||||
! fortran-record>c-struct
|
||||
|
||||
[ {
|
||||
{ "double" "ex" }
|
||||
{ "float" "wye" }
|
||||
{ "int" "zee" }
|
||||
{ "char[20]" "woo" }
|
||||
} ] [
|
||||
{
|
||||
{ "DOUBLE-PRECISION" "EX" }
|
||||
{ "REAL" "WYE" }
|
||||
{ "INTEGER" "ZEE" }
|
||||
{ "CHARACTER(20)" "WOO" }
|
||||
} fortran-record>c-struct
|
||||
] unit-test
|
||||
|
||||
! RECORD:
|
||||
|
||||
[ 16 ] [ "fortran_test_record" heap-size ] unit-test
|
||||
[ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test
|
||||
[ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test
|
||||
[ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test
|
||||
|
||||
! (fortran-invoke)
|
||||
|
||||
[ [
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ {
|
||||
[ ascii string>alien ]
|
||||
[ <longlong> ]
|
||||
[ <float> ]
|
||||
[ <complex-float> ]
|
||||
[ 1 0 ? <short> ]
|
||||
} spread ]
|
||||
[ { [ length ] [ drop ] [ drop ] [ drop ] [ drop ] } spread ]
|
||||
} 5 ncleave
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "funpack" "funtimes_"
|
||||
{ "char*" "longlong*" "float*" "complex-float*" "short*" "long" }
|
||||
alien-invoke
|
||||
] 6 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( aa ba ca da ea ab -- aa ab ba ca da ea )
|
||||
{
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
[ *float ]
|
||||
[ drop ]
|
||||
[ drop ]
|
||||
} spread
|
||||
] ] [
|
||||
f "funpack" "FUNTIMES" { "CHARACTER*12" "INTEGER*8" "!REAL" "COMPLEX" "LOGICAL*2" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ { [ ] } spread ]
|
||||
[ { [ drop ] } spread ]
|
||||
} 1 ncleave
|
||||
! [fortran-invoke]
|
||||
[ "float" "funpack" "fun_times_" { "float*" } alien-invoke ]
|
||||
1 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta aa -- reta aa )
|
||||
{ [ ] [ drop ] } spread
|
||||
] ] [
|
||||
"REAL" "funpack" "FUN_TIMES" { "REAL(*)" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ "complex-float" <c-object> ] 1 ndip
|
||||
! [fortran-args>c-args]
|
||||
{ [ { [ ] } spread ] [ { [ drop ] } spread ] } 1 ncleave
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "funpack" "fun_times_"
|
||||
{ "complex-float*" "float*" }
|
||||
alien-invoke
|
||||
] 2 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta aa -- reta aa )
|
||||
{ [ *complex-float ] [ drop ] } spread
|
||||
] ] [
|
||||
"COMPLEX" "funpack" "FUN_TIMES" { "REAL(*)" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ 20 <byte-array> 20 ] 0 ndip
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "funpack" "fun_times_"
|
||||
{ "char*" "long" }
|
||||
alien-invoke
|
||||
] 2 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta retb -- reta retb )
|
||||
{ [ ] [ ascii alien>nstring ] } spread
|
||||
] ] [
|
||||
"CHARACTER*20" "funpack" "FUN_TIMES" { }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
[ [
|
||||
! [<fortran-result>]
|
||||
[ 10 <byte-array> 10 ] 3 ndip
|
||||
! [fortran-args>c-args]
|
||||
{
|
||||
[ {
|
||||
[ ascii string>alien ]
|
||||
[ <float> ]
|
||||
[ ascii string>alien ]
|
||||
} spread ]
|
||||
[ { [ length ] [ drop ] [ length ] } spread ]
|
||||
} 3 ncleave
|
||||
! [fortran-invoke]
|
||||
[
|
||||
"void" "funpack" "fun_times_"
|
||||
{ "char*" "long" "char*" "float*" "char*" "long" "long" }
|
||||
alien-invoke
|
||||
] 7 nkeep
|
||||
! [fortran-results>]
|
||||
shuffle( reta retb aa ba ca ab cb -- reta retb aa ab ba ca cb )
|
||||
{
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
[ *float ]
|
||||
[ ]
|
||||
[ ascii alien>nstring ]
|
||||
} spread
|
||||
] ] [
|
||||
"CHARACTER*10" "funpack" "FUN_TIMES" { "!CHARACTER*20" "!REAL" "!CHARACTER*30" }
|
||||
(fortran-invoke)
|
||||
] unit-test
|
||||
|
||||
] with-variable ! intel-unix-abi
|
||||
|
||||
intel-windows-abi fortran-abi [
|
||||
|
||||
[ "FUN" ] [ "FUN" fortran-name>symbol-name ] unit-test
|
||||
[ "FUN_TIMES" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
|
||||
[ "FUNTIMES_" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
|
||||
|
||||
] with-variable
|
||||
|
||||
f2c-abi fortran-abi [
|
||||
|
||||
[ "char[1]" ]
|
||||
[ "character(1)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { "long" } ]
|
||||
[ "character" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "char*" "long" } ]
|
||||
[ "character" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "double" { } ]
|
||||
[ "real" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "float*" } ]
|
||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test
|
||||
[ "fun_times__" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test
|
||||
[ "funtimes___" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test
|
||||
|
||||
] with-variable
|
||||
|
||||
gfortran-abi fortran-abi [
|
||||
|
||||
[ "float" { } ]
|
||||
[ "real" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "float*" } ]
|
||||
[ "real(*)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "complex-float" { } ]
|
||||
[ "complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "complex-double" { } ]
|
||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "char[1]" ]
|
||||
[ "character(1)" fortran-type>c-type ] unit-test
|
||||
|
||||
[ "char*" { "long" } ]
|
||||
[ "character" fortran-arg-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "char*" "long" } ]
|
||||
[ "character" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "complex-float" { } ]
|
||||
[ "complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "complex-double" { } ]
|
||||
[ "double-complex" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
[ "void" { "complex-double*" } ]
|
||||
[ "double-complex(3)" fortran-ret-type>c-type ] unit-test
|
||||
|
||||
] with-variable
|
||||
|
|
@ -0,0 +1,452 @@
|
|||
! (c) 2009 Joe Groff, see BSD license
|
||||
USING: accessors alien alien.c-types alien.complex alien.parser
|
||||
alien.strings alien.structs 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 ;
|
||||
IN: alien.fortran
|
||||
|
||||
SINGLETONS: f2c-abi gfortran-abi intel-unix-abi intel-windows-abi ;
|
||||
|
||||
<<
|
||||
: add-f2c-libraries ( -- )
|
||||
"I77" "libI77.so" "cdecl" add-library
|
||||
"F77" "libF77.so" "cdecl" add-library ;
|
||||
|
||||
os netbsd? [ add-f2c-libraries ] when
|
||||
>>
|
||||
|
||||
: alien>nstring ( alien len encoding -- string )
|
||||
[ memory>byte-array ] dip decode ;
|
||||
|
||||
ERROR: invalid-fortran-type type ;
|
||||
|
||||
DEFER: fortran-sig>c-sig
|
||||
DEFER: fortran-ret-type>c-type
|
||||
DEFER: fortran-arg-type>c-type
|
||||
DEFER: fortran-name>symbol-name
|
||||
|
||||
SYMBOL: library-fortran-abis
|
||||
SYMBOL: fortran-abi
|
||||
library-fortran-abis [ H{ } clone ] initialize
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: lowercase-name-with-underscore ( name -- name' )
|
||||
>lower "_" append ;
|
||||
: lowercase-name-with-extra-underscore ( name -- name' )
|
||||
>lower CHAR: _ over member?
|
||||
[ "__" append ] [ "_" append ] if ;
|
||||
|
||||
HOOK: fortran-c-abi fortran-abi ( -- abi )
|
||||
M: f2c-abi fortran-c-abi "cdecl" ;
|
||||
M: gfortran-abi fortran-c-abi "cdecl" ;
|
||||
M: intel-unix-abi fortran-c-abi "cdecl" ;
|
||||
M: intel-windows-abi fortran-c-abi "cdecl" ;
|
||||
|
||||
HOOK: real-functions-return-double? fortran-abi ( -- ? )
|
||||
M: f2c-abi real-functions-return-double? t ;
|
||||
M: gfortran-abi real-functions-return-double? f ;
|
||||
M: intel-unix-abi real-functions-return-double? f ;
|
||||
M: intel-windows-abi real-functions-return-double? f ;
|
||||
|
||||
HOOK: complex-functions-return-by-value? fortran-abi ( -- ? )
|
||||
M: f2c-abi complex-functions-return-by-value? f ;
|
||||
M: gfortran-abi complex-functions-return-by-value? t ;
|
||||
M: intel-unix-abi complex-functions-return-by-value? f ;
|
||||
M: intel-windows-abi complex-functions-return-by-value? f ;
|
||||
|
||||
HOOK: character(1)-maps-to-char? fortran-abi ( -- ? )
|
||||
M: f2c-abi character(1)-maps-to-char? f ;
|
||||
M: gfortran-abi character(1)-maps-to-char? f ;
|
||||
M: intel-unix-abi character(1)-maps-to-char? t ;
|
||||
M: intel-windows-abi character(1)-maps-to-char? t ;
|
||||
|
||||
HOOK: mangle-name fortran-abi ( name -- name' )
|
||||
M: f2c-abi mangle-name lowercase-name-with-extra-underscore ;
|
||||
M: gfortran-abi mangle-name lowercase-name-with-underscore ;
|
||||
M: intel-unix-abi mangle-name lowercase-name-with-underscore ;
|
||||
M: intel-windows-abi mangle-name >upper ;
|
||||
|
||||
TUPLE: fortran-type dims size out? ;
|
||||
|
||||
TUPLE: number-type < fortran-type ;
|
||||
TUPLE: integer-type < number-type ;
|
||||
TUPLE: logical-type < integer-type ;
|
||||
TUPLE: real-type < number-type ;
|
||||
TUPLE: double-precision-type < number-type ;
|
||||
|
||||
TUPLE: character-type < fortran-type ;
|
||||
TUPLE: misc-type < fortran-type name ;
|
||||
|
||||
TUPLE: complex-type < number-type ;
|
||||
TUPLE: real-complex-type < complex-type ;
|
||||
TUPLE: double-complex-type < complex-type ;
|
||||
|
||||
CONSTANT: fortran>c-types H{
|
||||
{ "character" character-type }
|
||||
{ "integer" integer-type }
|
||||
{ "logical" logical-type }
|
||||
{ "real" real-type }
|
||||
{ "double-precision" double-precision-type }
|
||||
{ "complex" real-complex-type }
|
||||
{ "double-complex" double-complex-type }
|
||||
}
|
||||
|
||||
: append-dimensions ( base-c-type type -- c-type )
|
||||
dims>>
|
||||
[ product number>string "[" "]" surround append ] when* ;
|
||||
|
||||
MACRO: size-case-type ( cases -- )
|
||||
[ invalid-fortran-type ] suffix
|
||||
'[ [ size>> _ case ] [ append-dimensions ] bi ] ;
|
||||
|
||||
: simple-type ( type base-c-type -- c-type )
|
||||
swap
|
||||
[ dup size>> [ invalid-fortran-type ] [ drop ] if ]
|
||||
[ append-dimensions ] bi ;
|
||||
|
||||
: new-fortran-type ( out? dims size class -- type )
|
||||
new [ [ (>>size) ] [ (>>dims) ] [ (>>out?) ] tri ] keep ;
|
||||
|
||||
GENERIC: (fortran-type>c-type) ( type -- c-type )
|
||||
|
||||
M: f (fortran-type>c-type) drop "void" ;
|
||||
|
||||
M: integer-type (fortran-type>c-type)
|
||||
{
|
||||
{ f [ "int" ] }
|
||||
{ 1 [ "char" ] }
|
||||
{ 2 [ "short" ] }
|
||||
{ 4 [ "int" ] }
|
||||
{ 8 [ "longlong" ] }
|
||||
} size-case-type ;
|
||||
M: real-type (fortran-type>c-type)
|
||||
{
|
||||
{ f [ "float" ] }
|
||||
{ 4 [ "float" ] }
|
||||
{ 8 [ "double" ] }
|
||||
} size-case-type ;
|
||||
M: real-complex-type (fortran-type>c-type)
|
||||
{
|
||||
{ f [ "complex-float" ] }
|
||||
{ 8 [ "complex-float" ] }
|
||||
{ 16 [ "complex-double" ] }
|
||||
} size-case-type ;
|
||||
|
||||
M: double-precision-type (fortran-type>c-type)
|
||||
"double" simple-type ;
|
||||
M: double-complex-type (fortran-type>c-type)
|
||||
"complex-double" simple-type ;
|
||||
M: misc-type (fortran-type>c-type)
|
||||
dup name>> simple-type ;
|
||||
|
||||
: single-char? ( character-type -- ? )
|
||||
{ [ drop character(1)-maps-to-char? ] [ dims>> product 1 = ] } 1&& ;
|
||||
|
||||
: fix-character-type ( character-type -- character-type' )
|
||||
clone dup size>>
|
||||
[ dup dims>> [ invalid-fortran-type ] [ dup size>> 1array >>dims f >>size ] if ]
|
||||
[ dup dims>> [ ] [ f >>dims ] if ] if
|
||||
dup single-char? [ f >>dims ] when ;
|
||||
|
||||
M: character-type (fortran-type>c-type)
|
||||
fix-character-type "char" simple-type ;
|
||||
|
||||
: dimension>number ( string -- number )
|
||||
dup "*" = [ drop 0 ] [ string>number ] if ;
|
||||
|
||||
: parse-out ( string -- string' out? )
|
||||
"!" ?head ;
|
||||
|
||||
: parse-dims ( string -- string' dim )
|
||||
"(" split1 dup
|
||||
[ ")" ?tail drop "," split [ [ blank? ] trim dimension>number ] map ] when ;
|
||||
|
||||
: parse-size ( string -- string' size )
|
||||
"*" split1 dup [ string>number ] when ;
|
||||
|
||||
: (parse-fortran-type) ( fortran-type-string -- type )
|
||||
parse-out swap parse-dims swap parse-size swap
|
||||
dup >lower fortran>c-types at*
|
||||
[ nip new-fortran-type ] [ drop misc-type boa ] if ;
|
||||
|
||||
: parse-fortran-type ( fortran-type-string/f -- type/f )
|
||||
dup [ (parse-fortran-type) ] when ;
|
||||
|
||||
: c-type>pointer ( c-type -- c-type* )
|
||||
"[" split1 drop "*" append ;
|
||||
|
||||
GENERIC: added-c-args ( type -- args )
|
||||
|
||||
M: fortran-type added-c-args drop { } ;
|
||||
M: character-type added-c-args fix-character-type single-char? [ { } ] [ { "long" } ] if ;
|
||||
|
||||
GENERIC: returns-by-value? ( type -- ? )
|
||||
|
||||
M: f returns-by-value? drop t ;
|
||||
M: fortran-type returns-by-value? drop f ;
|
||||
M: number-type returns-by-value? dims>> not ;
|
||||
M: character-type returns-by-value? fix-character-type single-char? ;
|
||||
M: complex-type returns-by-value?
|
||||
{ [ drop complex-functions-return-by-value? ] [ dims>> not ] } 1&& ;
|
||||
|
||||
GENERIC: (fortran-ret-type>c-type) ( type -- c-type )
|
||||
|
||||
M: f (fortran-ret-type>c-type) drop "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 ;
|
||||
|
||||
: suffix! ( seq elt -- seq ) over push ; inline
|
||||
: append! ( seq-a seq-b -- seq-a ) over push-all ; inline
|
||||
|
||||
GENERIC: (fortran-arg>c-args) ( type -- main-quot added-quot )
|
||||
|
||||
: args?dims ( type quot -- main-quot added-quot )
|
||||
[ dup dims>> [ drop [ ] [ drop ] ] ] dip if ; inline
|
||||
|
||||
M: integer-type (fortran-arg>c-args)
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <int> ] [ drop ] ] }
|
||||
{ 1 [ [ <char> ] [ drop ] ] }
|
||||
{ 2 [ [ <short> ] [ drop ] ] }
|
||||
{ 4 [ [ <int> ] [ drop ] ] }
|
||||
{ 8 [ [ <longlong> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
M: logical-type (fortran-arg>c-args)
|
||||
[ call-next-method [ [ 1 0 ? ] prepend ] dip ] args?dims ;
|
||||
|
||||
M: real-type (fortran-arg>c-args)
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <float> ] [ drop ] ] }
|
||||
{ 4 [ [ <float> ] [ drop ] ] }
|
||||
{ 8 [ [ <double> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
M: real-complex-type (fortran-arg>c-args)
|
||||
[
|
||||
size>> {
|
||||
{ f [ [ <complex-float> ] [ drop ] ] }
|
||||
{ 8 [ [ <complex-float> ] [ drop ] ] }
|
||||
{ 16 [ [ <complex-double> ] [ drop ] ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case
|
||||
] args?dims ;
|
||||
|
||||
M: double-precision-type (fortran-arg>c-args)
|
||||
[ drop [ <double> ] [ drop ] ] args?dims ;
|
||||
|
||||
M: double-complex-type (fortran-arg>c-args)
|
||||
[ drop [ <complex-double> ] [ drop ] ] args?dims ;
|
||||
|
||||
M: character-type (fortran-arg>c-args)
|
||||
fix-character-type single-char?
|
||||
[ [ first <char> ] [ drop ] ]
|
||||
[ [ ascii string>alien ] [ length ] ] if ;
|
||||
|
||||
M: misc-type (fortran-arg>c-args)
|
||||
drop [ ] [ drop ] ;
|
||||
|
||||
GENERIC: (fortran-result>) ( type -- quots )
|
||||
|
||||
: result?dims ( type quot -- quot )
|
||||
[ dup dims>> [ drop { [ ] } ] ] dip if ; inline
|
||||
|
||||
M: integer-type (fortran-result>)
|
||||
[ size>> {
|
||||
{ f [ { [ *int ] } ] }
|
||||
{ 1 [ { [ *char ] } ] }
|
||||
{ 2 [ { [ *short ] } ] }
|
||||
{ 4 [ { [ *int ] } ] }
|
||||
{ 8 [ { [ *longlong ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ] result?dims ;
|
||||
|
||||
M: logical-type (fortran-result>)
|
||||
[ call-next-method first [ zero? not ] append 1array ] result?dims ;
|
||||
|
||||
M: real-type (fortran-result>)
|
||||
[ size>> {
|
||||
{ f [ { [ *float ] } ] }
|
||||
{ 4 [ { [ *float ] } ] }
|
||||
{ 8 [ { [ *double ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ] result?dims ;
|
||||
|
||||
M: real-complex-type (fortran-result>)
|
||||
[ size>> {
|
||||
{ f [ { [ *complex-float ] } ] }
|
||||
{ 8 [ { [ *complex-float ] } ] }
|
||||
{ 16 [ { [ *complex-double ] } ] }
|
||||
[ invalid-fortran-type ]
|
||||
} case ] result?dims ;
|
||||
|
||||
M: double-precision-type (fortran-result>)
|
||||
[ drop { [ *double ] } ] result?dims ;
|
||||
|
||||
M: double-complex-type (fortran-result>)
|
||||
[ drop { [ *complex-double ] } ] result?dims ;
|
||||
|
||||
M: character-type (fortran-result>)
|
||||
fix-character-type single-char?
|
||||
[ { [ *char 1string ] } ]
|
||||
[ { [ ] [ ascii alien>nstring ] } ] if ;
|
||||
|
||||
M: misc-type (fortran-result>)
|
||||
drop { [ ] } ;
|
||||
|
||||
GENERIC: (<fortran-result>) ( type -- quot )
|
||||
|
||||
M: fortran-type (<fortran-result>)
|
||||
(fortran-type>c-type) \ <c-object> [ ] 2sequence ;
|
||||
|
||||
M: character-type (<fortran-result>)
|
||||
fix-character-type dims>> product dup
|
||||
[ \ <byte-array> ] dip [ ] 3sequence ;
|
||||
|
||||
: [<fortran-result>] ( return parameters -- quot )
|
||||
[ parse-fortran-type ] dip
|
||||
over returns-by-value?
|
||||
[ 2drop [ ] ]
|
||||
[ [ (<fortran-result>) ] [ length \ ndip [ ] 3sequence ] bi* ] if ;
|
||||
|
||||
: [fortran-args>c-args] ( parameters -- quot )
|
||||
[ [ ] ] [
|
||||
[ parse-fortran-type (fortran-arg>c-args) 2array ] map flip first2
|
||||
[ [ \ spread [ ] 2sequence ] bi@ 2array ] [ length ] bi
|
||||
\ ncleave [ ] 3sequence
|
||||
] if-empty ;
|
||||
|
||||
:: [fortran-invoke] ( [args>args] return library function parameters -- [args>args] quot )
|
||||
return parameters fortran-sig>c-sig :> c-parameters :> c-return
|
||||
function fortran-name>symbol-name :> c-function
|
||||
[args>args]
|
||||
c-return library c-function c-parameters \ alien-invoke
|
||||
5 [ ] nsequence
|
||||
c-parameters length \ nkeep
|
||||
[ ] 3sequence ;
|
||||
|
||||
: [fortran-out-param>] ( parameter -- quot )
|
||||
parse-fortran-type
|
||||
[ (fortran-result>) ] [ out?>> ] bi
|
||||
[ ] [ [ drop [ drop ] ] map ] if ;
|
||||
|
||||
: [fortran-return>] ( return -- quot )
|
||||
parse-fortran-type {
|
||||
{ [ dup not ] [ drop { } ] }
|
||||
{ [ dup returns-by-value? ] [ drop { [ ] } ] }
|
||||
[ (fortran-result>) ]
|
||||
} cond ;
|
||||
|
||||
: letters ( -- seq ) CHAR: a CHAR: z [a,b] ;
|
||||
|
||||
: (shuffle-map) ( return parameters -- ret par )
|
||||
[
|
||||
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
|
||||
[ first2 letters swap head [ "" 2sequence ] with map ] map concat
|
||||
] bi* ;
|
||||
|
||||
: (fortran-in-shuffle) ( ret par -- seq )
|
||||
[ [ second ] bi@ <=> ] sort append ;
|
||||
|
||||
: (fortran-out-shuffle) ( ret par -- seq )
|
||||
append ;
|
||||
|
||||
: [fortran-result-shuffle] ( return parameters -- quot )
|
||||
(shuffle-map) [ (fortran-in-shuffle) ] [ (fortran-out-shuffle) ] 2bi <effect>
|
||||
\ shuffle-effect [ ] 2sequence ;
|
||||
|
||||
: [fortran-results>] ( return parameters -- quot )
|
||||
[ [fortran-result-shuffle] ]
|
||||
[ drop [fortran-return>] ]
|
||||
[ nip [ [fortran-out-param>] ] map concat ] 2tri
|
||||
append
|
||||
\ spread [ ] 2sequence append ;
|
||||
|
||||
: (add-fortran-library) ( fortran-abi name -- )
|
||||
library-fortran-abis get-global set-at ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: add-fortran-library ( name soname fortran-abi -- )
|
||||
[ fortran-abi [ fortran-c-abi ] with-variable add-library ]
|
||||
[ nip swap (add-fortran-library) ] 3bi ;
|
||||
|
||||
: fortran-name>symbol-name ( fortran-name -- c-name )
|
||||
mangle-name ;
|
||||
|
||||
: fortran-type>c-type ( fortran-type -- c-type )
|
||||
parse-fortran-type (fortran-type>c-type) ;
|
||||
|
||||
: fortran-arg-type>c-type ( fortran-type -- c-type added-args )
|
||||
parse-fortran-type
|
||||
[ (fortran-type>c-type) c-type>pointer ]
|
||||
[ 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
|
||||
] if ;
|
||||
|
||||
: fortran-arg-types>c-types ( fortran-types -- c-types )
|
||||
[ length <vector> 1 <vector> ] keep
|
||||
[ fortran-arg-type>c-type swapd [ suffix! ] [ append! ] 2bi* ] each
|
||||
append >array ;
|
||||
|
||||
: fortran-sig>c-sig ( fortran-return fortran-args -- c-return c-args )
|
||||
[ fortran-ret-type>c-type ] [ fortran-arg-types>c-types ] bi* append ;
|
||||
|
||||
: fortran-record>c-struct ( record -- struct )
|
||||
[ first2 [ fortran-type>c-type ] [ >lower ] bi* 2array ] map ;
|
||||
|
||||
: define-fortran-record ( name vocab fields -- )
|
||||
[ >lower ] [ ] [ fortran-record>c-struct ] tri* define-struct ;
|
||||
|
||||
: RECORD: scan in get parse-definition define-fortran-record ; parsing
|
||||
|
||||
: set-fortran-abi ( library -- )
|
||||
library-fortran-abis get-global at fortran-abi set ;
|
||||
|
||||
: (fortran-invoke) ( return library function parameters -- quot )
|
||||
{
|
||||
[ 2nip [<fortran-result>] ]
|
||||
[ nip nip nip [fortran-args>c-args] ]
|
||||
[ [fortran-invoke] ]
|
||||
[ 2nip [fortran-results>] ]
|
||||
} 4 ncleave 4 nappend ;
|
||||
|
||||
MACRO: fortran-invoke ( return library function parameters -- )
|
||||
{ [ 2drop nip set-fortran-abi ] [ (fortran-invoke) ] } 4 ncleave ;
|
||||
|
||||
:: define-fortran-function ( return library function parameters -- )
|
||||
function create-in dup reset-generic
|
||||
return library function parameters return [ "void" ] unless* parse-arglist
|
||||
[ \ fortran-invoke 5 [ ] nsequence ] dip define-declared ;
|
||||
|
||||
: SUBROUTINE:
|
||||
f "c-library" get scan ";" parse-tokens
|
||||
[ "()" subseq? not ] filter define-fortran-function ; parsing
|
||||
|
||||
: FUNCTION:
|
||||
scan "c-library" get scan ";" parse-tokens
|
||||
[ "()" subseq? not ] filter define-fortran-function ; parsing
|
||||
|
||||
: LIBRARY:
|
||||
scan
|
||||
[ "c-library" set ]
|
||||
[ set-fortran-abi ] bi ; parsing
|
||||
|
||||
|
|
@ -0,0 +1 @@
|
|||
GNU Fortran/G77/F2C alien interface
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
fortran
|
||||
ffi
|
||||
|
|
@ -58,10 +58,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
|
|||
: define-getter ( type spec -- )
|
||||
[ set-reader-props ] keep
|
||||
[ reader>> ]
|
||||
[
|
||||
type>>
|
||||
[ c-getter ] [ c-type-boxer-quot ] bi append
|
||||
]
|
||||
[ type>> c-type-getter-boxer ]
|
||||
[ ] tri
|
||||
(( c-ptr -- value )) define-struct-slot-word ;
|
||||
|
||||
|
|
|
|||
|
|
@ -42,3 +42,18 @@ C-UNION: barx
|
|||
[ ] [ \ foox-x "help" get execute ] unit-test
|
||||
[ ] [ \ set-foox-x "help" get execute ] unit-test
|
||||
] when
|
||||
|
||||
C-STRUCT: nested
|
||||
{ "int" "x" } ;
|
||||
|
||||
C-STRUCT: nested-2
|
||||
{ "nested" "y" } ;
|
||||
|
||||
[ 4 ] [
|
||||
"nested-2" <c-object>
|
||||
"nested" <c-object>
|
||||
4 over set-nested-x
|
||||
over set-nested-2-y
|
||||
nested-2-y
|
||||
nested-x
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -1,15 +1,26 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays generic hashtables kernel kernel.private
|
||||
USING: accessors arrays assocs generic hashtables kernel kernel.private
|
||||
math namespaces parser sequences strings words libc fry
|
||||
alien.c-types alien.structs.fields cpu.architecture math.order ;
|
||||
alien.c-types alien.structs.fields cpu.architecture math.order
|
||||
quotations byte-arrays ;
|
||||
IN: alien.structs
|
||||
|
||||
TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ;
|
||||
TUPLE: struct-type
|
||||
size
|
||||
align
|
||||
fields
|
||||
{ boxer-quot callable }
|
||||
{ unboxer-quot callable }
|
||||
{ getter callable }
|
||||
{ setter callable }
|
||||
return-in-registers? ;
|
||||
|
||||
M: struct-type c-type ;
|
||||
|
||||
M: struct-type heap-size size>> ;
|
||||
|
||||
M: struct-type c-type-class drop object ;
|
||||
M: struct-type c-type-class drop byte-array ;
|
||||
|
||||
M: struct-type c-type-align align>> ;
|
||||
|
||||
|
|
@ -29,7 +40,7 @@ M: struct-type box-parameter
|
|||
[ %box-large-struct ] [ box-parameter ] if-value-struct ;
|
||||
|
||||
: if-small-struct ( c-type true false -- ? )
|
||||
[ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
|
||||
[ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
|
||||
|
||||
M: struct-type unbox-return
|
||||
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
|
||||
|
|
@ -68,3 +79,8 @@ M: struct-type stack-size
|
|||
[ expand-constants ] map
|
||||
[ [ heap-size ] [ max ] map-reduce ] keep
|
||||
compute-struct-align f (define-struct) ;
|
||||
|
||||
: offset-of ( field struct -- offset )
|
||||
c-types get at fields>>
|
||||
[ name>> = ] with find nip offset>> ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types accessors math alien.accessors kernel
|
||||
kernel.private locals sequences sequences.private byte-arrays
|
||||
kernel.private sequences sequences.private byte-arrays
|
||||
parser prettyprint.custom fry ;
|
||||
IN: bit-arrays
|
||||
|
||||
|
|
@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ;
|
|||
|
||||
: ?{ \ } [ >bit-array ] parse-literal ; parsing
|
||||
|
||||
:: integer>bit-array ( n -- bit-array )
|
||||
n zero? [ 0 <bit-array> ] [
|
||||
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
|
||||
[ n' zero? ] [
|
||||
n' out underlying>> i set-alien-unsigned-1
|
||||
n' -8 shift n'!
|
||||
i 1+ i!
|
||||
] [ ] until
|
||||
out
|
||||
]
|
||||
: integer>bit-array ( n -- bit-array )
|
||||
dup 0 = [
|
||||
<bit-array>
|
||||
] [
|
||||
[ log2 1+ <bit-array> 0 ] keep
|
||||
[ dup 0 = ] [
|
||||
[ pick underlying>> pick set-alien-unsigned-1 ] keep
|
||||
[ 1+ ] [ -8 shift ] bi*
|
||||
] [ ] until 2drop
|
||||
] if ;
|
||||
|
||||
: bit-array>integer ( bit-array -- n )
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,27 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors bitstreams io io.streams.string kernel tools.test
|
||||
grouping compression.lzw multiline byte-arrays io.encodings.binary
|
||||
io.streams.byte-array ;
|
||||
IN: bitstreams.tests
|
||||
|
||||
[ 1 t ]
|
||||
[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
|
||||
|
||||
[ 254 8 t ]
|
||||
[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
|
||||
[ 4095 12 t ]
|
||||
[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
|
||||
|
||||
[ B{ 254 } ]
|
||||
[
|
||||
<string-writer> <bitstream-writer> 254 8 rot
|
||||
[ write-bits ] keep stream>> >byte-array
|
||||
] unit-test
|
||||
|
||||
[ 255 8 t ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
|
||||
|
||||
[ 255 8 f ]
|
||||
[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test
|
||||
|
|
@ -0,0 +1,96 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors byte-arrays destructors fry io kernel locals
|
||||
math sequences ;
|
||||
IN: bitstreams
|
||||
|
||||
TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
|
||||
TUPLE: bitstream-reader < bitstream ;
|
||||
|
||||
: reset-bitstream ( stream -- stream )
|
||||
0 >>#bits 0 >>current-bits ; inline
|
||||
|
||||
: new-bitstream ( stream class -- bitstream )
|
||||
new
|
||||
swap >>stream
|
||||
reset-bitstream ; inline
|
||||
|
||||
M: bitstream-reader dispose ( stream -- )
|
||||
stream>> dispose ;
|
||||
|
||||
: <bitstream-reader> ( stream -- bitstream )
|
||||
bitstream-reader new-bitstream ; inline
|
||||
|
||||
: read-next-byte ( bitstream -- bitstream )
|
||||
dup stream>> stream-read1 [
|
||||
>>current-bits 8 >>#bits
|
||||
] [
|
||||
0 >>#bits
|
||||
t >>end-of-stream?
|
||||
] if* ;
|
||||
|
||||
: maybe-read-next-byte ( bitstream -- bitstream )
|
||||
dup #bits>> 0 = [ read-next-byte ] when ; inline
|
||||
|
||||
: shift-one-bit ( bitstream -- n )
|
||||
[ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
|
||||
|
||||
: next-bit ( bitstream -- n/f ? )
|
||||
maybe-read-next-byte
|
||||
dup end-of-stream?>> [
|
||||
drop f
|
||||
] [
|
||||
[ shift-one-bit ]
|
||||
[ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
|
||||
] if dup >boolean ;
|
||||
|
||||
: read-bit ( bitstream -- n ? )
|
||||
dup #bits>> 1 = [
|
||||
[ current-bits>> 1 bitand ]
|
||||
[ read-next-byte drop ] bi t
|
||||
] [
|
||||
next-bit
|
||||
] if ; inline
|
||||
|
||||
: bits>integer ( seq -- n )
|
||||
0 [ [ 1 shift ] dip bitor ] reduce ; inline
|
||||
|
||||
: read-bits ( width bitstream -- n width ? )
|
||||
[
|
||||
'[ _ read-bit drop ] replicate
|
||||
[ f = ] trim-tail
|
||||
[ bits>integer ] [ length ] bi
|
||||
] 2keep drop over = ;
|
||||
|
||||
TUPLE: bitstream-writer < bitstream ;
|
||||
|
||||
: <bitstream-writer> ( stream -- bitstream )
|
||||
bitstream-writer new-bitstream ; inline
|
||||
|
||||
: write-bit ( n bitstream -- )
|
||||
[ 1 shift bitor ] change-current-bits
|
||||
[ 1+ ] change-#bits
|
||||
dup #bits>> 8 = [
|
||||
[ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
|
||||
[ reset-bitstream drop ] bi
|
||||
] [
|
||||
drop
|
||||
] if ; inline
|
||||
|
||||
ERROR: invalid-bit-width n ;
|
||||
|
||||
:: write-bits ( n width bitstream -- )
|
||||
n 0 < [ n invalid-bit-width ] when
|
||||
n 0 = [
|
||||
width [ 0 bitstream write-bit ] times
|
||||
] [
|
||||
width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
|
||||
n-length [
|
||||
n-length swap - 1- neg n swap shift 1 bitand
|
||||
bitstream write-bit
|
||||
] each
|
||||
] if ;
|
||||
|
||||
: flush-bits ( bitstream -- ) stream>> stream-flush ;
|
||||
|
||||
: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: help.markup help.syntax io io.files io.pathnames ;
|
||||
USING: help.markup help.syntax io io.files io.pathnames strings ;
|
||||
IN: bootstrap.image
|
||||
|
||||
ARTICLE: "bootstrap.image" "Bootstrapping new images"
|
||||
|
|
@ -14,7 +14,7 @@ $nl
|
|||
ABOUT: "bootstrap.image"
|
||||
|
||||
HELP: make-image
|
||||
{ $values { "arch" "a string" } }
|
||||
{ $values { "arch" string } }
|
||||
{ $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:"
|
||||
{ $code "x86.32" "x86.64" "ppc" "arm" }
|
||||
{ $code "x86.32" "unix-x86.64" "winnt-x86.64" "macosx-ppc" "linux-ppc" }
|
||||
"The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax quotations effects words ;
|
||||
IN: call
|
||||
|
||||
ABOUT: "call"
|
||||
|
||||
ARTICLE: "call" "Calling code with known stack effects"
|
||||
"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
|
||||
{ $subsection POSTPONE: call( }
|
||||
{ $subsection POSTPONE: execute( }
|
||||
{ $subsection call-effect }
|
||||
{ $subsection execute-effect } ;
|
||||
|
||||
HELP: call(
|
||||
{ $syntax "[ ] call( foo -- bar )" }
|
||||
{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
|
||||
|
||||
HELP: call-effect
|
||||
{ $values { "quot" quotation } { "effect" effect } }
|
||||
{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
|
||||
|
||||
HELP: execute(
|
||||
{ $syntax "word execute( foo -- bar )" }
|
||||
{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ;
|
||||
|
||||
HELP: execute-effect
|
||||
{ $values { "word" word } { "effect" effect } }
|
||||
{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
|
||||
|
||||
{ execute-effect call-effect } related-words
|
||||
{ POSTPONE: call( POSTPONE: execute( } related-words
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math tools.test call kernel ;
|
||||
IN: call.tests
|
||||
|
||||
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
|
||||
[ 1 2 [ + ] call( -- z ) ] must-fail
|
||||
[ 1 2 [ + ] call( x y -- z a ) ] must-fail
|
||||
[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
|
||||
[ [ + ] call( x y -- z ) ] must-infer
|
||||
|
||||
[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
|
||||
[ 1 2 \ + execute( -- z ) ] must-fail
|
||||
[ 1 2 \ + execute( x y -- z a ) ] must-fail
|
||||
[ \ + execute( x y -- z ) ] must-infer
|
||||
|
|
@ -0,0 +1,30 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel macros fry summary sequences generalizations accessors
|
||||
continuations effects.parser parser words ;
|
||||
IN: call
|
||||
|
||||
ERROR: wrong-values values quot length-required ;
|
||||
|
||||
M: wrong-values summary
|
||||
drop "Wrong number of values returned from quotation" ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: firstn-safe ( array quot n -- ... )
|
||||
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: call-effect ( effect -- quot )
|
||||
[ in>> length ] [ out>> length ] bi
|
||||
'[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
|
||||
|
||||
: call(
|
||||
")" parse-effect parsed \ call-effect parsed ; parsing
|
||||
|
||||
: execute-effect ( word effect -- )
|
||||
[ [ execute ] curry ] dip call-effect ; inline
|
||||
|
||||
: execute(
|
||||
")" parse-effect parsed \ execute-effect parsed ; parsing
|
||||
|
|
@ -29,7 +29,7 @@ SYMBOL: super-sent-messages
|
|||
|
||||
SYMBOL: frameworks
|
||||
|
||||
frameworks global [ V{ } clone or ] change-at
|
||||
frameworks [ V{ } clone ] initialize
|
||||
|
||||
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien kernel math
|
|||
namespaces make parser quotations sequences strings words
|
||||
cocoa.runtime io macros memoize io.encodings.utf8
|
||||
effects libc libc.private parser lexer init core-foundation fry
|
||||
generalizations specialized-arrays.direct.alien ;
|
||||
generalizations specialized-arrays.direct.alien call ;
|
||||
IN: cocoa.messages
|
||||
|
||||
: make-sender ( method function -- quot )
|
||||
|
|
@ -19,8 +19,8 @@ IN: cocoa.messages
|
|||
SYMBOL: message-senders
|
||||
SYMBOL: super-message-senders
|
||||
|
||||
message-senders global [ H{ } assoc-like ] change-at
|
||||
super-message-senders global [ H{ } assoc-like ] change-at
|
||||
message-senders [ H{ } clone ] initialize
|
||||
super-message-senders [ H{ } clone ] initialize
|
||||
|
||||
: cache-stub ( method function hash -- )
|
||||
[
|
||||
|
|
@ -53,7 +53,7 @@ MEMO: <selector> ( name -- sel ) f \ selector boa ;
|
|||
|
||||
SYMBOL: objc-methods
|
||||
|
||||
objc-methods global [ H{ } assoc-like ] change-at
|
||||
objc-methods [ H{ } clone ] initialize
|
||||
|
||||
: lookup-method ( selector -- method )
|
||||
dup objc-methods get at
|
||||
|
|
@ -79,11 +79,11 @@ MACRO: (send) ( selector super? -- quot )
|
|||
! Runtime introspection
|
||||
SYMBOL: class-init-hooks
|
||||
|
||||
class-init-hooks global [ H{ } clone or ] change-at
|
||||
class-init-hooks [ H{ } clone ] initialize
|
||||
|
||||
: (objc-class) ( name word -- class )
|
||||
2dup execute dup [ 2nip ] [
|
||||
drop over class-init-hooks get at [ assert-depth ] when*
|
||||
drop over class-init-hooks get at [ call( -- ) ] when*
|
||||
2dup execute dup [ 2nip ] [
|
||||
2drop "No such class: " prepend throw
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -44,4 +44,6 @@ IN: combinators.smart.tests
|
|||
|
||||
\ nested-smart-combo-test must-infer
|
||||
|
||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
||||
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
|
||||
|
||||
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
|
||||
|
|
@ -21,6 +21,12 @@ MACRO: reduce-outputs ( quot operation -- newquot )
|
|||
: sum-outputs ( quot -- n )
|
||||
[ + ] reduce-outputs ; inline
|
||||
|
||||
MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
|
||||
[ dup infer out>> ] 2dip
|
||||
[ swap '[ _ _ napply ] ]
|
||||
[ [ 1 [-] ] dip n*quot ] bi-curry* bi
|
||||
'[ @ @ @ ] ;
|
||||
|
||||
MACRO: append-outputs-as ( quot exemplar -- newquot )
|
||||
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ alien.c-types alien.structs cpu.architecture ;
|
|||
IN: compiler.alien
|
||||
|
||||
: large-struct? ( ctype -- ? )
|
||||
dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
|
||||
dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
|
||||
|
||||
: alien-parameters ( params -- seq )
|
||||
dup parameters>>
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel arrays sequences math math.order
|
||||
USING: accessors kernel arrays sequences math math.order call
|
||||
math.partial-dispatch generic generic.standard generic.math
|
||||
classes.algebra classes.union sets quotations assocs combinators
|
||||
words namespaces continuations classes fry combinators.smart
|
||||
|
|
@ -181,8 +181,9 @@ SYMBOL: history
|
|||
"custom-inlining" word-prop ;
|
||||
|
||||
: inline-custom ( #call word -- ? )
|
||||
[ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
|
||||
first object swap eliminate-dispatch ;
|
||||
[ dup ] [ "custom-inlining" word-prop ] bi*
|
||||
call( #call -- word/quot/f )
|
||||
object swap eliminate-dispatch ;
|
||||
|
||||
: inline-instance-check ( #call word -- ? )
|
||||
over in-d>> second value-info literal>> dup class?
|
||||
|
|
|
|||
|
|
@ -24,4 +24,4 @@ IN: compiler.utilities
|
|||
|
||||
SYMBOL: yield-hook
|
||||
|
||||
yield-hook global [ [ ] or ] change-at
|
||||
yield-hook [ [ ] ] initialize
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,4 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors tools.test compression.lzw ;
|
||||
IN: compression.lzw.tests
|
||||
|
|
@ -0,0 +1,204 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs bitstreams byte-vectors combinators io
|
||||
io.encodings.binary io.streams.byte-array kernel math sequences
|
||||
vectors ;
|
||||
IN: compression.lzw
|
||||
|
||||
CONSTANT: clear-code 256
|
||||
CONSTANT: end-of-information 257
|
||||
|
||||
TUPLE: lzw input output end-of-input? table count k omega omega-k #bits
|
||||
code old-code ;
|
||||
|
||||
SYMBOL: table-full
|
||||
|
||||
ERROR: index-too-big n ;
|
||||
|
||||
: lzw-bit-width ( n -- n' )
|
||||
{
|
||||
{ [ dup 510 <= ] [ drop 9 ] }
|
||||
{ [ dup 1022 <= ] [ drop 10 ] }
|
||||
{ [ dup 2046 <= ] [ drop 11 ] }
|
||||
{ [ dup 4094 <= ] [ drop 12 ] }
|
||||
[ drop table-full ]
|
||||
} cond ;
|
||||
|
||||
: lzw-bit-width-compress ( lzw -- n )
|
||||
count>> lzw-bit-width ;
|
||||
|
||||
: lzw-bit-width-uncompress ( lzw -- n )
|
||||
table>> length lzw-bit-width ;
|
||||
|
||||
: initial-compress-table ( -- assoc )
|
||||
258 iota [ [ 1vector ] keep ] H{ } map>assoc ;
|
||||
|
||||
: initial-uncompress-table ( -- seq )
|
||||
258 iota [ 1vector ] V{ } map-as ;
|
||||
|
||||
: reset-lzw ( lzw -- lzw )
|
||||
257 >>count
|
||||
V{ } clone >>omega
|
||||
V{ } clone >>omega-k
|
||||
9 >>#bits ;
|
||||
|
||||
: reset-lzw-compress ( lzw -- lzw )
|
||||
f >>k
|
||||
initial-compress-table >>table reset-lzw ;
|
||||
|
||||
: reset-lzw-uncompress ( lzw -- lzw )
|
||||
initial-uncompress-table >>table reset-lzw ;
|
||||
|
||||
: <lzw-compress> ( input -- obj )
|
||||
lzw new
|
||||
swap >>input
|
||||
binary <byte-writer> <bitstream-writer> >>output
|
||||
reset-lzw-compress ;
|
||||
|
||||
: <lzw-uncompress> ( input -- obj )
|
||||
lzw new
|
||||
swap >>input
|
||||
BV{ } clone >>output
|
||||
reset-lzw-uncompress ;
|
||||
|
||||
: push-k ( lzw -- lzw )
|
||||
[ ]
|
||||
[ k>> ]
|
||||
[ omega>> clone [ push ] keep ] tri >>omega-k ;
|
||||
|
||||
: omega-k-in-table? ( lzw -- ? )
|
||||
[ omega-k>> ] [ table>> ] bi key? ;
|
||||
|
||||
ERROR: not-in-table ;
|
||||
|
||||
: write-output ( lzw -- )
|
||||
[
|
||||
[ omega>> ] [ table>> ] bi at* [ not-in-table ] unless
|
||||
] [
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] bi
|
||||
] bi ;
|
||||
|
||||
: omega-k>omega ( lzw -- lzw )
|
||||
dup omega-k>> clone >>omega ;
|
||||
|
||||
: k>omega ( lzw -- lzw )
|
||||
dup k>> 1vector >>omega ;
|
||||
|
||||
: add-omega-k ( lzw -- )
|
||||
[ [ 1+ ] change-count count>> ]
|
||||
[ omega-k>> clone ]
|
||||
[ table>> ] tri set-at ;
|
||||
|
||||
: lzw-compress-char ( lzw k -- )
|
||||
>>k push-k dup omega-k-in-table? [
|
||||
omega-k>omega drop
|
||||
] [
|
||||
[ write-output ]
|
||||
[ add-omega-k ]
|
||||
[ k>omega drop ] tri
|
||||
] if ;
|
||||
|
||||
: (lzw-compress-chars) ( lzw -- )
|
||||
dup lzw-bit-width-compress table-full = [
|
||||
drop
|
||||
] [
|
||||
dup input>> stream-read1
|
||||
[ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ]
|
||||
[ t >>end-of-input? drop ] if*
|
||||
] if ;
|
||||
|
||||
: lzw-compress-chars ( lzw -- )
|
||||
{
|
||||
! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ]
|
||||
[
|
||||
[ clear-code ] dip
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] bi
|
||||
]
|
||||
[ (lzw-compress-chars) ]
|
||||
[
|
||||
[ k>> ]
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] tri
|
||||
]
|
||||
[
|
||||
[ end-of-information ] dip
|
||||
[ lzw-bit-width-compress ]
|
||||
[ output>> write-bits ] bi
|
||||
]
|
||||
[ ]
|
||||
} cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
|
||||
|
||||
: lzw-compress ( byte-array -- seq )
|
||||
binary <byte-reader> <lzw-compress>
|
||||
[ lzw-compress-chars ] [ output>> stream>> ] bi ;
|
||||
|
||||
: lookup-old-code ( lzw -- vector )
|
||||
[ old-code>> ] [ table>> ] bi nth ;
|
||||
|
||||
: lookup-code ( lzw -- vector )
|
||||
[ code>> ] [ table>> ] bi nth ;
|
||||
|
||||
: code-in-table? ( lzw -- ? )
|
||||
[ code>> ] [ table>> length ] bi < ;
|
||||
|
||||
: code>old-code ( lzw -- lzw )
|
||||
dup code>> >>old-code ;
|
||||
|
||||
: write-code ( lzw -- )
|
||||
[ lookup-code ] [ output>> ] bi push-all ;
|
||||
|
||||
: add-to-table ( seq lzw -- ) table>> push ;
|
||||
|
||||
: lzw-read ( lzw -- lzw n )
|
||||
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
|
||||
|
||||
DEFER: lzw-uncompress-char
|
||||
: handle-clear-code ( lzw -- )
|
||||
reset-lzw-uncompress
|
||||
lzw-read dup end-of-information = [
|
||||
2drop
|
||||
] [
|
||||
>>code
|
||||
[ write-code ]
|
||||
[ code>old-code ] bi
|
||||
lzw-uncompress-char
|
||||
] if ;
|
||||
|
||||
: handle-uncompress-code ( lzw -- lzw )
|
||||
dup code-in-table? [
|
||||
[ write-code ]
|
||||
[
|
||||
[
|
||||
[ lookup-old-code ]
|
||||
[ lookup-code first ] bi suffix
|
||||
] [ add-to-table ] bi
|
||||
] [ code>old-code ] tri
|
||||
] [
|
||||
[
|
||||
[ lookup-old-code dup first suffix ] keep
|
||||
[ output>> push-all ] [ add-to-table ] 2bi
|
||||
] [ code>old-code ] bi
|
||||
] if ;
|
||||
|
||||
: lzw-uncompress-char ( lzw -- )
|
||||
lzw-read [
|
||||
>>code
|
||||
dup code>> end-of-information = [
|
||||
drop
|
||||
] [
|
||||
dup code>> clear-code = [
|
||||
handle-clear-code
|
||||
] [
|
||||
handle-uncompress-code
|
||||
lzw-uncompress-char
|
||||
] if
|
||||
] if
|
||||
] [
|
||||
drop
|
||||
] if* ;
|
||||
|
||||
: lzw-uncompress ( seq -- byte-array )
|
||||
binary <byte-reader> <bitstream-reader>
|
||||
<lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax combinators system ;
|
||||
IN: zlib.ffi
|
||||
IN: compression.zlib.ffi
|
||||
|
||||
<< "zlib" {
|
||||
{ [ os winnt? ] [ "zlib1.dll" ] }
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel tools.test zlib classes ;
|
||||
IN: zlib.tests
|
||||
USING: kernel tools.test compression.zlib classes ;
|
||||
IN: compression.zlib.tests
|
||||
|
||||
: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
|
||||
|
||||
|
|
@ -3,8 +3,8 @@
|
|||
USING: alien alien.c-types alien.syntax byte-arrays combinators
|
||||
kernel math math.functions sequences system accessors
|
||||
libc ;
|
||||
QUALIFIED: zlib.ffi
|
||||
IN: zlib
|
||||
QUALIFIED: compression.zlib.ffi
|
||||
IN: compression.zlib
|
||||
|
||||
TUPLE: compressed data length ;
|
||||
|
||||
|
|
@ -16,7 +16,7 @@ TUPLE: compressed data length ;
|
|||
ERROR: zlib-failed n string ;
|
||||
|
||||
: zlib-error-message ( n -- * )
|
||||
dup zlib.ffi:Z_ERRNO = [
|
||||
dup compression.zlib.ffi:Z_ERRNO = [
|
||||
drop errno "native libc error"
|
||||
] [
|
||||
dup {
|
||||
|
|
@ -27,7 +27,7 @@ ERROR: zlib-failed n string ;
|
|||
] if zlib-failed ;
|
||||
|
||||
: zlib-error ( n -- )
|
||||
dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
|
||||
dup compression.zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
|
||||
|
||||
: compressed-size ( byte-array -- n )
|
||||
length 1001/1000 * ceiling 12 + ;
|
||||
|
|
@ -35,7 +35,7 @@ ERROR: zlib-failed n string ;
|
|||
: compress ( byte-array -- compressed )
|
||||
[
|
||||
[ compressed-size <byte-array> dup length <ulong> ] keep [
|
||||
dup length zlib.ffi:compress zlib-error
|
||||
dup length compression.zlib.ffi:compress zlib-error
|
||||
] 3keep drop *ulong head
|
||||
] keep length <compressed> ;
|
||||
|
||||
|
|
@ -44,5 +44,5 @@ ERROR: zlib-failed n string ;
|
|||
length>> [ <byte-array> ] keep <ulong> 2dup
|
||||
] [
|
||||
data>> dup length
|
||||
zlib.ffi:uncompress zlib-error
|
||||
compression.zlib.ffi:uncompress zlib-error
|
||||
] bi *ulong head ;
|
||||
|
|
@ -85,4 +85,4 @@ PRIVATE>
|
|||
: get-process ( name -- process )
|
||||
dup registered-processes at [ ] [ thread ] ?if ;
|
||||
|
||||
\ registered-processes global [ H{ } assoc-like ] change-at
|
||||
\ registered-processes [ H{ } clone ] initialize
|
||||
|
|
|
|||
|
|
@ -152,7 +152,7 @@ HOOK: %loop-entry cpu ( -- )
|
|||
HOOK: small-enough? cpu ( n -- ? )
|
||||
|
||||
! Is this structure small enough to be returned in registers?
|
||||
HOOK: struct-small-enough? cpu ( c-type -- ? )
|
||||
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
|
||||
|
||||
! Do we pass this struct by value or hidden reference?
|
||||
HOOK: value-struct? cpu ( c-type -- ? )
|
||||
|
|
|
|||
|
|
@ -659,7 +659,7 @@ M: ppc %callback-value ( ctype -- )
|
|||
|
||||
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
|
||||
|
||||
M: ppc struct-small-enough? ( size -- ? ) drop f ;
|
||||
M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
|
||||
|
||||
M: ppc %box-small-struct
|
||||
drop "No small structs" throw ;
|
||||
|
|
|
|||
|
|
@ -48,9 +48,12 @@ M: x86.32 %alien-invoke (CALL) rel-dlsym ;
|
|||
|
||||
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
|
||||
|
||||
M: x86.32 struct-small-enough? ( size -- ? )
|
||||
heap-size { 1 2 4 8 } member?
|
||||
os { linux netbsd solaris } member? not and ;
|
||||
M: x86.32 return-struct-in-registers? ( c-type -- ? )
|
||||
c-type
|
||||
[ return-in-registers?>> ]
|
||||
[ heap-size { 1 2 4 8 } member? ] bi
|
||||
os { linux netbsd solaris } member? not
|
||||
and or ;
|
||||
|
||||
: struct-return@ ( n -- operand )
|
||||
[ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@ M: struct-type flatten-value-type ( type -- seq )
|
|||
flatten-small-struct
|
||||
] if ;
|
||||
|
||||
M: x86.64 struct-small-enough? ( size -- ? )
|
||||
M: x86.64 return-struct-in-registers? ( c-type -- ? )
|
||||
heap-size 2 cells <= ;
|
||||
|
||||
M: x86.64 dummy-stack-params? f ;
|
||||
|
|
|
|||
|
|
@ -10,7 +10,8 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
|
|||
|
||||
M: x86.64 reserved-area-size 4 cells ;
|
||||
|
||||
M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ;
|
||||
M: x86.64 return-struct-in-registers? ( c-type -- ? )
|
||||
heap-size { 1 2 4 8 } member? ;
|
||||
|
||||
M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,11 @@
|
|||
USING: io.streams.string csv tools.test shuffle kernel strings
|
||||
USING: io.streams.string csv tools.test kernel strings
|
||||
io.pathnames io.files.unique io.encodings.utf8 io.files
|
||||
io.directories ;
|
||||
IN: csv.tests
|
||||
|
||||
! I like to name my unit tests
|
||||
: named-unit-test ( name output input -- )
|
||||
nipd unit-test ; inline
|
||||
|
||||
! tests nicked from the wikipedia csv article
|
||||
! http://en.wikipedia.org/wiki/Comma-separated_values
|
||||
unit-test drop ; inline
|
||||
|
||||
"Fields are separated by commas"
|
||||
[ { { "1997" "Ford" "E350" } } ]
|
||||
|
|
@ -90,3 +87,5 @@ IN: csv.tests
|
|||
{ { "writing,some,csv,tests" } } dup "csv-test2-"
|
||||
unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
|
||||
] unit-test
|
||||
|
||||
[ { { "hello" "" "" "" "goodbye" "" } } ] [ "hello,,\"\",,goodbye," <string-reader> csv ] unit-test
|
||||
|
|
|
|||
|
|
@ -46,13 +46,15 @@ DEFER: quoted-field ( -- endchar )
|
|||
|
||||
: (row) ( -- sep )
|
||||
field ,
|
||||
dup delimiter get = [ drop (row) ] when ;
|
||||
dup delimiter> = [ drop (row) ] when ;
|
||||
|
||||
: row ( -- eof? array[string] )
|
||||
[ (row) ] { } make ;
|
||||
|
||||
: (csv) ( -- )
|
||||
row harvest [ , ] unless-empty [ (csv) ] when ;
|
||||
row
|
||||
dup [ empty? ] all? [ drop ] [ , ] if
|
||||
[ (csv) ] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -60,7 +62,8 @@ PRIVATE>
|
|||
[ row nip ] with-input-stream ;
|
||||
|
||||
: csv ( stream -- rows )
|
||||
[ [ (csv) ] { } make ] with-input-stream ;
|
||||
[ [ (csv) ] { } make ] with-input-stream
|
||||
dup peek { "" } = [ but-last ] when ;
|
||||
|
||||
: file>csv ( path encoding -- csv )
|
||||
<file-reader> csv ;
|
||||
|
|
|
|||
|
|
@ -11,46 +11,46 @@ IN: db.postgresql.ffi
|
|||
} cond "cdecl" add-library >>
|
||||
|
||||
! ConnSatusType
|
||||
: CONNECTION_OK HEX: 0 ; inline
|
||||
: CONNECTION_BAD HEX: 1 ; inline
|
||||
: CONNECTION_STARTED HEX: 2 ; inline
|
||||
: CONNECTION_MADE HEX: 3 ; inline
|
||||
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
|
||||
: CONNECTION_AUTH_OK HEX: 5 ; inline
|
||||
: CONNECTION_SETENV HEX: 6 ; inline
|
||||
: CONNECTION_SSL_STARTUP HEX: 7 ; inline
|
||||
: CONNECTION_NEEDED HEX: 8 ; inline
|
||||
CONSTANT: CONNECTION_OK HEX: 0
|
||||
CONSTANT: CONNECTION_BAD HEX: 1
|
||||
CONSTANT: CONNECTION_STARTED HEX: 2
|
||||
CONSTANT: CONNECTION_MADE HEX: 3
|
||||
CONSTANT: CONNECTION_AWAITING_RESPONSE HEX: 4
|
||||
CONSTANT: CONNECTION_AUTH_OK HEX: 5
|
||||
CONSTANT: CONNECTION_SETENV HEX: 6
|
||||
CONSTANT: CONNECTION_SSL_STARTUP HEX: 7
|
||||
CONSTANT: CONNECTION_NEEDED HEX: 8
|
||||
|
||||
! PostgresPollingStatusType
|
||||
: PGRES_POLLING_FAILED HEX: 0 ; inline
|
||||
: PGRES_POLLING_READING HEX: 1 ; inline
|
||||
: PGRES_POLLING_WRITING HEX: 2 ; inline
|
||||
: PGRES_POLLING_OK HEX: 3 ; inline
|
||||
: PGRES_POLLING_ACTIVE HEX: 4 ; inline
|
||||
CONSTANT: PGRES_POLLING_FAILED HEX: 0
|
||||
CONSTANT: PGRES_POLLING_READING HEX: 1
|
||||
CONSTANT: PGRES_POLLING_WRITING HEX: 2
|
||||
CONSTANT: PGRES_POLLING_OK HEX: 3
|
||||
CONSTANT: PGRES_POLLING_ACTIVE HEX: 4
|
||||
|
||||
! ExecStatusType;
|
||||
: PGRES_EMPTY_QUERY HEX: 0 ; inline
|
||||
: PGRES_COMMAND_OK HEX: 1 ; inline
|
||||
: PGRES_TUPLES_OK HEX: 2 ; inline
|
||||
: PGRES_COPY_OUT HEX: 3 ; inline
|
||||
: PGRES_COPY_IN HEX: 4 ; inline
|
||||
: PGRES_BAD_RESPONSE HEX: 5 ; inline
|
||||
: PGRES_NONFATAL_ERROR HEX: 6 ; inline
|
||||
: PGRES_FATAL_ERROR HEX: 7 ; inline
|
||||
CONSTANT: PGRES_EMPTY_QUERY HEX: 0
|
||||
CONSTANT: PGRES_COMMAND_OK HEX: 1
|
||||
CONSTANT: PGRES_TUPLES_OK HEX: 2
|
||||
CONSTANT: PGRES_COPY_OUT HEX: 3
|
||||
CONSTANT: PGRES_COPY_IN HEX: 4
|
||||
CONSTANT: PGRES_BAD_RESPONSE HEX: 5
|
||||
CONSTANT: PGRES_NONFATAL_ERROR HEX: 6
|
||||
CONSTANT: PGRES_FATAL_ERROR HEX: 7
|
||||
|
||||
! PGTransactionStatusType;
|
||||
: PQTRANS_IDLE HEX: 0 ; inline
|
||||
: PQTRANS_ACTIVE HEX: 1 ; inline
|
||||
: PQTRANS_INTRANS HEX: 2 ; inline
|
||||
: PQTRANS_INERROR HEX: 3 ; inline
|
||||
: PQTRANS_UNKNOWN HEX: 4 ; inline
|
||||
CONSTANT: PQTRANS_IDLE HEX: 0
|
||||
CONSTANT: PQTRANS_ACTIVE HEX: 1
|
||||
CONSTANT: PQTRANS_INTRANS HEX: 2
|
||||
CONSTANT: PQTRANS_INERROR HEX: 3
|
||||
CONSTANT: PQTRANS_UNKNOWN HEX: 4
|
||||
|
||||
! PGVerbosity;
|
||||
: PQERRORS_TERSE HEX: 0 ; inline
|
||||
: PQERRORS_DEFAULT HEX: 1 ; inline
|
||||
: PQERRORS_VERBOSE HEX: 2 ; inline
|
||||
CONSTANT: PQERRORS_TERSE HEX: 0
|
||||
CONSTANT: PQERRORS_DEFAULT HEX: 1
|
||||
CONSTANT: PQERRORS_VERBOSE HEX: 2
|
||||
|
||||
: InvalidOid 0 ; inline
|
||||
CONSTANT: InvalidOid 0
|
||||
|
||||
TYPEDEF: int ConnStatusType
|
||||
TYPEDEF: int ExecStatusType
|
||||
|
|
@ -348,21 +348,21 @@ FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
|
|||
FUNCTION: int PQenv2encoding ( ) ;
|
||||
|
||||
! From git, include/catalog/pg_type.h
|
||||
: BOOL-OID 16 ; inline
|
||||
: BYTEA-OID 17 ; inline
|
||||
: CHAR-OID 18 ; inline
|
||||
: NAME-OID 19 ; inline
|
||||
: INT8-OID 20 ; inline
|
||||
: INT2-OID 21 ; inline
|
||||
: INT4-OID 23 ; inline
|
||||
: TEXT-OID 23 ; inline
|
||||
: OID-OID 26 ; inline
|
||||
: FLOAT4-OID 700 ; inline
|
||||
: FLOAT8-OID 701 ; inline
|
||||
: VARCHAR-OID 1043 ; inline
|
||||
: DATE-OID 1082 ; inline
|
||||
: TIME-OID 1083 ; inline
|
||||
: TIMESTAMP-OID 1114 ; inline
|
||||
: TIMESTAMPTZ-OID 1184 ; inline
|
||||
: INTERVAL-OID 1186 ; inline
|
||||
: NUMERIC-OID 1700 ; inline
|
||||
CONSTANT: BOOL-OID 16
|
||||
CONSTANT: BYTEA-OID 17
|
||||
CONSTANT: CHAR-OID 18
|
||||
CONSTANT: NAME-OID 19
|
||||
CONSTANT: INT8-OID 20
|
||||
CONSTANT: INT2-OID 21
|
||||
CONSTANT: INT4-OID 23
|
||||
CONSTANT: TEXT-OID 23
|
||||
CONSTANT: OID-OID 26
|
||||
CONSTANT: FLOAT4-OID 700
|
||||
CONSTANT: FLOAT8-OID 701
|
||||
CONSTANT: VARCHAR-OID 1043
|
||||
CONSTANT: DATE-OID 1082
|
||||
CONSTANT: TIME-OID 1083
|
||||
CONSTANT: TIMESTAMP-OID 1114
|
||||
CONSTANT: TIMESTAMPTZ-OID 1184
|
||||
CONSTANT: INTERVAL-OID 1186
|
||||
CONSTANT: NUMERIC-OID 1700
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: arrays continuations db io kernel math namespaces
|
||||
quotations sequences db.postgresql.ffi alien alien.c-types
|
||||
db.types tools.walker ascii splitting math.parser combinators
|
||||
libc shuffle calendar.format byte-arrays destructors prettyprint
|
||||
libc calendar.format byte-arrays destructors prettyprint
|
||||
accessors strings serialize io.encodings.binary io.encodings.utf8
|
||||
alien.strings io.streams.byte-array summary present urls
|
||||
specialized-arrays.uint specialized-arrays.alien db.private ;
|
||||
|
|
@ -117,7 +117,7 @@ M: postgresql-result-null summary ( obj -- str )
|
|||
|
||||
: pq-get-string ( handle row column -- obj )
|
||||
3dup PQgetvalue utf8 alien>string
|
||||
dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ;
|
||||
dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ;
|
||||
|
||||
: pq-get-number ( handle row column -- obj )
|
||||
pq-get-string dup [ string>number ] when ;
|
||||
|
|
@ -134,7 +134,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
|
|||
: pq-get-blob ( handle row column -- obj/f )
|
||||
[ PQgetvalue ] 3keep 3dup PQgetlength
|
||||
dup 0 > [
|
||||
3nip
|
||||
[ 3drop ] dip
|
||||
[
|
||||
memory>byte-array >string
|
||||
0 <uint>
|
||||
|
|
|
|||
|
|
@ -44,11 +44,11 @@ M: retryable execute-statement* ( statement type -- )
|
|||
] bi attempt-all drop ;
|
||||
|
||||
: sql-props ( class -- columns table )
|
||||
[ db-columns ] [ db-table ] bi ;
|
||||
[ db-columns ] [ db-table-name ] bi ;
|
||||
|
||||
: query-make ( class quot -- statements )
|
||||
#! query, input, outputs, secondary queries
|
||||
over unparse "table" set
|
||||
over db-table-name "table-name" set
|
||||
[ sql-props ] dip
|
||||
[ 0 sql-counter rot with-variable ] curry
|
||||
{ "" { } { } { } } nmake
|
||||
|
|
|
|||
|
|
@ -13,33 +13,33 @@ IN: db.sqlite.ffi
|
|||
} cond "cdecl" add-library >>
|
||||
|
||||
! Return values from sqlite functions
|
||||
: SQLITE_OK 0 ; inline ! Successful result
|
||||
: SQLITE_ERROR 1 ; inline ! SQL error or missing database
|
||||
: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
|
||||
: SQLITE_PERM 3 ; inline ! Access permission denied
|
||||
: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
|
||||
: SQLITE_BUSY 5 ; inline ! The database file is locked
|
||||
: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
|
||||
: SQLITE_NOMEM 7 ; inline ! A malloc() failed
|
||||
: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
|
||||
: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
|
||||
: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
|
||||
: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
|
||||
: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
|
||||
: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
|
||||
: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
|
||||
: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
|
||||
: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
|
||||
: SQLITE_SCHEMA 17 ; inline ! The database schema changed
|
||||
: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
|
||||
: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
|
||||
: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
|
||||
: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
|
||||
: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
|
||||
: SQLITE_AUTH 23 ; inline ! Authorization denied
|
||||
: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
|
||||
: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
|
||||
: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
|
||||
CONSTANT: SQLITE_OK 0 ! Successful result
|
||||
CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database
|
||||
CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite
|
||||
CONSTANT: SQLITE_PERM 3 ! Access permission denied
|
||||
CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort
|
||||
CONSTANT: SQLITE_BUSY 5 ! The database file is locked
|
||||
CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked
|
||||
CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed
|
||||
CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database
|
||||
CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt()
|
||||
CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred
|
||||
CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed
|
||||
CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found
|
||||
CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full
|
||||
CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file
|
||||
CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error
|
||||
CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty
|
||||
CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed
|
||||
CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table
|
||||
CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation
|
||||
CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch
|
||||
CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly
|
||||
CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host
|
||||
CONSTANT: SQLITE_AUTH 23 ! Authorization denied
|
||||
CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error
|
||||
CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range
|
||||
CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file
|
||||
|
||||
: sqlite-error-messages ( -- seq ) {
|
||||
"Successful result"
|
||||
|
|
@ -72,32 +72,32 @@ IN: db.sqlite.ffi
|
|||
} ;
|
||||
|
||||
! Return values from sqlite3_step
|
||||
: SQLITE_ROW 100 ; inline
|
||||
: SQLITE_DONE 101 ; inline
|
||||
CONSTANT: SQLITE_ROW 100
|
||||
CONSTANT: SQLITE_DONE 101
|
||||
|
||||
! Return values from the sqlite3_column_type function
|
||||
: SQLITE_INTEGER 1 ; inline
|
||||
: SQLITE_FLOAT 2 ; inline
|
||||
: SQLITE_TEXT 3 ; inline
|
||||
: SQLITE_BLOB 4 ; inline
|
||||
: SQLITE_NULL 5 ; inline
|
||||
CONSTANT: SQLITE_INTEGER 1
|
||||
CONSTANT: SQLITE_FLOAT 2
|
||||
CONSTANT: SQLITE_TEXT 3
|
||||
CONSTANT: SQLITE_BLOB 4
|
||||
CONSTANT: SQLITE_NULL 5
|
||||
|
||||
! Values for the 'destructor' parameter of the 'bind' routines.
|
||||
: SQLITE_STATIC 0 ; inline
|
||||
: SQLITE_TRANSIENT -1 ; inline
|
||||
CONSTANT: SQLITE_STATIC 0
|
||||
CONSTANT: SQLITE_TRANSIENT -1
|
||||
|
||||
: SQLITE_OPEN_READONLY HEX: 00000001 ; inline
|
||||
: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline
|
||||
: SQLITE_OPEN_CREATE HEX: 00000004 ; inline
|
||||
: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline
|
||||
: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline
|
||||
: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline
|
||||
: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline
|
||||
: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline
|
||||
: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline
|
||||
: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline
|
||||
: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline
|
||||
: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline
|
||||
CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001
|
||||
CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002
|
||||
CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004
|
||||
CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008
|
||||
CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010
|
||||
CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100
|
||||
CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200
|
||||
CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400
|
||||
CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800
|
||||
CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
|
||||
CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
|
||||
CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
|
||||
|
||||
TYPEDEF: void sqlite3
|
||||
TYPEDEF: void sqlite3_stmt
|
||||
|
|
|
|||
|
|
@ -73,3 +73,95 @@ IN: db.sqlite.tests
|
|||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
! You don't need a primary key
|
||||
USING: accessors arrays sorting ;
|
||||
TUPLE: things one two ;
|
||||
|
||||
things "THINGS" {
|
||||
{ "one" "ONE" INTEGER +not-null+ }
|
||||
{ "two" "TWO" INTEGER +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
[ { { 0 0 } { 0 1 } { 1 0 } { 1 1 } } ] [
|
||||
test.db [
|
||||
things create-table
|
||||
0 0 things boa insert-tuple
|
||||
0 1 things boa insert-tuple
|
||||
1 1 things boa insert-tuple
|
||||
1 0 things boa insert-tuple
|
||||
f f things boa select-tuples
|
||||
[ [ one>> ] [ two>> ] bi 2array ] map natural-sort
|
||||
things drop-table
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
! Tables can have different names than the name of the tuple
|
||||
TUPLE: foo slot ;
|
||||
C: <foo> foo
|
||||
foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent
|
||||
|
||||
TUPLE: hi bye try ;
|
||||
C: <hi> hi
|
||||
hi "HELLO" {
|
||||
{ "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } }
|
||||
{ "try" "RETHROW" INTEGER { +foreign-id+ foo "SOMETHING" } }
|
||||
} define-persistent
|
||||
|
||||
[ T{ foo { slot 1 } } T{ hi { bye 1 } { try 1 } } ] [
|
||||
test.db [
|
||||
foo create-table
|
||||
hi create-table
|
||||
1 <foo> insert-tuple
|
||||
f <foo> select-tuple
|
||||
1 1 <hi> insert-tuple
|
||||
f <hi> select-tuple
|
||||
hi drop-table
|
||||
foo drop-table
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
test.db [
|
||||
hi create-table
|
||||
hi drop-table
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
TUPLE: show id ;
|
||||
TUPLE: user username data ;
|
||||
TUPLE: watch show user ;
|
||||
|
||||
user "USER" {
|
||||
{ "username" "USERNAME" TEXT +not-null+ +user-assigned-id+ }
|
||||
{ "data" "DATA" TEXT }
|
||||
} define-persistent
|
||||
|
||||
show "SHOW" {
|
||||
{ "id" "ID" +db-assigned-id+ }
|
||||
} define-persistent
|
||||
|
||||
watch "WATCH" {
|
||||
{ "user" "USER" TEXT +not-null+
|
||||
{ +foreign-id+ user "USERNAME" } +user-assigned-id+ }
|
||||
{ "show" "SHOW" BIG-INTEGER +not-null+
|
||||
{ +foreign-id+ show "ID" } +user-assigned-id+ }
|
||||
} define-persistent
|
||||
|
||||
[ T{ user { username "littledan" } { data "foo" } } ] [
|
||||
test.db [
|
||||
user create-table
|
||||
show create-table
|
||||
watch create-table
|
||||
"littledan" "foo" user boa insert-tuple
|
||||
"mark" "bar" user boa insert-tuple
|
||||
show new insert-tuple
|
||||
show new select-tuple
|
||||
"littledan" f user boa select-tuple
|
||||
watch boa insert-tuple
|
||||
watch new select-tuple
|
||||
user>> f user boa select-tuple
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ \ swap ensure-table ] must-fail
|
||||
|
|
|
|||
|
|
@ -138,11 +138,13 @@ M: sqlite-db-connection create-sql-statement ( class -- statement )
|
|||
modifiers 0%
|
||||
] interleave
|
||||
|
||||
", " 0%
|
||||
find-primary-key
|
||||
"primary key(" 0%
|
||||
[ "," 0% ] [ column-name>> 0% ] interleave
|
||||
"));" 0%
|
||||
find-primary-key [
|
||||
", " 0%
|
||||
"primary key(" 0%
|
||||
[ "," 0% ] [ column-name>> 0% ] interleave
|
||||
")" 0%
|
||||
] unless-empty
|
||||
");" 0%
|
||||
] query-make ;
|
||||
|
||||
M: sqlite-db-connection drop-sql-statement ( class -- statement )
|
||||
|
|
@ -223,11 +225,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: insert-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fki_${table}_${foreign-table}_id
|
||||
BEFORE INSERT ON ${table}
|
||||
CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
|
||||
BEFORE INSERT ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -235,12 +237,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: insert-trigger-not-null ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fki_${table}_${foreign-table}_id
|
||||
BEFORE INSERT ON ${table}
|
||||
CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
|
||||
BEFORE INSERT ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE NEW.${foreign-table-id} IS NOT NULL
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -248,11 +250,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: update-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fku_${table}_${foreign-table}_id
|
||||
BEFORE UPDATE ON ${table}
|
||||
CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
|
||||
BEFORE UPDATE ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -260,12 +262,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: update-trigger-not-null ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fku_${table}_${foreign-table}_id
|
||||
BEFORE UPDATE ON ${table}
|
||||
CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
|
||||
BEFORE UPDATE ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE NEW.${foreign-table-id} IS NOT NULL
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -273,11 +275,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: delete-trigger-restrict ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fkd_${table}_${foreign-table}_id
|
||||
BEFORE DELETE ON ${foreign-table}
|
||||
CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
|
||||
BEFORE DELETE ON ${foreign-table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
|
||||
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -285,10 +287,10 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: delete-trigger-cascade ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fkd_${table}_${foreign-table}_id
|
||||
BEFORE DELETE ON ${foreign-table}
|
||||
CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
|
||||
BEFORE DELETE ON ${foreign-table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
|
||||
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -321,7 +323,7 @@ M: sqlite-db-connection compound ( string seq -- new-string )
|
|||
{ "default" [ first number>string " " glue ] }
|
||||
{ "references" [
|
||||
[ >reference-string ] keep
|
||||
first2 [ "foreign-table" set ]
|
||||
first2 [ db-table-name "foreign-table-name" set ]
|
||||
[ "foreign-table-id" set ] bi*
|
||||
create-sqlite-triggers
|
||||
] }
|
||||
|
|
|
|||
|
|
@ -49,7 +49,7 @@ ERROR: no-slot ;
|
|||
|
||||
ERROR: not-persistent class ;
|
||||
|
||||
: db-table ( class -- object )
|
||||
: db-table-name ( class -- object )
|
||||
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
|
||||
|
||||
: db-columns ( class -- object )
|
||||
|
|
@ -165,7 +165,7 @@ ERROR: no-column column ;
|
|||
|
||||
: >reference-string ( string pair -- string )
|
||||
first2
|
||||
[ [ unparse " " glue ] [ db-columns ] bi ] dip
|
||||
[ [ db-table-name " " glue ] [ db-columns ] bi ] dip
|
||||
swap [ column-name>> = ] with find nip
|
||||
[ no-column ] unless*
|
||||
column-name>> "(" ")" surround append ;
|
||||
|
|
|
|||
|
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser lexer kernel namespaces sequences definitions
|
||||
io.files io.backend io.pathnames io summary continuations
|
||||
tools.crossref tools.vocabs prettyprint source-files assocs
|
||||
vocabs vocabs.loader splitting accessors ;
|
||||
vocabs vocabs.loader splitting accessors debugger prettyprint
|
||||
help.topics ;
|
||||
IN: editors
|
||||
|
||||
TUPLE: no-edit-hook ;
|
||||
|
|
@ -29,11 +30,21 @@ SYMBOL: edit-hook
|
|||
[ (normalize-path) ] dip edit-hook get-global
|
||||
[ call ] [ no-edit-hook edit-location ] if* ;
|
||||
|
||||
ERROR: cannot-find-source definition ;
|
||||
|
||||
M: cannot-find-source error.
|
||||
"Cannot find source for ``" write
|
||||
definition>> pprint-short
|
||||
"''" print ;
|
||||
|
||||
: edit ( defspec -- )
|
||||
where [ first2 edit-location ] when* ;
|
||||
dup where
|
||||
[ first2 edit-location ]
|
||||
[ dup word-link? [ name>> edit ] [ cannot-find-source ] if ]
|
||||
?if ;
|
||||
|
||||
: edit-vocab ( name -- )
|
||||
vocab-source-path 1 edit-location ;
|
||||
>vocab-link edit ;
|
||||
|
||||
GENERIC: error-file ( error -- file )
|
||||
|
||||
|
|
|
|||
|
|
@ -1,39 +1,39 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types namespaces io.binary fry
|
||||
kernel math ;
|
||||
kernel math grouping sequences ;
|
||||
IN: endian
|
||||
|
||||
SINGLETONS: big-endian little-endian ;
|
||||
|
||||
: native-endianness ( -- class )
|
||||
: compute-native-endianness ( -- class )
|
||||
1 <int> *char 0 = big-endian little-endian ? ;
|
||||
|
||||
: >signed ( x n -- y )
|
||||
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
|
||||
|
||||
native-endianness \ native-endianness set-global
|
||||
SYMBOL: native-endianness
|
||||
native-endianness [ compute-native-endianness ] initialize
|
||||
|
||||
SYMBOL: endianness
|
||||
endianness [ native-endianness get-global ] initialize
|
||||
|
||||
\ native-endianness get-global endianness set-global
|
||||
|
||||
HOOK: >native-endian native-endianness ( obj n -- str )
|
||||
HOOK: >native-endian native-endianness ( obj n -- bytes )
|
||||
|
||||
M: big-endian >native-endian >be ;
|
||||
|
||||
M: little-endian >native-endian >le ;
|
||||
|
||||
HOOK: unsigned-native-endian> native-endianness ( obj -- str )
|
||||
HOOK: unsigned-native-endian> native-endianness ( obj -- bytes )
|
||||
|
||||
M: big-endian unsigned-native-endian> be> ;
|
||||
|
||||
M: little-endian unsigned-native-endian> le> ;
|
||||
|
||||
: signed-native-endian> ( obj n -- str )
|
||||
: signed-native-endian> ( obj n -- n' )
|
||||
[ unsigned-native-endian> ] dip >signed ;
|
||||
|
||||
HOOK: >endian endianness ( obj n -- str )
|
||||
HOOK: >endian endianness ( obj n -- bytes )
|
||||
|
||||
M: big-endian >endian >be ;
|
||||
|
||||
|
|
@ -45,13 +45,13 @@ M: big-endian endian> be> ;
|
|||
|
||||
M: little-endian endian> le> ;
|
||||
|
||||
HOOK: unsigned-endian> endianness ( obj -- str )
|
||||
HOOK: unsigned-endian> endianness ( obj -- bytes )
|
||||
|
||||
M: big-endian unsigned-endian> be> ;
|
||||
|
||||
M: little-endian unsigned-endian> le> ;
|
||||
|
||||
: signed-endian> ( obj n -- str )
|
||||
: signed-endian> ( obj n -- bytes )
|
||||
[ unsigned-endian> ] dip >signed ;
|
||||
|
||||
: with-endianness ( endian quot -- )
|
||||
|
|
@ -65,3 +65,15 @@ M: little-endian unsigned-endian> le> ;
|
|||
|
||||
: with-native-endian ( quot -- )
|
||||
\ native-endianness get-global swap with-endianness ; inline
|
||||
|
||||
: seq>native-endianness ( seq n -- seq' )
|
||||
native-endianness get-global dup endianness get = [
|
||||
2drop
|
||||
] [
|
||||
[ [ <sliced-groups> ] keep ] dip
|
||||
little-endian = [
|
||||
'[ be> _ >le ] map
|
||||
] [
|
||||
'[ le> _ >be ] map
|
||||
] if concat
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -81,11 +81,18 @@ CHLOE: a
|
|||
CHLOE: base
|
||||
compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
|
||||
|
||||
: hidden-nested-fields ( -- xml )
|
||||
nested-forms get " " join f like nested-forms-key
|
||||
hidden-form-field ;
|
||||
|
||||
: render-hidden ( for -- xml )
|
||||
[ "," split [ hidden render>xml ] map ] [ f ] if* ;
|
||||
|
||||
: compile-hidden-form-fields ( for -- )
|
||||
'[
|
||||
_ [ "," split [ hidden render>xml ] map ] [ f ] if*
|
||||
nested-forms get " " join f like nested-forms-key hidden-form-field>xml
|
||||
[ [ modify-form ] each-responder ] with-string-writer <unescaped>
|
||||
_ render-hidden
|
||||
hidden-nested-fields
|
||||
form-modifications
|
||||
[XML <div style="display: none;"><-><-><-></div> XML]
|
||||
] [code] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
IN: furnace.tests
|
||||
USING: http http.server.dispatchers http.server.responses
|
||||
http.server furnace furnace.utilities tools.test kernel
|
||||
namespaces accessors io.streams.string urls ;
|
||||
namespaces accessors io.streams.string urls xml.writer ;
|
||||
TUPLE: funny-dispatcher < dispatcher ;
|
||||
|
||||
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
|
||||
|
|
@ -31,7 +31,7 @@ M: base-path-check-responder call-responder*
|
|||
] unit-test
|
||||
|
||||
[ "<input type=\"hidden\" value=\"&&&\" name=\"foo\"/>" ]
|
||||
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
|
||||
[ "&&&" "foo" hidden-form-field xml>string ]
|
||||
unit-test
|
||||
|
||||
[ f ] [ <request> request [ referrer ] with-variable ] unit-test
|
||||
|
|
|
|||
|
|
@ -20,13 +20,13 @@ HELP: each-responder
|
|||
{ $description "Applies the quotation to each responder involved in processing the current request." } ;
|
||||
|
||||
HELP: hidden-form-field
|
||||
{ $values { "value" string } { "name" string } }
|
||||
{ $description "Renders an HTML hidden form field tag." }
|
||||
{ $values { "value" string } { "name" string } { "xml" "an XML chunk" } }
|
||||
{ $description "Renders an HTML hidden form field tag as XML." }
|
||||
{ $notes "This word is used by session management, conversation scope and asides." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: furnace.utilities io ;"
|
||||
"\"bar\" \"foo\" hidden-form-field nl"
|
||||
"USING: furnace.utilities io xml.writer ;"
|
||||
"\"bar\" \"foo\" hidden-form-field write-xml nl"
|
||||
"<input type=\"hidden\" value=\"bar\" name=\"foo\"/>"
|
||||
}
|
||||
} ;
|
||||
|
|
@ -38,7 +38,7 @@ HELP: link-attr
|
|||
{ $examples "Conversation scope adds attributes to link tags." } ;
|
||||
|
||||
HELP: modify-form
|
||||
{ $values { "responder" "a responder" } }
|
||||
{ $values { "responder" "a responder" } { "xml/f" "an XML chunk or f" } }
|
||||
{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
|
||||
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
|
||||
{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
|
||||
|
|
|
|||
|
|
@ -77,18 +77,18 @@ GENERIC: link-attr ( tag responder -- )
|
|||
|
||||
M: object link-attr 2drop ;
|
||||
|
||||
GENERIC: modify-form ( responder -- )
|
||||
GENERIC: modify-form ( responder -- xml/f )
|
||||
|
||||
M: object modify-form drop ;
|
||||
M: object modify-form drop f ;
|
||||
|
||||
: hidden-form-field>xml ( value name -- xml )
|
||||
: form-modifications ( -- xml )
|
||||
[ [ modify-form [ , ] when* ] each-responder ] { } make ;
|
||||
|
||||
: hidden-form-field ( value name -- xml )
|
||||
over [
|
||||
[XML <input type="hidden" value=<-> name=<->/> XML]
|
||||
] [ drop ] if ;
|
||||
|
||||
: hidden-form-field ( value name -- )
|
||||
hidden-form-field>xml write-xml ;
|
||||
|
||||
: nested-forms-key "__n" ;
|
||||
|
||||
: request-params ( request -- assoc )
|
||||
|
|
|
|||
|
|
@ -30,6 +30,10 @@ HELP: narray
|
|||
|
||||
{ nsequence narray } related-words
|
||||
|
||||
HELP: nsum
|
||||
{ $values { "n" integer } }
|
||||
{ $description "Adds the top " { $snippet "n" } " stack values." } ;
|
||||
|
||||
HELP: firstn
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link first } ", "
|
||||
|
|
@ -54,7 +58,7 @@ HELP: npick
|
|||
"placed on the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
|
||||
{ $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" }
|
||||
"Some core words expressed in terms of " { $link npick } ":"
|
||||
{ $table
|
||||
{ { $link dup } { $snippet "1 npick" } }
|
||||
|
|
@ -71,7 +75,7 @@ HELP: ndup
|
|||
"placed on the top of the stack."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" }
|
||||
"Some core words expressed in terms of " { $link ndup } ":"
|
||||
{ $table
|
||||
{ { $link dup } { $snippet "1 ndup" } }
|
||||
|
|
@ -87,7 +91,7 @@ HELP: nnip
|
|||
"for any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" }
|
||||
"Some core words expressed in terms of " { $link nnip } ":"
|
||||
{ $table
|
||||
{ { $link nip } { $snippet "1 nnip" } }
|
||||
|
|
@ -102,7 +106,7 @@ HELP: ndrop
|
|||
"for any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" }
|
||||
"Some core words expressed in terms of " { $link ndrop } ":"
|
||||
{ $table
|
||||
{ { $link drop } { $snippet "1 ndrop" } }
|
||||
|
|
@ -117,7 +121,7 @@ HELP: nrot
|
|||
"number of items on the stack. "
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" }
|
||||
"Some core words expressed in terms of " { $link nrot } ":"
|
||||
{ $table
|
||||
{ { $link swap } { $snippet "1 nrot" } }
|
||||
|
|
@ -131,7 +135,7 @@ HELP: -nrot
|
|||
"number of items on the stack. "
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
|
||||
{ $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" }
|
||||
"Some core words expressed in terms of " { $link -nrot } ":"
|
||||
{ $table
|
||||
{ { $link swap } { $snippet "1 -nrot" } }
|
||||
|
|
@ -147,8 +151,8 @@ HELP: ndip
|
|||
"stack. The quotation can consume and produce any number of items."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
|
||||
{ $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" }
|
||||
{ $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" }
|
||||
"Some core words expressed in terms of " { $link ndip } ":"
|
||||
{ $table
|
||||
{ { $link dip } { $snippet "1 ndip" } }
|
||||
|
|
@ -164,7 +168,7 @@ HELP: nslip
|
|||
"removed from the stack, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" }
|
||||
"Some core words expressed in terms of " { $link nslip } ":"
|
||||
{ $table
|
||||
{ { $link slip } { $snippet "1 nslip" } }
|
||||
|
|
@ -180,7 +184,7 @@ HELP: nkeep
|
|||
"saved, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" }
|
||||
"Some core words expressed in terms of " { $link nkeep } ":"
|
||||
{ $table
|
||||
{ { $link keep } { $snippet "1 nkeep" } }
|
||||
|
|
@ -238,6 +242,11 @@ HELP: ncleave
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: nspread
|
||||
{ $values { "quots" "a sequence of quotations" } { "n" integer } }
|
||||
{ $description "A generalization of " { $link spread } " that can work for any quotation arity."
|
||||
} ;
|
||||
|
||||
HELP: mnswap
|
||||
{ $values { "m" integer } { "n" integer } }
|
||||
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
|
||||
|
|
@ -250,6 +259,17 @@ HELP: mnswap
|
|||
}
|
||||
} ;
|
||||
|
||||
HELP: nweave
|
||||
{ $values { "n" integer } }
|
||||
{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: arrays kernel generalizations prettyprint ;"
|
||||
"\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ."
|
||||
"{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }"
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: n*quot
|
||||
{ $values
|
||||
{ "n" integer } { "seq" sequence }
|
||||
|
|
@ -299,18 +319,14 @@ HELP: ntuck
|
|||
}
|
||||
{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;
|
||||
|
||||
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
|
||||
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
|
||||
"macros where the arity of the input quotations depends on an "
|
||||
"input parameter."
|
||||
$nl
|
||||
"Generalized sequence operations:"
|
||||
ARTICLE: "sequence-generalizations" "Generalized sequence operations"
|
||||
{ $subsection narray }
|
||||
{ $subsection nsequence }
|
||||
{ $subsection firstn }
|
||||
{ $subsection nappend }
|
||||
{ $subsection nappend-as }
|
||||
"Generated stack shuffle operations:"
|
||||
{ $subsection nappend-as } ;
|
||||
|
||||
ARTICLE: "shuffle-generalizations" "Generalized shuffle words"
|
||||
{ $subsection ndup }
|
||||
{ $subsection npick }
|
||||
{ $subsection nrot }
|
||||
|
|
@ -319,14 +335,28 @@ $nl
|
|||
{ $subsection ndrop }
|
||||
{ $subsection ntuck }
|
||||
{ $subsection mnswap }
|
||||
"Generalized combinators:"
|
||||
{ $subsection nweave } ;
|
||||
|
||||
ARTICLE: "combinator-generalizations" "Generalized combinators"
|
||||
{ $subsection ndip }
|
||||
{ $subsection nslip }
|
||||
{ $subsection nkeep }
|
||||
{ $subsection napply }
|
||||
{ $subsection ncleave }
|
||||
"Generalized quotation construction:"
|
||||
{ $subsection nspread } ;
|
||||
|
||||
ARTICLE: "other-generalizations" "Additional generalizations"
|
||||
{ $subsection ncurry }
|
||||
{ $subsection nwith } ;
|
||||
{ $subsection nwith }
|
||||
{ $subsection nsum } ;
|
||||
|
||||
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
|
||||
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
|
||||
"macros where the arity of the input quotations depends on an "
|
||||
"input parameter."
|
||||
{ $subsection "sequence-generalizations" }
|
||||
{ $subsection "shuffle-generalizations" }
|
||||
{ $subsection "combinator-generalizations" }
|
||||
{ $subsection "other-generalizations" } ;
|
||||
|
||||
ABOUT: "generalizations"
|
||||
|
|
|
|||
|
|
@ -53,3 +53,12 @@ IN: generalizations.tests
|
|||
|
||||
[ 4 nappend ] must-infer
|
||||
[ 4 { } nappend-as ] must-infer
|
||||
|
||||
[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test
|
||||
{ 4 1 } [ 4 nsum ] must-infer-as
|
||||
|
||||
[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test
|
||||
{ 3 5 } [ 2 nweave ] must-infer-as
|
||||
|
||||
[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]
|
||||
[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
|
||||
! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo
|
||||
! Cavazos, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel sequences sequences.private math combinators
|
||||
|
|
@ -23,6 +23,9 @@ MACRO: nsequence ( n seq -- )
|
|||
MACRO: narray ( n -- )
|
||||
'[ _ { } nsequence ] ;
|
||||
|
||||
MACRO: nsum ( n -- )
|
||||
1- [ + ] n*quot ;
|
||||
|
||||
MACRO: firstn ( n -- )
|
||||
dup zero? [ drop [ drop ] ] [
|
||||
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
|
||||
|
|
@ -70,11 +73,23 @@ MACRO: ncleave ( quots n -- )
|
|||
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
|
||||
compose ;
|
||||
|
||||
MACRO: nspread ( quots n -- )
|
||||
over empty? [ 2drop [ ] ] [
|
||||
[ [ but-last ] dip ]
|
||||
[ [ peek ] dip ] 2bi
|
||||
swap
|
||||
'[ [ _ _ nspread ] _ ndip @ ]
|
||||
] if ;
|
||||
|
||||
MACRO: napply ( quot n -- )
|
||||
swap <repetition> spread>quot ;
|
||||
|
||||
MACRO: mnswap ( m n -- )
|
||||
1+ '[ _ -nrot ] <repetition> spread>quot ;
|
||||
1+ '[ _ -nrot ] swap '[ _ _ napply ] ;
|
||||
|
||||
MACRO: nweave ( n -- )
|
||||
[ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
|
||||
'[ _ _ ncleave ] ;
|
||||
|
||||
: nappend-as ( n exemplar -- seq )
|
||||
[ narray concat ] dip like ; inline
|
||||
|
|
|
|||
|
|
@ -118,7 +118,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
|
|||
|
||||
SYMBOL: help-hook
|
||||
|
||||
help-hook global [ [ print-topic ] or ] change-at
|
||||
help-hook [ [ print-topic ] ] initialize
|
||||
|
||||
: help ( topic -- )
|
||||
help-hook get call ;
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ combinators combinators.short-circuit splitting debugger
|
|||
hashtables sorting effects vocabs vocabs.loader assocs editors
|
||||
continuations classes.predicate macros math sets eval
|
||||
vocabs.parser words.symbol values grouping unicode.categories
|
||||
sequences.deep ;
|
||||
sequences.deep call ;
|
||||
IN: help.lint
|
||||
|
||||
SYMBOL: vocabs-quot
|
||||
|
|
@ -15,9 +15,9 @@ SYMBOL: vocabs-quot
|
|||
: check-example ( element -- )
|
||||
[
|
||||
rest [
|
||||
but-last "\n" join 1vector
|
||||
[ (eval>string) ] with-datastack
|
||||
peek "\n" ?tail drop
|
||||
but-last "\n" join
|
||||
[ (eval>string) ] call( code -- output )
|
||||
"\n" ?tail drop
|
||||
] keep
|
||||
peek assert=
|
||||
] vocabs-quot get call ;
|
||||
|
|
@ -145,7 +145,7 @@ M: help-error error.
|
|||
bi ;
|
||||
|
||||
: check-something ( obj quot -- )
|
||||
flush '[ _ assert-depth ] swap '[ _ <help-error> , ] recover ; inline
|
||||
flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
|
||||
|
||||
: check-word ( word -- )
|
||||
[ with-file-vocabs ] vocabs-quot set
|
||||
|
|
|
|||
|
|
@ -27,11 +27,11 @@ M: link summary
|
|||
! Help articles
|
||||
SYMBOL: articles
|
||||
|
||||
articles global [ H{ } assoc-like ] change-at
|
||||
articles [ H{ } clone ] initialize
|
||||
|
||||
SYMBOL: article-xref
|
||||
|
||||
article-xref global [ H{ } assoc-like ] change-at
|
||||
article-xref [ H{ } clone ] initialize
|
||||
|
||||
GENERIC: article-name ( topic -- string )
|
||||
GENERIC: article-title ( topic -- string )
|
||||
|
|
|
|||
|
|
@ -57,7 +57,10 @@ HELP: hidden
|
|||
{ $description "Hidden components render as a hidden form field. For example, a page for editing a weblog post might contain a hidden field with the post ID." } ;
|
||||
|
||||
HELP: html
|
||||
{ $description "HTML components render HTML verbatim, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
|
||||
{ $description "HTML components render HTML verbatim from a string, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
|
||||
|
||||
HELP: xml
|
||||
{ $description "XML components render XML verbatim, from an XML chunk. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
|
||||
|
||||
HELP: inspector
|
||||
{ $description "Inspector components render an arbitrary object by passing it to the " { $link describe } " word." } ;
|
||||
|
|
@ -90,6 +93,7 @@ $nl
|
|||
{ $subsection inspector }
|
||||
{ $subsection comparison }
|
||||
{ $subsection html }
|
||||
{ $subsection xml }
|
||||
"Tuple components:"
|
||||
{ $subsection field }
|
||||
{ $subsection password }
|
||||
|
|
|
|||
|
|
@ -171,3 +171,8 @@ M: comparison render*
|
|||
SINGLETON: html
|
||||
|
||||
M: html render* 2drop <unescaped> ;
|
||||
|
||||
! XML component
|
||||
SINGLETON: xml
|
||||
|
||||
M: xml render* 2drop ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,7 @@
|
|||
USING: help.markup help.syntax strings xml.data ;
|
||||
IN: html
|
||||
|
||||
HELP: simple-page
|
||||
{ $values { "title" string } { "head" "XML data" } { "body" "XML data" }
|
||||
{ "xml" xml } }
|
||||
{ $description "Constructs a simple XHTML page with a " { $snippet "head" } " and " { $snippet "body" } " tag. The given XML data is spliced into the two child tags, and a title is also added to the head tag." } ;
|
||||
|
|
@ -15,7 +15,7 @@ IN: html
|
|||
</head>
|
||||
<body><-></body>
|
||||
</html>
|
||||
XML> ; inline
|
||||
XML> ;
|
||||
|
||||
: render-error ( message -- xml )
|
||||
[XML <span class="error"><-></span> XML] ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
IN: html.templates.chloe
|
||||
USING: help.markup help.syntax html.components html.forms
|
||||
USING: xml.data help.markup help.syntax html.components html.forms
|
||||
html.templates html.templates.chloe.syntax
|
||||
html.templates.chloe.compiler html.templates.chloe.components
|
||||
math xml.data strings quotations namespaces ;
|
||||
math strings quotations namespaces ;
|
||||
|
||||
HELP: <chloe>
|
||||
{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } }
|
||||
|
|
@ -70,6 +70,7 @@ ARTICLE: "html.templates.chloe.tags.component" "Component Chloe tags"
|
|||
{ { $snippet "t:field" } { $link field } }
|
||||
{ { $snippet "t:hidden" } { $link hidden } }
|
||||
{ { $snippet "t:html" } { $link html } }
|
||||
{ { $snippet "t:xml" } { $link xml } }
|
||||
{ { $snippet "t:inspector" } { $link inspector } }
|
||||
{ { $snippet "t:label" } { $link label } }
|
||||
{ { $snippet "t:link" } { $link link } }
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors kernel sequences combinators kernel fry
|
|||
namespaces make classes.tuple assocs splitting words arrays io
|
||||
io.files io.files.info io.encodings.utf8 io.streams.string
|
||||
unicode.case mirrors math urls present multiline quotations xml
|
||||
logging continuations
|
||||
logging call
|
||||
xml.data xml.writer xml.syntax strings
|
||||
html.forms
|
||||
html
|
||||
|
|
@ -95,6 +95,7 @@ COMPONENT: password
|
|||
COMPONENT: choice
|
||||
COMPONENT: checkbox
|
||||
COMPONENT: code
|
||||
COMPONENT: xml
|
||||
|
||||
SYMBOL: template-cache
|
||||
|
||||
|
|
@ -130,6 +131,6 @@ TUPLE: cached-template path last-modified quot ;
|
|||
template-cache get clear-assoc ;
|
||||
|
||||
M: chloe call-template*
|
||||
template-quot assert-depth ;
|
||||
template-quot call( -- ) ;
|
||||
|
||||
INSTANCE: chloe template
|
||||
|
|
|
|||
|
|
@ -2,8 +2,8 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: assocs namespaces make kernel sequences accessors
|
||||
combinators strings splitting io io.streams.string present
|
||||
xml.writer xml.data xml.entities html.forms
|
||||
html.templates html.templates.chloe.syntax continuations ;
|
||||
xml.writer xml.data xml.entities html.forms call
|
||||
html.templates html.templates.chloe.syntax ;
|
||||
IN: html.templates.chloe.compiler
|
||||
|
||||
: chloe-attrs-only ( assoc -- assoc' )
|
||||
|
|
@ -83,7 +83,7 @@ ERROR: unknown-chloe-tag tag ;
|
|||
|
||||
: compile-chloe-tag ( tag -- )
|
||||
dup main>> dup tags get at
|
||||
[ curry assert-depth ]
|
||||
[ call( tag -- ) ]
|
||||
[ unknown-chloe-tag ]
|
||||
?if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@ html.templates ;
|
|||
|
||||
SYMBOL: tags
|
||||
|
||||
tags global [ H{ } clone or ] change-at
|
||||
tags [ H{ } clone ] initialize
|
||||
|
||||
: define-chloe-tag ( name quot -- ) swap tags get set-at ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: continuations sequences kernel namespaces debugger
|
||||
combinators math quotations generic strings splitting accessors
|
||||
assocs fry vocabs.parser parser lexer io io.files
|
||||
assocs fry vocabs.parser parser lexer io io.files call
|
||||
io.streams.string io.encodings.utf8 html.templates ;
|
||||
IN: html.templates.fhtml
|
||||
|
||||
|
|
@ -72,6 +72,6 @@ TUPLE: fhtml path ;
|
|||
C: <fhtml> fhtml
|
||||
|
||||
M: fhtml call-template* ( filename -- )
|
||||
'[ _ path>> utf8 file-contents eval-template ] assert-depth ;
|
||||
[ path>> utf8 file-contents eval-template ] call( filename -- ) ;
|
||||
|
||||
INSTANCE: fhtml template
|
||||
|
|
|
|||
|
|
@ -56,8 +56,7 @@ HELP: http-request
|
|||
|
||||
HELP: with-http-request
|
||||
{ $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } }
|
||||
{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." }
|
||||
{ $errors "Throws an error if the HTTP request fails." } ;
|
||||
{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read. Does not throw an error if the HTTP request fails; to do so, call " { $link check-response } " on the " { $snippet "response" } "." } ;
|
||||
|
||||
ARTICLE: "http.client.get" "GET requests with the HTTP client"
|
||||
"Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"
|
||||
|
|
|
|||
|
|
@ -141,12 +141,15 @@ ERROR: download-failed response ;
|
|||
: check-response ( response -- response )
|
||||
dup code>> success? [ download-failed ] unless ;
|
||||
|
||||
: check-response-with-body ( response body -- response body )
|
||||
[ >>body check-response ] keep ;
|
||||
|
||||
: with-http-request ( request quot -- response )
|
||||
[ (with-http-request) check-response ] with-destructors ; inline
|
||||
[ (with-http-request) ] with-destructors ; inline
|
||||
|
||||
: http-request ( request -- response data )
|
||||
[ [ % ] with-http-request ] B{ } make
|
||||
over content-charset>> decode ;
|
||||
over content-charset>> decode check-response-with-body ;
|
||||
|
||||
: <get-request> ( url -- request )
|
||||
"GET" <client-request> ;
|
||||
|
|
|
|||
|
|
@ -113,6 +113,12 @@ HELP: set-header
|
|||
{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
|
||||
{ $side-effects "request/response" } ;
|
||||
|
||||
HELP: set-basic-auth
|
||||
{ $values { "request" request } { "username" string } { "password" string } }
|
||||
{ $description "Sets the " { $snippet "Authorization" } " header of " { $snippet "request" } " to perform HTTP Basic authentication with the given " { $snippet "username" } " and " { $snippet "password" } "." }
|
||||
{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
|
||||
{ $side-effects "request" } ;
|
||||
|
||||
ARTICLE: "http.cookies" "HTTP cookies"
|
||||
"Every " { $link request } " and " { $link response } " instance can contain cookies."
|
||||
$nl
|
||||
|
|
|
|||
|
|
@ -359,3 +359,8 @@ SYMBOL: a
|
|||
! Test cloning
|
||||
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
|
||||
[ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
|
||||
|
||||
! Test basic auth
|
||||
[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -7,7 +7,8 @@ calendar.format present urls fry
|
|||
io io.encodings io.encodings.iana io.encodings.binary
|
||||
io.encodings.8-bit io.crlf
|
||||
unicode.case unicode.categories
|
||||
http.parsers ;
|
||||
http.parsers
|
||||
base64 ;
|
||||
IN: http
|
||||
|
||||
: (read-header) ( -- alist )
|
||||
|
|
@ -142,6 +143,9 @@ cookies ;
|
|||
: set-header ( request/response value key -- request/response )
|
||||
pick header>> set-at ;
|
||||
|
||||
: set-basic-auth ( request username password -- request )
|
||||
":" glue >base64 "Basic " prepend "Authorization" set-header ;
|
||||
|
||||
: <request> ( -- request )
|
||||
request new
|
||||
"1.1" >>version
|
||||
|
|
@ -156,6 +160,7 @@ cookies ;
|
|||
: header ( request/response key -- value )
|
||||
swap header>> at ;
|
||||
|
||||
|
||||
TUPLE: response
|
||||
version
|
||||
code
|
||||
|
|
|
|||
|
|
@ -161,7 +161,7 @@ C: <trivial-responder> trivial-responder
|
|||
|
||||
M: trivial-responder call-responder* nip response>> clone ;
|
||||
|
||||
main-responder global [ <404> <trivial-responder> or ] change-at
|
||||
main-responder [ <404> <trivial-responder> ] initialize
|
||||
|
||||
: invert-slice ( slice -- slice' )
|
||||
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ $nl
|
|||
"If all you want to do is serve files from a directory, the following phrase does the trick:"
|
||||
{ $code
|
||||
"USING: namespaces http.server http.server.static ;"
|
||||
"/var/www/mysite.com/ <static> main-responder set"
|
||||
"\"/var/www/mysite.com/\" <static> main-responder set"
|
||||
"8080 httpd"
|
||||
}
|
||||
{ $subsection "http.server.static.extend" } ;
|
||||
|
|
|
|||
|
|
@ -45,9 +45,8 @@ TUPLE: file-responder root hook special allow-listings ;
|
|||
[ file-responder get hook>> call ] [ 2drop <304> ] if ;
|
||||
|
||||
: serving-path ( filename -- filename )
|
||||
file-responder get root>> trim-tail-separators
|
||||
"/"
|
||||
rot "" or trim-head-separators 3append ;
|
||||
[ file-responder get root>> trim-tail-separators "/" ] dip
|
||||
"" or trim-head-separators 3append ;
|
||||
|
||||
: serve-file ( filename -- response )
|
||||
dup mime-type
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,24 @@
|
|||
USING: images.bitmap images.viewer io.encodings.binary
|
||||
io.files io.files.unique kernel tools.test ;
|
||||
IN: images.bitmap.tests
|
||||
|
||||
: test-bitmap24 ( -- path )
|
||||
"resource:basis/images/test-images/thiswayup24.bmp" ;
|
||||
|
||||
: test-bitmap8 ( -- path )
|
||||
"resource:basis/images/test-images/rgb8bit.bmp" ;
|
||||
|
||||
: test-bitmap4 ( -- path )
|
||||
"resource:basis/images/test-images/rgb4bit.bmp" ;
|
||||
|
||||
: test-bitmap1 ( -- path )
|
||||
"resource:basis/images/test-images/1bit.bmp" ;
|
||||
|
||||
[ t ]
|
||||
[
|
||||
test-bitmap24
|
||||
[ binary file-contents ] [ load-bitmap ] bi
|
||||
|
||||
"test-bitmap24" unique-file
|
||||
[ save-bitmap ] [ binary file-contents ] bi =
|
||||
] unit-test
|
||||
|
|
@ -1,11 +1,12 @@
|
|||
! Copyright (C) 2007, 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien alien.c-types arrays byte-arrays columns
|
||||
combinators fry grouping io io.binary io.encodings.binary
|
||||
io.files kernel libc macros math math.bitwise math.functions
|
||||
namespaces opengl opengl.gl prettyprint sequences strings
|
||||
summary ui ui.gadgets.panes ;
|
||||
IN: graphics.bitmap
|
||||
combinators fry grouping io io.binary io.encodings.binary io.files
|
||||
kernel macros math math.bitwise math.functions namespaces sequences
|
||||
strings images endian summary ;
|
||||
IN: images.bitmap
|
||||
|
||||
TUPLE: bitmap-image < image ;
|
||||
|
||||
! Currently can only handle 24/32bit bitmaps.
|
||||
! Handles row-reversed bitmaps (their height is negative)
|
||||
|
|
@ -13,41 +14,24 @@ IN: graphics.bitmap
|
|||
TUPLE: bitmap magic size reserved offset header-length width
|
||||
height planes bit-count compression size-image
|
||||
x-pels y-pels color-used color-important rgb-quads color-index
|
||||
alpha-channel-zero?
|
||||
array ;
|
||||
buffer ;
|
||||
|
||||
: array-copy ( bitmap array -- bitmap array' )
|
||||
over size-image>> abs memory>byte-array ;
|
||||
|
||||
MACRO: (nbits>bitmap) ( bits -- )
|
||||
[ -3 shift ] keep '[
|
||||
bitmap new
|
||||
2over * _ * >>size-image
|
||||
swap >>height
|
||||
swap >>width
|
||||
swap array-copy [ >>array ] [ >>color-index ] bi
|
||||
_ >>bit-count
|
||||
] ;
|
||||
|
||||
: bgr>bitmap ( array height width -- bitmap )
|
||||
24 (nbits>bitmap) ;
|
||||
|
||||
: bgra>bitmap ( array height width -- bitmap )
|
||||
32 (nbits>bitmap) ;
|
||||
|
||||
: 8bit>array ( bitmap -- array )
|
||||
: 8bit>buffer ( bitmap -- array )
|
||||
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
|
||||
[ color-index>> >array ] bi [ swap nth ] with map concat ;
|
||||
|
||||
ERROR: bmp-not-supported n ;
|
||||
|
||||
: raw-bitmap>array ( bitmap -- array )
|
||||
: raw-bitmap>buffer ( bitmap -- array )
|
||||
dup bit-count>>
|
||||
{
|
||||
{ 32 [ color-index>> ] }
|
||||
{ 24 [ color-index>> ] }
|
||||
{ 16 [ bmp-not-supported ] }
|
||||
{ 8 [ 8bit>array ] }
|
||||
{ 8 [ 8bit>buffer ] }
|
||||
{ 4 [ bmp-not-supported ] }
|
||||
{ 2 [ bmp-not-supported ] }
|
||||
{ 1 [ bmp-not-supported ] }
|
||||
|
|
@ -95,19 +79,58 @@ M: bitmap-magic summary
|
|||
dup rgb-quads-length read >>rgb-quads
|
||||
dup color-index-length read >>color-index ;
|
||||
|
||||
: (load-bitmap) ( path -- bitmap )
|
||||
: load-bitmap-data ( path -- bitmap )
|
||||
binary [
|
||||
bitmap new
|
||||
parse-file-header parse-bitmap-header parse-bitmap
|
||||
] with-file-reader ;
|
||||
|
||||
: alpha-channel-zero? ( bitmap -- ? )
|
||||
array>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
|
||||
: process-bitmap-data ( bitmap -- bitmap )
|
||||
dup raw-bitmap>buffer >>buffer ;
|
||||
|
||||
: load-bitmap ( path -- bitmap )
|
||||
(load-bitmap)
|
||||
dup raw-bitmap>array >>array
|
||||
dup alpha-channel-zero? >>alpha-channel-zero? ;
|
||||
load-bitmap-data process-bitmap-data ;
|
||||
|
||||
ERROR: unknown-component-order bitmap ;
|
||||
|
||||
: bitmap>component-order ( bitmap -- object )
|
||||
bit-count>> {
|
||||
{ 32 [ BGRA ] }
|
||||
{ 24 [ BGR ] }
|
||||
{ 8 [ BGR ] }
|
||||
[ unknown-component-order ]
|
||||
} case ;
|
||||
|
||||
: >image ( bitmap -- bitmap-image )
|
||||
{
|
||||
[ [ width>> ] [ height>> ] bi 2array ]
|
||||
[ bitmap>component-order ]
|
||||
[ buffer>> ]
|
||||
} cleave bitmap-image boa ;
|
||||
|
||||
M: bitmap-image load-image* ( path bitmap -- bitmap-image )
|
||||
drop load-bitmap >image ;
|
||||
|
||||
M: bitmap-image normalize-scan-line-order
|
||||
dup dim>> '[
|
||||
_ first 4 * <sliced-groups> reverse concat
|
||||
] change-bitmap ;
|
||||
|
||||
MACRO: (nbits>bitmap) ( bits -- )
|
||||
[ -3 shift ] keep '[
|
||||
bitmap new
|
||||
2over * _ * >>size-image
|
||||
swap >>height
|
||||
swap >>width
|
||||
swap array-copy [ >>buffer ] [ >>color-index ] bi
|
||||
_ >>bit-count >image
|
||||
] ;
|
||||
|
||||
: bgr>bitmap ( array height width -- bitmap )
|
||||
24 (nbits>bitmap) ;
|
||||
|
||||
: bgra>bitmap ( array height width -- bitmap )
|
||||
32 (nbits>bitmap) ;
|
||||
|
||||
: write2 ( n -- ) 2 >le write ;
|
||||
: write4 ( n -- ) 4 >le write ;
|
||||
|
|
@ -116,7 +139,7 @@ M: bitmap-magic summary
|
|||
binary [
|
||||
B{ CHAR: B CHAR: M } write
|
||||
[
|
||||
array>> length 14 + 40 + write4
|
||||
buffer>> length 14 + 40 + write4
|
||||
0 write4
|
||||
54 write4
|
||||
40 write4
|
||||
|
|
@ -0,0 +1,62 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors grouping sequences combinators
|
||||
math specialized-arrays.direct.uint byte-arrays
|
||||
specialized-arrays.direct.ushort ;
|
||||
IN: images
|
||||
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||
R16G16B16 R32G32B32 ;
|
||||
|
||||
TUPLE: image dim component-order bitmap ;
|
||||
|
||||
: <image> ( -- image ) image new ; inline
|
||||
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
||||
: add-dummy-alpha ( seq -- seq' )
|
||||
3 <sliced-groups>
|
||||
[ 255 suffix ] map concat ;
|
||||
|
||||
: normalize-component-order ( image -- image )
|
||||
dup component-order>>
|
||||
{
|
||||
{ RGBA [ ] }
|
||||
{ R32G32B32 [
|
||||
[
|
||||
dup length 4 / <direct-uint-array>
|
||||
[ bits>float 255.0 * >integer ] map
|
||||
>byte-array add-dummy-alpha
|
||||
] change-bitmap
|
||||
] }
|
||||
{ R16G16B16 [
|
||||
[
|
||||
dup length 2 / <direct-ushort-array>
|
||||
[ -8 shift ] map
|
||||
>byte-array add-dummy-alpha
|
||||
] change-bitmap
|
||||
] }
|
||||
{ BGRA [
|
||||
[
|
||||
4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
|
||||
] change-bitmap
|
||||
] }
|
||||
{ RGB [ [ add-dummy-alpha ] change-bitmap ] }
|
||||
{ BGR [
|
||||
[
|
||||
3 <sliced-groups>
|
||||
[ [ [ 0 3 ] dip <slice> reverse-here ] each ]
|
||||
[ add-dummy-alpha ] bi
|
||||
] change-bitmap
|
||||
] }
|
||||
} case
|
||||
RGBA >>component-order ;
|
||||
|
||||
GENERIC: normalize-scan-line-order ( image -- image )
|
||||
|
||||
M: image normalize-scan-line-order ;
|
||||
|
||||
: normalize-image ( image -- image )
|
||||
[ >byte-array ] change-bitmap
|
||||
normalize-component-order
|
||||
normalize-scan-line-order ;
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: constructors kernel splitting unicode.case combinators
|
||||
accessors images.bitmap images.tiff images io.backend
|
||||
io.pathnames ;
|
||||
IN: images.loader
|
||||
|
||||
ERROR: unknown-image-extension extension ;
|
||||
|
||||
: image-class ( path -- class )
|
||||
file-extension >lower {
|
||||
{ "bmp" [ bitmap-image ] }
|
||||
{ "tif" [ tiff-image ] }
|
||||
{ "tiff" [ tiff-image ] }
|
||||
[ unknown-image-extension ]
|
||||
} case ;
|
||||
|
||||
: load-image ( path -- image )
|
||||
dup image-class new load-image* normalize-image ;
|
||||
|
Before Width: | Height: | Size: 1.6 KiB After Width: | Height: | Size: 1.6 KiB |
Binary file not shown.
|
Before Width: | Height: | Size: 5.2 KiB After Width: | Height: | Size: 5.2 KiB |
|
Before Width: | Height: | Size: 11 KiB After Width: | Height: | Size: 11 KiB |
|
Before Width: | Height: | Size: 59 KiB After Width: | Height: | Size: 59 KiB |
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue