steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Merge commit 'origin/master' into emacs

db4
Jose A. Ortega Ruiz 2009-02-14 13:43:17 +01:00
parent 883835272d b638a35fd7
commit 29d1dfe7b5
210 changed files with 4272 additions and 1673 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -24,3 +24,4 @@ build-support/wordsize
*.bak *.bak
.#* .#*
*.swo *.swo
checksums.txt

2
basis/alien/arrays/arrays.factor Normal file → Executable file
View File

@ -26,7 +26,7 @@ M: array box-return drop "void*" box-return ;
M: array stack-size drop "void*" stack-size ; 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 ] ; M: array c-type-unboxer-quot drop [ >c-ptr ] ;

29
basis/alien/c-types/c-types.factor Normal file → Executable file
View File

@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary layouts system compiler.units io.files io.encodings.binary
accessors combinators effects continuations fry call ; accessors combinators effects continuations fry call classes ;
IN: alien.c-types IN: alien.c-types
DEFER: <int> DEFER: <int>
@ -13,18 +13,20 @@ DEFER: *char
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable : little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type TUPLE: c-type
class { class class initial: object }
boxer boxer-quot unboxer unboxer-quot boxer
getter setter { boxer-quot callable }
reg-class size align stack-align? ; unboxer
{ unboxer-quot callable }
: new-c-type ( class -- type ) { getter callable }
new { setter callable }
int-regs >>reg-class { reg-class initial: int-regs }
object >>class ; inline size
align
stack-align? ;
: <c-type> ( -- type ) : <c-type> ( -- type )
\ c-type new-c-type ; \ c-type new ;
SYMBOL: c-types SYMBOL: c-types
@ -185,6 +187,9 @@ M: f byte-length drop 0 ;
[ "Cannot read struct fields with this type" throw ] [ "Cannot read struct fields with this type" throw ]
] unless* ; ] unless* ;
: c-type-getter-boxer ( name -- quot )
[ c-getter ] [ c-type-boxer-quot ] bi append ;
: c-setter ( name -- quot ) : c-setter ( name -- quot )
c-type-setter [ c-type-setter [
[ "Cannot write struct fields with this type" throw ] [ "Cannot write struct fields with this type" throw ]
@ -221,7 +226,7 @@ M: f byte-length drop 0 ;
TUPLE: long-long-type < c-type ; TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- type ) : <long-long-type> ( -- type )
long-long-type new-c-type ; long-long-type new ;
M: long-long-type unbox-parameter ( n type -- ) M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ; c-type-unboxer %unbox-long-long ;

11
basis/alien/complex/complex.factor
View File

@ -1,6 +1,13 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 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
basis/alien/complex/functor/functor.factor
View File

@ -12,15 +12,15 @@ T-imaginary DEFINES ${T}-imaginary
set-T-real DEFINES set-${T}-real set-T-real DEFINES set-${T}-real
set-T-imaginary DEFINES set-${T}-imaginary set-T-imaginary DEFINES set-${T}-imaginary
>T DEFINES >${T} <T> DEFINES <${T}>
T> DEFINES ${T}> *T DEFINES *${T}
WHERE WHERE
: >T ( z -- alien ) : <T> ( z -- alien )
>rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline >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-real ] [ T-imaginary ] bi rect> ; inline
T in get T in get
@ -28,8 +28,8 @@ T in get
define-struct define-struct
T c-type T c-type
T> 1quotation >>boxer-quot <T> 1quotation >>unboxer-quot
>T 1quotation >>unboxer-quot *T 1quotation >>boxer-quot
drop drop
;FUNCTOR ;FUNCTOR

0
basis/math/blas/cblas/authors.txt → basis/alien/fortran/authors.txt
View File

73
basis/alien/fortran/fortran-docs.factor Normal file
View File

@ -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"

381
basis/alien/fortran/fortran-tests.factor Normal file
View File

@ -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

452
basis/alien/fortran/fortran.factor Normal file
View File

@ -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

1
basis/alien/fortran/summary.txt Normal file
View File

@ -0,0 +1 @@
GNU Fortran/G77/F2C alien interface

2
basis/alien/fortran/tags.txt Normal file
View File

@ -0,0 +1,2 @@
fortran
ffi

5
basis/alien/structs/fields/fields.factor
View File

@ -58,10 +58,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
: define-getter ( type spec -- ) : define-getter ( type spec -- )
[ set-reader-props ] keep [ set-reader-props ] keep
[ reader>> ] [ reader>> ]
[ [ type>> c-type-getter-boxer ]
type>>
[ c-getter ] [ c-type-boxer-quot ] bi append
]
[ ] tri [ ] tri
(( c-ptr -- value )) define-struct-slot-word ; (( c-ptr -- value )) define-struct-slot-word ;

15
basis/alien/structs/structs-tests.factor Normal file → Executable file
View File

@ -42,3 +42,18 @@ C-UNION: barx
[ ] [ \ foox-x "help" get execute ] unit-test [ ] [ \ foox-x "help" get execute ] unit-test
[ ] [ \ set-foox-x "help" get execute ] unit-test [ ] [ \ set-foox-x "help" get execute ] unit-test
] when ] 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

26
basis/alien/structs/structs.factor Normal file → Executable file
View File

@ -1,15 +1,26 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 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 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 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>> ; M: struct-type c-type-align align>> ;
@ -29,7 +40,7 @@ M: struct-type box-parameter
[ %box-large-struct ] [ box-parameter ] if-value-struct ; [ %box-large-struct ] [ box-parameter ] if-value-struct ;
: if-small-struct ( c-type true false -- ? ) : 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 M: struct-type unbox-return
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ; [ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
@ -68,3 +79,8 @@ M: struct-type stack-size
[ expand-constants ] map [ expand-constants ] map
[ [ heap-size ] [ max ] map-reduce ] keep [ [ heap-size ] [ max ] map-reduce ] keep
compute-struct-align f (define-struct) ; compute-struct-align f (define-struct) ;
: offset-of ( field struct -- offset )
c-types get at fields>>
[ name>> = ] with find nip offset>> ;

21
basis/bit-arrays/bit-arrays.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Slava Pestov. ! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types accessors math alien.accessors kernel 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 ; parser prettyprint.custom fry ;
IN: bit-arrays IN: bit-arrays
@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ;
: ?{ \ } [ >bit-array ] parse-literal ; parsing : ?{ \ } [ >bit-array ] parse-literal ; parsing
:: integer>bit-array ( n -- bit-array ) : integer>bit-array ( n -- bit-array )
n zero? [ 0 <bit-array> ] [ dup 0 = [
[let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] | <bit-array>
[ n' zero? ] [ ] [
n' out underlying>> i set-alien-unsigned-1 [ log2 1+ <bit-array> 0 ] keep
n' -8 shift n'! [ dup 0 = ] [
i 1+ i! [ pick underlying>> pick set-alien-unsigned-1 ] keep
] [ ] until [ 1+ ] [ -8 shift ] bi*
out ] [ ] until 2drop
]
] if ; ] if ;
: bit-array>integer ( bit-array -- n ) : bit-array>integer ( bit-array -- n )

1
basis/bitstreams/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

27
basis/bitstreams/bitstreams-tests.factor Normal file
View File

@ -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

96
basis/bitstreams/bitstreams.factor Normal file
View File

@ -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 ;

6
basis/bootstrap/image/image-docs.factor
View File

@ -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 IN: bootstrap.image
ARTICLE: "bootstrap.image" "Bootstrapping new images" ARTICLE: "bootstrap.image" "Bootstrapping new images"
@ -14,7 +14,7 @@ $nl
ABOUT: "bootstrap.image" ABOUT: "bootstrap.image"
HELP: make-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:" { $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" } "." } ; "The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;

2
basis/cocoa/cocoa.factor
View File

@ -29,7 +29,7 @@ SYMBOL: super-sent-messages
SYMBOL: frameworks SYMBOL: frameworks
frameworks global [ V{ } clone or ] change-at frameworks [ V{ } clone ] initialize
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook [ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook

8
basis/cocoa/messages/messages.factor
View File

@ -19,8 +19,8 @@ IN: cocoa.messages
SYMBOL: message-senders SYMBOL: message-senders
SYMBOL: super-message-senders SYMBOL: super-message-senders
message-senders global [ H{ } assoc-like ] change-at message-senders [ H{ } clone ] initialize
super-message-senders global [ H{ } assoc-like ] change-at super-message-senders [ H{ } clone ] initialize
: cache-stub ( method function hash -- ) : cache-stub ( method function hash -- )
[ [
@ -53,7 +53,7 @@ MEMO: <selector> ( name -- sel ) f \ selector boa ;
SYMBOL: objc-methods SYMBOL: objc-methods
objc-methods global [ H{ } assoc-like ] change-at objc-methods [ H{ } clone ] initialize
: lookup-method ( selector -- method ) : lookup-method ( selector -- method )
dup objc-methods get at dup objc-methods get at
@ -79,7 +79,7 @@ MACRO: (send) ( selector super? -- quot )
! Runtime introspection ! Runtime introspection
SYMBOL: class-init-hooks SYMBOL: class-init-hooks
class-init-hooks global [ H{ } clone or ] change-at class-init-hooks [ H{ } clone ] initialize
: (objc-class) ( name word -- class ) : (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [ 2dup execute dup [ 2nip ] [

2
basis/combinators/smart/smart-tests.factor
View File

@ -45,3 +45,5 @@ IN: combinators.smart.tests
\ nested-smart-combo-test must-infer \ 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

6
basis/combinators/smart/smart.factor
View File

@ -21,6 +21,12 @@ MACRO: reduce-outputs ( quot operation -- newquot )
: sum-outputs ( quot -- n ) : sum-outputs ( quot -- n )
[ + ] reduce-outputs ; inline [ + ] 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 ) MACRO: append-outputs-as ( quot exemplar -- newquot )
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ; [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;

2
basis/compiler/alien/alien.factor
View File

@ -5,7 +5,7 @@ alien.c-types alien.structs cpu.architecture ;
IN: compiler.alien IN: compiler.alien
: large-struct? ( ctype -- ? ) : 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 ) : alien-parameters ( params -- seq )
dup parameters>> dup parameters>>

2
basis/compiler/utilities/utilities.factor
View File

@ -24,4 +24,4 @@ IN: compiler.utilities
SYMBOL: yield-hook SYMBOL: yield-hook
yield-hook global [ [ ] or ] change-at yield-hook [ [ ] ] initialize

1
basis/compression/lzw/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

4
basis/compression/lzw/lzw-tests.factor Normal file
View File

@ -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

204
basis/compression/lzw/lzw.factor Normal file
View File

@ -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 ;

0
basis/zlib/authors.txt → basis/compression/zlib/authors.txt
View File

0
basis/zlib/ffi/authors.txt → basis/compression/zlib/ffi/authors.txt
View File

2
basis/zlib/ffi/ffi.factor → basis/compression/zlib/ffi/ffi.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators system ; USING: alien alien.syntax combinators system ;
IN: zlib.ffi IN: compression.zlib.ffi
<< "zlib" { << "zlib" {
{ [ os winnt? ] [ "zlib1.dll" ] } { [ os winnt? ] [ "zlib1.dll" ] }

4
basis/zlib/zlib-tests.factor → basis/compression/zlib/zlib-tests.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test zlib classes ; USING: kernel tools.test compression.zlib classes ;
IN: zlib.tests IN: compression.zlib.tests
: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ; : compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;

12
basis/zlib/zlib.factor → basis/compression/zlib/zlib.factor
View File

@ -3,8 +3,8 @@
USING: alien alien.c-types alien.syntax byte-arrays combinators USING: alien alien.c-types alien.syntax byte-arrays combinators
kernel math math.functions sequences system accessors kernel math math.functions sequences system accessors
libc ; libc ;
QUALIFIED: zlib.ffi QUALIFIED: compression.zlib.ffi
IN: zlib IN: compression.zlib
TUPLE: compressed data length ; TUPLE: compressed data length ;
@ -16,7 +16,7 @@ TUPLE: compressed data length ;
ERROR: zlib-failed n string ; ERROR: zlib-failed n string ;
: zlib-error-message ( n -- * ) : zlib-error-message ( n -- * )
dup zlib.ffi:Z_ERRNO = [ dup compression.zlib.ffi:Z_ERRNO = [
drop errno "native libc error" drop errno "native libc error"
] [ ] [
dup { dup {
@ -27,7 +27,7 @@ ERROR: zlib-failed n string ;
] if zlib-failed ; ] if zlib-failed ;
: zlib-error ( n -- ) : 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 ) : compressed-size ( byte-array -- n )
length 1001/1000 * ceiling 12 + ; length 1001/1000 * ceiling 12 + ;
@ -35,7 +35,7 @@ ERROR: zlib-failed n string ;
: compress ( byte-array -- compressed ) : compress ( byte-array -- compressed )
[ [
[ compressed-size <byte-array> dup length <ulong> ] keep [ [ 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 ] 3keep drop *ulong head
] keep length <compressed> ; ] keep length <compressed> ;
@ -44,5 +44,5 @@ ERROR: zlib-failed n string ;
length>> [ <byte-array> ] keep <ulong> 2dup length>> [ <byte-array> ] keep <ulong> 2dup
] [ ] [
data>> dup length data>> dup length
zlib.ffi:uncompress zlib-error compression.zlib.ffi:uncompress zlib-error
] bi *ulong head ; ] bi *ulong head ;

2
basis/concurrency/messaging/messaging.factor
View File

@ -85,4 +85,4 @@ PRIVATE>
: get-process ( name -- process ) : get-process ( name -- process )
dup registered-processes at [ ] [ thread ] ?if ; dup registered-processes at [ ] [ thread ] ?if ;
\ registered-processes global [ H{ } assoc-like ] change-at \ registered-processes [ H{ } clone ] initialize

0
extra/constructors/authors.txt → basis/constructors/authors.txt
View File

0
extra/constructors/constructors-tests.factor → basis/constructors/constructors-tests.factor
View File

0
extra/constructors/constructors.factor → basis/constructors/constructors.factor
View File

2
basis/cpu/architecture/architecture.factor
View File

@ -152,7 +152,7 @@ HOOK: %loop-entry cpu ( -- )
HOOK: small-enough? cpu ( n -- ? ) HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers? ! 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? ! Do we pass this struct by value or hidden reference?
HOOK: value-struct? cpu ( c-type -- ? ) HOOK: value-struct? cpu ( c-type -- ? )

2
basis/cpu/ppc/ppc.factor
View File

@ -659,7 +659,7 @@ M: ppc %callback-value ( ctype -- )
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; 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 M: ppc %box-small-struct
drop "No small structs" throw ; drop "No small structs" throw ;

9
basis/cpu/x86/32/32.factor
View File

@ -48,9 +48,12 @@ M: x86.32 %alien-invoke (CALL) rel-dlsym ;
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ; M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
M: x86.32 struct-small-enough? ( size -- ? ) M: x86.32 return-struct-in-registers? ( c-type -- ? )
heap-size { 1 2 4 8 } member? c-type
os { linux netbsd solaris } member? not and ; [ return-in-registers?>> ]
[ heap-size { 1 2 4 8 } member? ] bi
os { linux netbsd solaris } member? not
and or ;
: struct-return@ ( n -- operand ) : struct-return@ ( n -- operand )
[ next-stack@ ] [ stack-frame get params>> stack@ ] if* ; [ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;

2
basis/cpu/x86/64/unix/unix.factor
View File

@ -44,7 +44,7 @@ M: struct-type flatten-value-type ( type -- seq )
flatten-small-struct flatten-small-struct
] if ; ] if ;
M: x86.64 struct-small-enough? ( size -- ? ) M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ; heap-size 2 cells <= ;
M: x86.64 dummy-stack-params? f ; M: x86.64 dummy-stack-params? f ;

3
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -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 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? ; M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;

9
basis/csv/csv-tests.factor
View File

@ -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.pathnames io.files.unique io.encodings.utf8 io.files
io.directories ; io.directories ;
IN: csv.tests IN: csv.tests
! I like to name my unit tests ! I like to name my unit tests
: named-unit-test ( name output input -- ) : named-unit-test ( name output input -- )
nipd unit-test ; inline unit-test drop ; inline
! tests nicked from the wikipedia csv article
! http://en.wikipedia.org/wiki/Comma-separated_values
"Fields are separated by commas" "Fields are separated by commas"
[ { { "1997" "Ford" "E350" } } ] [ { { "1997" "Ford" "E350" } } ]
@ -90,3 +87,5 @@ IN: csv.tests
{ { "writing,some,csv,tests" } } dup "csv-test2-" { { "writing,some,csv,tests" } } dup "csv-test2-"
unique-file utf8 [ csv>file ] [ file>csv ] 2bi = unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
] unit-test ] unit-test
[ { { "hello" "" "" "" "goodbye" "" } } ] [ "hello,,\"\",,goodbye," <string-reader> csv ] unit-test

9
basis/csv/csv.factor
View File

@ -46,13 +46,15 @@ DEFER: quoted-field ( -- endchar )
: (row) ( -- sep ) : (row) ( -- sep )
field , field ,
dup delimiter get = [ drop (row) ] when ; dup delimiter> = [ drop (row) ] when ;
: row ( -- eof? array[string] ) : row ( -- eof? array[string] )
[ (row) ] { } make ; [ (row) ] { } make ;
: (csv) ( -- ) : (csv) ( -- )
row harvest [ , ] unless-empty [ (csv) ] when ; row
dup [ empty? ] all? [ drop ] [ , ] if
[ (csv) ] when ;
PRIVATE> PRIVATE>
@ -60,7 +62,8 @@ PRIVATE>
[ row nip ] with-input-stream ; [ row nip ] with-input-stream ;
: csv ( stream -- rows ) : csv ( stream -- rows )
[ [ (csv) ] { } make ] with-input-stream ; [ [ (csv) ] { } make ] with-input-stream
dup peek { "" } = [ but-last ] when ;
: file>csv ( path encoding -- csv ) : file>csv ( path encoding -- csv )
<file-reader> csv ; <file-reader> csv ;

98
basis/db/postgresql/ffi/ffi.factor
View File

@ -11,46 +11,46 @@ IN: db.postgresql.ffi
} cond "cdecl" add-library >> } cond "cdecl" add-library >>
! ConnSatusType ! ConnSatusType
: CONNECTION_OK HEX: 0 ; inline CONSTANT: CONNECTION_OK HEX: 0
: CONNECTION_BAD HEX: 1 ; inline CONSTANT: CONNECTION_BAD HEX: 1
: CONNECTION_STARTED HEX: 2 ; inline CONSTANT: CONNECTION_STARTED HEX: 2
: CONNECTION_MADE HEX: 3 ; inline CONSTANT: CONNECTION_MADE HEX: 3
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline CONSTANT: CONNECTION_AWAITING_RESPONSE HEX: 4
: CONNECTION_AUTH_OK HEX: 5 ; inline CONSTANT: CONNECTION_AUTH_OK HEX: 5
: CONNECTION_SETENV HEX: 6 ; inline CONSTANT: CONNECTION_SETENV HEX: 6
: CONNECTION_SSL_STARTUP HEX: 7 ; inline CONSTANT: CONNECTION_SSL_STARTUP HEX: 7
: CONNECTION_NEEDED HEX: 8 ; inline CONSTANT: CONNECTION_NEEDED HEX: 8
! PostgresPollingStatusType ! PostgresPollingStatusType
: PGRES_POLLING_FAILED HEX: 0 ; inline CONSTANT: PGRES_POLLING_FAILED HEX: 0
: PGRES_POLLING_READING HEX: 1 ; inline CONSTANT: PGRES_POLLING_READING HEX: 1
: PGRES_POLLING_WRITING HEX: 2 ; inline CONSTANT: PGRES_POLLING_WRITING HEX: 2
: PGRES_POLLING_OK HEX: 3 ; inline CONSTANT: PGRES_POLLING_OK HEX: 3
: PGRES_POLLING_ACTIVE HEX: 4 ; inline CONSTANT: PGRES_POLLING_ACTIVE HEX: 4
! ExecStatusType; ! ExecStatusType;
: PGRES_EMPTY_QUERY HEX: 0 ; inline CONSTANT: PGRES_EMPTY_QUERY HEX: 0
: PGRES_COMMAND_OK HEX: 1 ; inline CONSTANT: PGRES_COMMAND_OK HEX: 1
: PGRES_TUPLES_OK HEX: 2 ; inline CONSTANT: PGRES_TUPLES_OK HEX: 2
: PGRES_COPY_OUT HEX: 3 ; inline CONSTANT: PGRES_COPY_OUT HEX: 3
: PGRES_COPY_IN HEX: 4 ; inline CONSTANT: PGRES_COPY_IN HEX: 4
: PGRES_BAD_RESPONSE HEX: 5 ; inline CONSTANT: PGRES_BAD_RESPONSE HEX: 5
: PGRES_NONFATAL_ERROR HEX: 6 ; inline CONSTANT: PGRES_NONFATAL_ERROR HEX: 6
: PGRES_FATAL_ERROR HEX: 7 ; inline CONSTANT: PGRES_FATAL_ERROR HEX: 7
! PGTransactionStatusType; ! PGTransactionStatusType;
: PQTRANS_IDLE HEX: 0 ; inline CONSTANT: PQTRANS_IDLE HEX: 0
: PQTRANS_ACTIVE HEX: 1 ; inline CONSTANT: PQTRANS_ACTIVE HEX: 1
: PQTRANS_INTRANS HEX: 2 ; inline CONSTANT: PQTRANS_INTRANS HEX: 2
: PQTRANS_INERROR HEX: 3 ; inline CONSTANT: PQTRANS_INERROR HEX: 3
: PQTRANS_UNKNOWN HEX: 4 ; inline CONSTANT: PQTRANS_UNKNOWN HEX: 4
! PGVerbosity; ! PGVerbosity;
: PQERRORS_TERSE HEX: 0 ; inline CONSTANT: PQERRORS_TERSE HEX: 0
: PQERRORS_DEFAULT HEX: 1 ; inline CONSTANT: PQERRORS_DEFAULT HEX: 1
: PQERRORS_VERBOSE HEX: 2 ; inline CONSTANT: PQERRORS_VERBOSE HEX: 2
: InvalidOid 0 ; inline CONSTANT: InvalidOid 0
TYPEDEF: int ConnStatusType TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType TYPEDEF: int ExecStatusType
@ -348,21 +348,21 @@ FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
FUNCTION: int PQenv2encoding ( ) ; FUNCTION: int PQenv2encoding ( ) ;
! From git, include/catalog/pg_type.h ! From git, include/catalog/pg_type.h
: BOOL-OID 16 ; inline CONSTANT: BOOL-OID 16
: BYTEA-OID 17 ; inline CONSTANT: BYTEA-OID 17
: CHAR-OID 18 ; inline CONSTANT: CHAR-OID 18
: NAME-OID 19 ; inline CONSTANT: NAME-OID 19
: INT8-OID 20 ; inline CONSTANT: INT8-OID 20
: INT2-OID 21 ; inline CONSTANT: INT2-OID 21
: INT4-OID 23 ; inline CONSTANT: INT4-OID 23
: TEXT-OID 23 ; inline CONSTANT: TEXT-OID 23
: OID-OID 26 ; inline CONSTANT: OID-OID 26
: FLOAT4-OID 700 ; inline CONSTANT: FLOAT4-OID 700
: FLOAT8-OID 701 ; inline CONSTANT: FLOAT8-OID 701
: VARCHAR-OID 1043 ; inline CONSTANT: VARCHAR-OID 1043
: DATE-OID 1082 ; inline CONSTANT: DATE-OID 1082
: TIME-OID 1083 ; inline CONSTANT: TIME-OID 1083
: TIMESTAMP-OID 1114 ; inline CONSTANT: TIMESTAMP-OID 1114
: TIMESTAMPTZ-OID 1184 ; inline CONSTANT: TIMESTAMPTZ-OID 1184
: INTERVAL-OID 1186 ; inline CONSTANT: INTERVAL-OID 1186
: NUMERIC-OID 1700 ; inline CONSTANT: NUMERIC-OID 1700

6
basis/db/postgresql/lib/lib.factor
View File

@ -3,7 +3,7 @@
USING: arrays continuations db io kernel math namespaces USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser combinators 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 accessors strings serialize io.encodings.binary io.encodings.utf8
alien.strings io.streams.byte-array summary present urls alien.strings io.streams.byte-array summary present urls
specialized-arrays.uint specialized-arrays.alien db.private ; 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 ) : pq-get-string ( handle row column -- obj )
3dup PQgetvalue utf8 alien>string 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-number ( handle row column -- obj )
pq-get-string dup [ string>number ] when ; 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 ) : pq-get-blob ( handle row column -- obj/f )
[ PQgetvalue ] 3keep 3dup PQgetlength [ PQgetvalue ] 3keep 3dup PQgetlength
dup 0 > [ dup 0 > [
3nip [ 3drop ] dip
[ [
memory>byte-array >string memory>byte-array >string
0 <uint> 0 <uint>

4
basis/db/queries/queries.factor
View File

@ -44,11 +44,11 @@ M: retryable execute-statement* ( statement type -- )
] bi attempt-all drop ; ] bi attempt-all drop ;
: sql-props ( class -- columns table ) : sql-props ( class -- columns table )
[ db-columns ] [ db-table ] bi ; [ db-columns ] [ db-table-name ] bi ;
: query-make ( class quot -- statements ) : query-make ( class quot -- statements )
#! query, input, outputs, secondary queries #! query, input, outputs, secondary queries
over unparse "table" set over db-table-name "table-name" set
[ sql-props ] dip [ sql-props ] dip
[ 0 sql-counter rot with-variable ] curry [ 0 sql-counter rot with-variable ] curry
{ "" { } { } { } } nmake { "" { } { } { } } nmake

96
basis/db/sqlite/ffi/ffi.factor
View File

@ -13,33 +13,33 @@ IN: db.sqlite.ffi
} cond "cdecl" add-library >> } cond "cdecl" add-library >>
! Return values from sqlite functions ! Return values from sqlite functions
: SQLITE_OK 0 ; inline ! Successful result CONSTANT: SQLITE_OK 0 ! Successful result
: SQLITE_ERROR 1 ; inline ! SQL error or missing database CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database
: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite
: SQLITE_PERM 3 ; inline ! Access permission denied CONSTANT: SQLITE_PERM 3 ! Access permission denied
: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort
: SQLITE_BUSY 5 ; inline ! The database file is locked CONSTANT: SQLITE_BUSY 5 ! The database file is locked
: SQLITE_LOCKED 6 ; inline ! A table in the database is locked CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked
: SQLITE_NOMEM 7 ; inline ! A malloc() failed CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed
: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database
: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt() CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt()
: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred
: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed
: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found
: SQLITE_FULL 13 ; inline ! Insertion failed because database is full CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full
: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file
: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error
: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty
: SQLITE_SCHEMA 17 ; inline ! The database schema changed CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed
: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table
: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation
: SQLITE_MISMATCH 20 ; inline ! Data type mismatch CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch
: SQLITE_MISUSE 21 ; inline ! Library used incorrectly CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly
: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host
: SQLITE_AUTH 23 ; inline ! Authorization denied CONSTANT: SQLITE_AUTH 23 ! Authorization denied
: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error
: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range
: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file
: sqlite-error-messages ( -- seq ) { : sqlite-error-messages ( -- seq ) {
"Successful result" "Successful result"
@ -72,32 +72,32 @@ IN: db.sqlite.ffi
} ; } ;
! Return values from sqlite3_step ! Return values from sqlite3_step
: SQLITE_ROW 100 ; inline CONSTANT: SQLITE_ROW 100
: SQLITE_DONE 101 ; inline CONSTANT: SQLITE_DONE 101
! Return values from the sqlite3_column_type function ! Return values from the sqlite3_column_type function
: SQLITE_INTEGER 1 ; inline CONSTANT: SQLITE_INTEGER 1
: SQLITE_FLOAT 2 ; inline CONSTANT: SQLITE_FLOAT 2
: SQLITE_TEXT 3 ; inline CONSTANT: SQLITE_TEXT 3
: SQLITE_BLOB 4 ; inline CONSTANT: SQLITE_BLOB 4
: SQLITE_NULL 5 ; inline CONSTANT: SQLITE_NULL 5
! Values for the 'destructor' parameter of the 'bind' routines. ! Values for the 'destructor' parameter of the 'bind' routines.
: SQLITE_STATIC 0 ; inline CONSTANT: SQLITE_STATIC 0
: SQLITE_TRANSIENT -1 ; inline CONSTANT: SQLITE_TRANSIENT -1
: SQLITE_OPEN_READONLY HEX: 00000001 ; inline CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001
: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002
: SQLITE_OPEN_CREATE HEX: 00000004 ; inline CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004
: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008
: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010
: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100
: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200
: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400
: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800
: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
TYPEDEF: void sqlite3 TYPEDEF: void sqlite3
TYPEDEF: void sqlite3_stmt TYPEDEF: void sqlite3_stmt

92
basis/db/sqlite/sqlite-tests.factor
View File

@ -73,3 +73,95 @@ IN: db.sqlite.tests
"select * from person" sql-query length "select * from person" sql-query length
] with-db ] with-db
] unit-test ] 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

54
basis/db/sqlite/sqlite.factor
View File

@ -138,11 +138,13 @@ M: sqlite-db-connection create-sql-statement ( class -- statement )
modifiers 0% modifiers 0%
] interleave ] interleave
find-primary-key [
", " 0% ", " 0%
find-primary-key
"primary key(" 0% "primary key(" 0%
[ "," 0% ] [ column-name>> 0% ] interleave [ "," 0% ] [ column-name>> 0% ] interleave
"));" 0% ")" 0%
] unless-empty
");" 0%
] query-make ; ] query-make ;
M: sqlite-db-connection drop-sql-statement ( class -- statement ) M: sqlite-db-connection drop-sql-statement ( class -- statement )
@ -223,11 +225,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: insert-trigger ( -- string ) : insert-trigger ( -- string )
[ [
<" <"
CREATE TRIGGER fki_${table}_${foreign-table}_id CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
BEFORE INSERT ON ${table} BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN 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 (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END; END;
"> interpolate "> interpolate
] with-string-writer ; ] with-string-writer ;
@ -235,12 +237,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: insert-trigger-not-null ( -- string ) : insert-trigger-not-null ( -- string )
[ [
<" <"
CREATE TRIGGER fki_${table}_${foreign-table}_id CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
BEFORE INSERT ON ${table} BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN 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 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; END;
"> interpolate "> interpolate
] with-string-writer ; ] with-string-writer ;
@ -248,11 +250,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: update-trigger ( -- string ) : update-trigger ( -- string )
[ [
<" <"
CREATE TRIGGER fku_${table}_${foreign-table}_id CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
BEFORE UPDATE ON ${table} BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN 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 (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL; WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END; END;
"> interpolate "> interpolate
] with-string-writer ; ] with-string-writer ;
@ -260,12 +262,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: update-trigger-not-null ( -- string ) : update-trigger-not-null ( -- string )
[ [
<" <"
CREATE TRIGGER fku_${table}_${foreign-table}_id CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
BEFORE UPDATE ON ${table} BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN 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 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; END;
"> interpolate "> interpolate
] with-string-writer ; ] with-string-writer ;
@ -273,11 +275,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: delete-trigger-restrict ( -- string ) : delete-trigger-restrict ( -- string )
[ [
<" <"
CREATE TRIGGER fkd_${table}_${foreign-table}_id CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
BEFORE DELETE ON ${foreign-table} BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"') 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} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL; WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
END; END;
"> interpolate "> interpolate
] with-string-writer ; ] with-string-writer ;
@ -285,10 +287,10 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: delete-trigger-cascade ( -- string ) : delete-trigger-cascade ( -- string )
[ [
<" <"
CREATE TRIGGER fkd_${table}_${foreign-table}_id CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
BEFORE DELETE ON ${foreign-table} BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN 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; END;
"> interpolate "> interpolate
] with-string-writer ; ] with-string-writer ;
@ -321,7 +323,7 @@ M: sqlite-db-connection compound ( string seq -- new-string )
{ "default" [ first number>string " " glue ] } { "default" [ first number>string " " glue ] }
{ "references" [ { "references" [
[ >reference-string ] keep [ >reference-string ] keep
first2 [ "foreign-table" set ] first2 [ db-table-name "foreign-table-name" set ]
[ "foreign-table-id" set ] bi* [ "foreign-table-id" set ] bi*
create-sqlite-triggers create-sqlite-triggers
] } ] }

4
basis/db/types/types.factor
View File

@ -49,7 +49,7 @@ ERROR: no-slot ;
ERROR: not-persistent class ; ERROR: not-persistent class ;
: db-table ( class -- object ) : db-table-name ( class -- object )
dup "db-table" word-prop [ ] [ not-persistent ] ?if ; dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- object ) : db-columns ( class -- object )
@ -165,7 +165,7 @@ ERROR: no-column column ;
: >reference-string ( string pair -- string ) : >reference-string ( string pair -- string )
first2 first2
[ [ unparse " " glue ] [ db-columns ] bi ] dip [ [ db-table-name " " glue ] [ db-columns ] bi ] dip
swap [ column-name>> = ] with find nip swap [ column-name>> = ] with find nip
[ no-column ] unless* [ no-column ] unless*
column-name>> "(" ")" surround append ; column-name>> "(" ")" surround append ;

19
basis/editors/editors.factor
View File

@ -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. ! See http://factorcode.org/license.txt for BSD license.
USING: parser lexer kernel namespaces sequences definitions USING: parser lexer kernel namespaces sequences definitions
io.files io.backend io.pathnames io summary continuations io.files io.backend io.pathnames io summary continuations
tools.crossref tools.vocabs prettyprint source-files assocs tools.crossref tools.vocabs prettyprint source-files assocs
vocabs vocabs.loader splitting accessors ; vocabs vocabs.loader splitting accessors debugger prettyprint
help.topics ;
IN: editors IN: editors
TUPLE: no-edit-hook ; TUPLE: no-edit-hook ;
@ -29,11 +30,21 @@ SYMBOL: edit-hook
[ (normalize-path) ] dip edit-hook get-global [ (normalize-path) ] dip edit-hook get-global
[ call ] [ no-edit-hook edit-location ] if* ; [ 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 -- ) : 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 -- ) : edit-vocab ( name -- )
vocab-source-path 1 edit-location ; >vocab-link edit ;
GENERIC: error-file ( error -- file ) GENERIC: error-file ( error -- file )

37
basis/endian/endian.factor
View File

@ -1,39 +1,36 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types namespaces io.binary fry USING: alien.c-types namespaces io.binary fry
kernel math ; kernel math grouping sequences math.bitwise ;
IN: endian IN: endian
SINGLETONS: big-endian little-endian ; SINGLETONS: big-endian little-endian ;
: native-endianness ( -- class ) : compute-native-endianness ( -- class )
1 <int> *char 0 = big-endian little-endian ? ; 1 <int> *char 0 = big-endian little-endian ? ;
: >signed ( x n -- y ) SYMBOL: native-endianness
2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; native-endianness [ compute-native-endianness ] initialize
native-endianness \ native-endianness set-global
SYMBOL: endianness SYMBOL: endianness
endianness [ native-endianness get-global ] initialize
\ native-endianness get-global endianness set-global HOOK: >native-endian native-endianness ( obj n -- bytes )
HOOK: >native-endian native-endianness ( obj n -- str )
M: big-endian >native-endian >be ; M: big-endian >native-endian >be ;
M: little-endian >native-endian >le ; 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: big-endian unsigned-native-endian> be> ;
M: little-endian unsigned-native-endian> le> ; M: little-endian unsigned-native-endian> le> ;
: signed-native-endian> ( obj n -- str ) : signed-native-endian> ( obj n -- n' )
[ unsigned-native-endian> ] dip >signed ; [ unsigned-native-endian> ] dip >signed ;
HOOK: >endian endianness ( obj n -- str ) HOOK: >endian endianness ( obj n -- bytes )
M: big-endian >endian >be ; M: big-endian >endian >be ;
@ -45,13 +42,13 @@ M: big-endian endian> be> ;
M: little-endian endian> le> ; M: little-endian endian> le> ;
HOOK: unsigned-endian> endianness ( obj -- str ) HOOK: unsigned-endian> endianness ( obj -- bytes )
M: big-endian unsigned-endian> be> ; M: big-endian unsigned-endian> be> ;
M: little-endian unsigned-endian> le> ; M: little-endian unsigned-endian> le> ;
: signed-endian> ( obj n -- str ) : signed-endian> ( obj n -- bytes )
[ unsigned-endian> ] dip >signed ; [ unsigned-endian> ] dip >signed ;
: with-endianness ( endian quot -- ) : with-endianness ( endian quot -- )
@ -65,3 +62,15 @@ M: little-endian unsigned-endian> le> ;
: with-native-endian ( quot -- ) : with-native-endian ( quot -- )
\ native-endianness get-global swap with-endianness ; inline \ 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

13
basis/furnace/chloe-tags/chloe-tags.factor
View File

@ -81,11 +81,18 @@ CHLOE: a
CHLOE: base CHLOE: base
compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ; 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 -- ) : compile-hidden-form-fields ( for -- )
'[ '[
_ [ "," split [ hidden render>xml ] map ] [ f ] if* _ render-hidden
nested-forms get " " join f like nested-forms-key hidden-form-field>xml hidden-nested-fields
[ [ modify-form ] each-responder ] with-string-writer <unescaped> form-modifications
[XML <div style="display: none;"><-><-><-></div> XML] [XML <div style="display: none;"><-><-><-></div> XML]
] [code] ; ] [code] ;

4
basis/furnace/furnace-tests.factor
View File

@ -1,7 +1,7 @@
IN: furnace.tests IN: furnace.tests
USING: http http.server.dispatchers http.server.responses USING: http http.server.dispatchers http.server.responses
http.server furnace furnace.utilities tools.test kernel 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 ; TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ; : <funny-dispatcher> funny-dispatcher new-dispatcher ;
@ -31,7 +31,7 @@ M: base-path-check-responder call-responder*
] unit-test ] unit-test
[ "<input type=\"hidden\" value=\"&amp;&amp;&amp;\" name=\"foo\"/>" ] [ "<input type=\"hidden\" value=\"&amp;&amp;&amp;\" name=\"foo\"/>" ]
[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] [ "&&&" "foo" hidden-form-field xml>string ]
unit-test unit-test
[ f ] [ <request> request [ referrer ] with-variable ] unit-test [ f ] [ <request> request [ referrer ] with-variable ] unit-test

10
basis/furnace/utilities/utilities-docs.factor
View File

@ -20,13 +20,13 @@ HELP: each-responder
{ $description "Applies the quotation to each responder involved in processing the current request." } ; { $description "Applies the quotation to each responder involved in processing the current request." } ;
HELP: hidden-form-field HELP: hidden-form-field
{ $values { "value" string } { "name" string } } { $values { "value" string } { "name" string } { "xml" "an XML chunk" } }
{ $description "Renders an HTML hidden form field tag." } { $description "Renders an HTML hidden form field tag as XML." }
{ $notes "This word is used by session management, conversation scope and asides." } { $notes "This word is used by session management, conversation scope and asides." }
{ $examples { $examples
{ $example { $example
"USING: furnace.utilities io ;" "USING: furnace.utilities io xml.writer ;"
"\"bar\" \"foo\" hidden-form-field nl" "\"bar\" \"foo\" hidden-form-field write-xml nl"
"<input type=\"hidden\" value=\"bar\" name=\"foo\"/>" "<input type=\"hidden\" value=\"bar\" name=\"foo\"/>"
} }
} ; } ;
@ -38,7 +38,7 @@ HELP: link-attr
{ $examples "Conversation scope adds attributes to link tags." } ; { $examples "Conversation scope adds attributes to link tags." } ;
HELP: modify-form 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 } "." } { $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } { $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." } ; { $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;

12
basis/furnace/utilities/utilities.factor
View File

@ -77,18 +77,18 @@ GENERIC: link-attr ( tag responder -- )
M: object link-attr 2drop ; 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 [ over [
[XML <input type="hidden" value=<-> name=<->/> XML] [XML <input type="hidden" value=<-> name=<->/> XML]
] [ drop ] if ; ] [ drop ] if ;
: hidden-form-field ( value name -- )
hidden-form-field>xml write-xml ;
: nested-forms-key "__n" ; : nested-forms-key "__n" ;
: request-params ( request -- assoc ) : request-params ( request -- assoc )

20
basis/generalizations/generalizations-docs.factor
View File

@ -58,7 +58,7 @@ HELP: npick
"placed on the top of the stack." "placed on the top of the stack."
} }
{ $examples { $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 } ":" "Some core words expressed in terms of " { $link npick } ":"
{ $table { $table
{ { $link dup } { $snippet "1 npick" } } { { $link dup } { $snippet "1 npick" } }
@ -75,7 +75,7 @@ HELP: ndup
"placed on the top of the stack." "placed on the top of the stack."
} }
{ $examples { $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 } ":" "Some core words expressed in terms of " { $link ndup } ":"
{ $table { $table
{ { $link dup } { $snippet "1 ndup" } } { { $link dup } { $snippet "1 ndup" } }
@ -91,7 +91,7 @@ HELP: nnip
"for any number of items." "for any number of items."
} }
{ $examples { $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 } ":" "Some core words expressed in terms of " { $link nnip } ":"
{ $table { $table
{ { $link nip } { $snippet "1 nnip" } } { { $link nip } { $snippet "1 nnip" } }
@ -106,7 +106,7 @@ HELP: ndrop
"for any number of items." "for any number of items."
} }
{ $examples { $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 } ":" "Some core words expressed in terms of " { $link ndrop } ":"
{ $table { $table
{ { $link drop } { $snippet "1 ndrop" } } { { $link drop } { $snippet "1 ndrop" } }
@ -121,7 +121,7 @@ HELP: nrot
"number of items on the stack. " "number of items on the stack. "
} }
{ $examples { $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 } ":" "Some core words expressed in terms of " { $link nrot } ":"
{ $table { $table
{ { $link swap } { $snippet "1 nrot" } } { { $link swap } { $snippet "1 nrot" } }
@ -135,7 +135,7 @@ HELP: -nrot
"number of items on the stack. " "number of items on the stack. "
} }
{ $examples { $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 } ":" "Some core words expressed in terms of " { $link -nrot } ":"
{ $table { $table
{ { $link swap } { $snippet "1 -nrot" } } { { $link swap } { $snippet "1 -nrot" } }
@ -151,8 +151,8 @@ HELP: ndip
"stack. The quotation can consume and produce any number of items." "stack. The quotation can consume and produce any number of items."
} }
{ $examples { $examples
{ $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "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 3 [ drop ] 2 ndip .s clear" "2\n3" }
"Some core words expressed in terms of " { $link ndip } ":" "Some core words expressed in terms of " { $link ndip } ":"
{ $table { $table
{ { $link dip } { $snippet "1 ndip" } } { { $link dip } { $snippet "1 ndip" } }
@ -168,7 +168,7 @@ HELP: nslip
"removed from the stack, the quotation called, and the items restored." "removed from the stack, the quotation called, and the items restored."
} }
{ $examples { $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 } ":" "Some core words expressed in terms of " { $link nslip } ":"
{ $table { $table
{ { $link slip } { $snippet "1 nslip" } } { { $link slip } { $snippet "1 nslip" } }
@ -184,7 +184,7 @@ HELP: nkeep
"saved, the quotation called, and the items restored." "saved, the quotation called, and the items restored."
} }
{ $examples { $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 } ":" "Some core words expressed in terms of " { $link nkeep } ":"
{ $table { $table
{ { $link keep } { $snippet "1 nkeep" } } { { $link keep } { $snippet "1 nkeep" } }

2
basis/help/help.factor
View File

@ -118,7 +118,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
SYMBOL: help-hook SYMBOL: help-hook
help-hook global [ [ print-topic ] or ] change-at help-hook [ [ print-topic ] ] initialize
: help ( topic -- ) : help ( topic -- )
help-hook get call ; help-hook get call ;

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

@ -27,11 +27,11 @@ M: link summary
! Help articles ! Help articles
SYMBOL: articles SYMBOL: articles
articles global [ H{ } assoc-like ] change-at articles [ H{ } clone ] initialize
SYMBOL: article-xref SYMBOL: article-xref
article-xref global [ H{ } assoc-like ] change-at article-xref [ H{ } clone ] initialize
GENERIC: article-name ( topic -- string ) GENERIC: article-name ( topic -- string )
GENERIC: article-title ( topic -- string ) GENERIC: article-title ( topic -- string )

6
basis/html/components/components-docs.factor
View File

@ -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." } ; { $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 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 HELP: inspector
{ $description "Inspector components render an arbitrary object by passing it to the " { $link describe } " word." } ; { $description "Inspector components render an arbitrary object by passing it to the " { $link describe } " word." } ;
@ -90,6 +93,7 @@ $nl
{ $subsection inspector } { $subsection inspector }
{ $subsection comparison } { $subsection comparison }
{ $subsection html } { $subsection html }
{ $subsection xml }
"Tuple components:" "Tuple components:"
{ $subsection field } { $subsection field }
{ $subsection password } { $subsection password }

5
basis/html/components/components.factor
View File

@ -171,3 +171,8 @@ M: comparison render*
SINGLETON: html SINGLETON: html
M: html render* 2drop <unescaped> ; M: html render* 2drop <unescaped> ;
! XML component
SINGLETON: xml
M: xml render* 2drop ;

7
basis/html/html-docs.factor Normal file
View File

@ -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." } ;

2
basis/html/html.factor
View File

@ -15,7 +15,7 @@ IN: html
</head> </head>
<body><-></body> <body><-></body>
</html> </html>
XML> ; inline XML> ;
: render-error ( message -- xml ) : render-error ( message -- xml )
[XML <span class="error"><-></span> XML] ; [XML <span class="error"><-></span> XML] ;

5
basis/html/templates/chloe/chloe-docs.factor
View File

@ -1,8 +1,8 @@
IN: html.templates.chloe 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 html.templates.chloe.syntax
html.templates.chloe.compiler html.templates.chloe.components html.templates.chloe.compiler html.templates.chloe.components
math xml.data strings quotations namespaces ; math strings quotations namespaces ;
HELP: <chloe> HELP: <chloe>
{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" 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:field" } { $link field } }
{ { $snippet "t:hidden" } { $link hidden } } { { $snippet "t:hidden" } { $link hidden } }
{ { $snippet "t:html" } { $link html } } { { $snippet "t:html" } { $link html } }
{ { $snippet "t:xml" } { $link xml } }
{ { $snippet "t:inspector" } { $link inspector } } { { $snippet "t:inspector" } { $link inspector } }
{ { $snippet "t:label" } { $link label } } { { $snippet "t:label" } { $link label } }
{ { $snippet "t:link" } { $link link } } { { $snippet "t:link" } { $link link } }

1
basis/html/templates/chloe/chloe.factor
View File

@ -95,6 +95,7 @@ COMPONENT: password
COMPONENT: choice COMPONENT: choice
COMPONENT: checkbox COMPONENT: checkbox
COMPONENT: code COMPONENT: code
COMPONENT: xml
SYMBOL: template-cache SYMBOL: template-cache

2
basis/html/templates/chloe/syntax/syntax.factor
View File

@ -11,7 +11,7 @@ html.templates ;
SYMBOL: tags SYMBOL: tags
tags global [ H{ } clone or ] change-at tags [ H{ } clone ] initialize
: define-chloe-tag ( name quot -- ) swap tags get set-at ; : define-chloe-tag ( name quot -- ) swap tags get set-at ;

3
basis/http/client/client-docs.factor
View File

@ -56,8 +56,7 @@ HELP: http-request
HELP: with-http-request HELP: with-http-request
{ $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } } { $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." } { $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" } "." } ;
{ $errors "Throws an error if the HTTP request fails." } ;
ARTICLE: "http.client.get" "GET requests with the HTTP client" 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:" "Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"

7
basis/http/client/client.factor
View File

@ -141,12 +141,15 @@ ERROR: download-failed response ;
: check-response ( response -- response ) : check-response ( response -- response )
dup code>> success? [ download-failed ] unless ; 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 ( request quot -- response )
[ (with-http-request) check-response ] with-destructors ; inline [ (with-http-request) ] with-destructors ; inline
: http-request ( request -- response data ) : http-request ( request -- response data )
[ [ % ] with-http-request ] B{ } make [ [ % ] with-http-request ] B{ } make
over content-charset>> decode ; over content-charset>> decode check-response-with-body ;
: <get-request> ( url -- request ) : <get-request> ( url -- request )
"GET" <client-request> ; "GET" <client-request> ;

6
basis/http/http-docs.factor
View File

@ -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." } { $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" } ; { $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" ARTICLE: "http.cookies" "HTTP cookies"
"Every " { $link request } " and " { $link response } " instance can contain cookies." "Every " { $link request } " and " { $link response } " instance can contain cookies."
$nl $nl

5
basis/http/http-tests.factor
View File

@ -359,3 +359,8 @@ SYMBOL: a
! Test cloning ! Test cloning
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test [ 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 [ 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
basis/http/http.factor
View File

@ -7,7 +7,8 @@ calendar.format present urls fry
io io.encodings io.encodings.iana io.encodings.binary io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit io.crlf io.encodings.8-bit io.crlf
unicode.case unicode.categories unicode.case unicode.categories
http.parsers ; http.parsers
base64 ;
IN: http IN: http
: (read-header) ( -- alist ) : (read-header) ( -- alist )
@ -142,6 +143,9 @@ cookies ;
: set-header ( request/response value key -- request/response ) : set-header ( request/response value key -- request/response )
pick header>> set-at ; pick header>> set-at ;
: set-basic-auth ( request username password -- request )
":" glue >base64 "Basic " prepend "Authorization" set-header ;
: <request> ( -- request ) : <request> ( -- request )
request new request new
"1.1" >>version "1.1" >>version
@ -156,6 +160,7 @@ cookies ;
: header ( request/response key -- value ) : header ( request/response key -- value )
swap header>> at ; swap header>> at ;
TUPLE: response TUPLE: response
version version
code code

2
basis/http/server/server.factor
View File

@ -161,7 +161,7 @@ C: <trivial-responder> trivial-responder
M: trivial-responder call-responder* nip response>> clone ; 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' ) : invert-slice ( slice -- slice' )
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ; dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;

2
basis/http/server/static/static-docs.factor
View File

@ -38,7 +38,7 @@ $nl
"If all you want to do is serve files from a directory, the following phrase does the trick:" "If all you want to do is serve files from a directory, the following phrase does the trick:"
{ $code { $code
"USING: namespaces http.server http.server.static ;" "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" "8080 httpd"
} }
{ $subsection "http.server.static.extend" } ; { $subsection "http.server.static.extend" } ;

5
basis/http/server/static/static.factor
View File

@ -45,9 +45,8 @@ TUPLE: file-responder root hook special allow-listings ;
[ file-responder get hook>> call ] [ 2drop <304> ] if ; [ file-responder get hook>> call ] [ 2drop <304> ] if ;
: serving-path ( filename -- filename ) : serving-path ( filename -- filename )
file-responder get root>> trim-tail-separators [ file-responder get root>> trim-tail-separators "/" ] dip
"/" "" or trim-head-separators 3append ;
rot "" or trim-head-separators 3append ;
: serve-file ( filename -- response ) : serve-file ( filename -- response )
dup mime-type dup mime-type

1
basis/images/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

0
extra/graphics/authors.txt → basis/images/bitmap/authors.txt Normal file → Executable file
View File

24
basis/images/bitmap/bitmap-tests.factor Normal file
View File

@ -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

89
extra/graphics/bitmap/bitmap.factor → basis/images/bitmap/bitmap.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2007, 2009 Doug Coleman. ! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays byte-arrays columns USING: accessors alien alien.c-types arrays byte-arrays columns
combinators fry grouping io io.binary io.encodings.binary combinators fry grouping io io.binary io.encodings.binary io.files
io.files kernel libc macros math math.bitwise math.functions kernel macros math math.bitwise math.functions namespaces sequences
namespaces opengl opengl.gl prettyprint sequences strings strings images endian summary ;
summary ui ui.gadgets.panes ; IN: images.bitmap
IN: graphics.bitmap
TUPLE: bitmap-image < image ;
! Currently can only handle 24/32bit bitmaps. ! Currently can only handle 24/32bit bitmaps.
! Handles row-reversed bitmaps (their height is negative) ! Handles row-reversed bitmaps (their height is negative)
@ -13,41 +14,24 @@ IN: graphics.bitmap
TUPLE: bitmap magic size reserved offset header-length width TUPLE: bitmap magic size reserved offset header-length width
height planes bit-count compression size-image height planes bit-count compression size-image
x-pels y-pels color-used color-important rgb-quads color-index x-pels y-pels color-used color-important rgb-quads color-index
alpha-channel-zero? buffer ;
array ;
: array-copy ( bitmap array -- bitmap array' ) : array-copy ( bitmap array -- bitmap array' )
over size-image>> abs memory>byte-array ; over size-image>> abs memory>byte-array ;
MACRO: (nbits>bitmap) ( bits -- ) : 8bit>buffer ( bitmap -- array )
[ -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 )
[ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ] [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
[ color-index>> >array ] bi [ swap nth ] with map concat ; [ color-index>> >array ] bi [ swap nth ] with map concat ;
ERROR: bmp-not-supported n ; ERROR: bmp-not-supported n ;
: raw-bitmap>array ( bitmap -- array ) : raw-bitmap>buffer ( bitmap -- array )
dup bit-count>> dup bit-count>>
{ {
{ 32 [ color-index>> ] } { 32 [ color-index>> ] }
{ 24 [ color-index>> ] } { 24 [ color-index>> ] }
{ 16 [ bmp-not-supported ] } { 16 [ bmp-not-supported ] }
{ 8 [ 8bit>array ] } { 8 [ 8bit>buffer ] }
{ 4 [ bmp-not-supported ] } { 4 [ bmp-not-supported ] }
{ 2 [ bmp-not-supported ] } { 2 [ bmp-not-supported ] }
{ 1 [ bmp-not-supported ] } { 1 [ bmp-not-supported ] }
@ -95,19 +79,58 @@ M: bitmap-magic summary
dup rgb-quads-length read >>rgb-quads dup rgb-quads-length read >>rgb-quads
dup color-index-length read >>color-index ; dup color-index-length read >>color-index ;
: (load-bitmap) ( path -- bitmap ) : load-bitmap-data ( path -- bitmap )
binary [ binary [
bitmap new bitmap new
parse-file-header parse-bitmap-header parse-bitmap parse-file-header parse-bitmap-header parse-bitmap
] with-file-reader ; ] with-file-reader ;
: alpha-channel-zero? ( bitmap -- ? ) : process-bitmap-data ( bitmap -- bitmap )
array>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ; dup raw-bitmap>buffer >>buffer ;
: load-bitmap ( path -- bitmap ) : load-bitmap ( path -- bitmap )
(load-bitmap) load-bitmap-data process-bitmap-data ;
dup raw-bitmap>array >>array
dup alpha-channel-zero? >>alpha-channel-zero? ; 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 ; : write2 ( n -- ) 2 >le write ;
: write4 ( n -- ) 4 >le write ; : write4 ( n -- ) 4 >le write ;
@ -116,7 +139,7 @@ M: bitmap-magic summary
binary [ binary [
B{ CHAR: B CHAR: M } write B{ CHAR: B CHAR: M } write
[ [
array>> length 14 + 40 + write4 buffer>> length 14 + 40 + write4
0 write4 0 write4
54 write4 54 write4
40 write4 40 write4

66
basis/images/images.factor Normal file
View File

@ -0,0 +1,66 @@
! 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 specialized-arrays.uint
specialized-arrays.ushort specialized-arrays.float ;
IN: images
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
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-floats ( byte-array -- byte-array )
byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
: normalize-component-order ( image -- image )
dup component-order>>
{
{ RGBA [ ] }
{ R32G32B32A32 [
[ normalize-floats ] change-bitmap
] }
{ R32G32B32 [
[ normalize-floats add-dummy-alpha ] change-bitmap
] }
{ R16G16B16A16 [
[ byte-array>ushort-array [ -8 shift ] B{ } map-as ] change-bitmap
] }
{ R16G16B16 [
[
byte-array>ushort-array [ -8 shift ] B{ } map-as add-dummy-alpha
] change-bitmap
] }
{ BGRA [
[
4 <sliced-groups> dup [ 3 head-slice reverse-here ] each
] change-bitmap
] }
{ RGB [ [ add-dummy-alpha ] change-bitmap ] }
{ BGR [
[
3 <sliced-groups>
[ [ 3 head-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
extra/graphics/bitmap/authors.txt → basis/images/loader/authors.txt Executable file → Normal file
View File

19
basis/images/loader/loader.factor Normal file
View File

@ -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 ;

0
extra/graphics/tags.txt → basis/images/tags.txt
View File

0
extra/graphics/bitmap/test-images/1bit.bmp → basis/images/test-images/1bit.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.6 KiB

After

Width:  |  Height:  |  Size: 1.6 KiB

BIN
basis/images/test-images/octagon.tiff Normal file
View File

Binary file not shown.

0
extra/graphics/tiff/rgb.tiff → basis/images/test-images/rgb.tiff
View File

0
extra/graphics/bitmap/test-images/rgb4bit.bmp → basis/images/test-images/rgb4bit.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 5.2 KiB

After

Width:  |  Height:  |  Size: 5.2 KiB

0
extra/graphics/bitmap/test-images/rgb8bit.bmp → basis/images/test-images/rgb8bit.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 11 KiB

After

Width:  |  Height:  |  Size: 11 KiB

0
extra/graphics/bitmap/test-images/thiswayup24.bmp → basis/images/test-images/thiswayup24.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 59 KiB

After

Width:  |  Height:  |  Size: 59 KiB

0
extra/graphics/tiff/authors.txt → basis/images/tiff/authors.txt
View File

10
basis/images/tiff/tiff-tests.factor Executable file
View File

@ -0,0 +1,10 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test images.tiff ;
IN: images.tiff.tests
: tiff-test-path ( -- path )
"resource:extra/images/test-images/rgb.tiff" ;
: tiff-test-path2 ( -- path )
"resource:extra/images/test-images/octagon.tiff" ;

374
basis/images/tiff/tiff.factor Executable file
View File

@ -0,0 +1,374 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs byte-arrays classes combinators
compression.lzw constructors endian fry grouping images io
io.binary io.encodings.ascii io.encodings.binary
io.encodings.string io.encodings.utf8 io.files kernel math
math.bitwise math.order math.parser pack prettyprint sequences
strings math.vectors ;
IN: images.tiff
TUPLE: tiff-image < image ;
TUPLE: parsed-tiff endianness the-answer ifd-offset ifds ;
CONSTRUCTOR: parsed-tiff ( -- tiff ) V{ } clone >>ifds ;
TUPLE: ifd count ifd-entries next
processed-tags strips bitmap ;
CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
TUPLE: ifd-entry tag type count offset/value ;
CONSTRUCTOR: ifd-entry ( tag type count offset/value -- ifd-entry ) ;
SINGLETONS: photometric-interpretation
photometric-interpretation-white-is-zero
photometric-interpretation-black-is-zero
photometric-interpretation-rgb
photometric-interpretation-palette-color ;
ERROR: bad-photometric-interpretation n ;
: lookup-photometric-interpretation ( n -- singleton )
{
{ 0 [ photometric-interpretation-white-is-zero ] }
{ 1 [ photometric-interpretation-black-is-zero ] }
{ 2 [ photometric-interpretation-rgb ] }
{ 3 [ photometric-interpretation-palette-color ] }
[ bad-photometric-interpretation ]
} case ;
SINGLETONS: compression
compression-none
compression-CCITT-2
compression-lzw
compression-pack-bits ;
ERROR: bad-compression n ;
: lookup-compression ( n -- compression )
{
{ 1 [ compression-none ] }
{ 2 [ compression-CCITT-2 ] }
{ 5 [ compression-lzw ] }
{ 32773 [ compression-pack-bits ] }
[ bad-compression ]
} case ;
SINGLETONS: resolution-unit
resolution-unit-none
resolution-unit-inch
resolution-unit-centimeter ;
ERROR: bad-resolution-unit n ;
: lookup-resolution-unit ( n -- object )
{
{ 1 [ resolution-unit-none ] }
{ 2 [ resolution-unit-inch ] }
{ 3 [ resolution-unit-centimeter ] }
[ bad-resolution-unit ]
} case ;
SINGLETONS: predictor
predictor-none
predictor-horizontal-differencing ;
ERROR: bad-predictor n ;
: lookup-predictor ( n -- object )
{
{ 1 [ predictor-none ] }
{ 2 [ predictor-horizontal-differencing ] }
[ bad-predictor ]
} case ;
SINGLETONS: planar-configuration
planar-configuration-chunky
planar-configuration-planar ;
ERROR: bad-planar-configuration n ;
: lookup-planar-configuration ( n -- object )
{
{ 1 [ planar-configuration-chunky ] }
{ 2 [ planar-configuration-planar ] }
[ bad-planar-configuration ]
} case ;
SINGLETONS: sample-format
sample-format-unsigned-integer
sample-format-signed-integer
sample-format-ieee-float
sample-format-undefined-data ;
ERROR: bad-sample-format n ;
: lookup-sample-format ( sequence -- object )
[
{
{ 1 [ sample-format-unsigned-integer ] }
{ 2 [ sample-format-signed-integer ] }
{ 3 [ sample-format-ieee-float ] }
{ 4 [ sample-format-undefined-data ] }
[ bad-sample-format ]
} case
] map ;
SINGLETONS: extra-samples
extra-samples-unspecified-alpha-data
extra-samples-associated-alpha-data
extra-samples-unassociated-alpha-data ;
ERROR: bad-extra-samples n ;
: lookup-extra-samples ( sequence -- object )
{
{ 0 [ extra-samples-unspecified-alpha-data ] }
{ 1 [ extra-samples-associated-alpha-data ] }
{ 2 [ extra-samples-unassociated-alpha-data ] }
[ bad-extra-samples ]
} case ;
SINGLETONS: image-length image-width x-resolution y-resolution
rows-per-strip strip-offsets strip-byte-counts bits-per-sample
samples-per-pixel new-subfile-type orientation software
date-time photoshop exif-ifd sub-ifd inter-color-profile
xmp iptc fill-order document-name page-number page-name
x-position y-position
unhandled-ifd-entry ;
ERROR: bad-tiff-magic bytes ;
: tiff-endianness ( byte-array -- ? )
{
{ B{ CHAR: M CHAR: M } [ big-endian ] }
{ B{ CHAR: I CHAR: I } [ little-endian ] }
[ bad-tiff-magic ]
} case ;
: read-header ( tiff -- tiff )
2 read tiff-endianness [ >>endianness ] keep
[
2 read endian> >>the-answer
4 read endian> >>ifd-offset
] with-endianness ;
: push-ifd ( tiff ifd -- tiff ) over ifds>> push ;
: read-ifd ( -- ifd )
2 read endian>
2 read endian>
4 read endian>
4 read endian> <ifd-entry> ;
: read-ifds ( tiff -- tiff )
dup ifd-offset>> seek-absolute seek-input
2 read endian>
dup [ read-ifd ] replicate
4 read endian>
[ <ifd> push-ifd ] [ 0 = [ read-ifds ] unless ] bi ;
ERROR: no-tag class ;
: ?at ( key assoc -- value/key ? )
dupd at* [ nip t ] [ drop f ] if ; inline
: find-tag ( idf class -- tag )
swap processed-tags>> ?at [ no-tag ] unless ;
: tag? ( idf class -- tag )
swap processed-tags>> key? ;
: read-strips ( ifd -- ifd )
dup
[ strip-byte-counts find-tag ]
[ strip-offsets find-tag ] bi
2dup [ integer? ] both? [
seek-absolute seek-input read 1array
] [
[ seek-absolute seek-input read ] { } 2map-as
] if >>strips ;
ERROR: unknown-ifd-type n ;
: bytes>bits ( n/byte-array -- n )
dup byte-array? [ byte-array>bignum ] when ;
: value-length ( ifd-entry -- n )
[ count>> ] [ type>> ] bi {
{ 1 [ ] }
{ 2 [ ] }
{ 3 [ 2 * ] }
{ 4 [ 4 * ] }
{ 5 [ 8 * ] }
{ 6 [ ] }
{ 7 [ ] }
{ 8 [ 2 * ] }
{ 9 [ 4 * ] }
{ 10 [ 8 * ] }
{ 11 [ 4 * ] }
{ 12 [ 8 * ] }
{ 13 [ 4 * ] }
[ unknown-ifd-type ]
} case ;
ERROR: bad-small-ifd-type n ;
: adjust-offset/value ( ifd-entry -- obj )
[ offset/value>> 4 >endian ] [ type>> ] bi
{
{ 1 [ 1 head endian> ] }
{ 3 [ 2 head endian> ] }
{ 4 [ endian> ] }
{ 6 [ 1 head endian> 8 >signed ] }
{ 8 [ 2 head endian> 16 >signed ] }
{ 9 [ endian> 32 >signed ] }
{ 11 [ endian> bits>float ] }
{ 13 [ endian> 32 >signed ] }
[ bad-small-ifd-type ]
} case ;
: offset-bytes>obj ( bytes type -- obj )
{
{ 1 [ ] } ! blank
{ 2 [ ] } ! read c strings here
{ 3 [ 2 <sliced-groups> [ endian> ] map ] }
{ 4 [ 4 <sliced-groups> [ endian> ] map ] }
{ 5 [ 8 <sliced-groups> [ "II" unpack first2 / ] map ] }
{ 6 [ [ 8 >signed ] map ] }
{ 7 [ ] } ! blank
{ 8 [ 2 <sliced-groups> [ endian> 16 >signed ] map ] }
{ 9 [ 4 <sliced-groups> [ endian> 32 >signed ] map ] }
{ 10 [ 8 group [ "ii" unpack first2 / ] map ] }
{ 11 [ 4 group [ "f" unpack ] map ] }
{ 12 [ 8 group [ "d" unpack ] map ] }
[ unknown-ifd-type ]
} case ;
: ifd-entry-value ( ifd-entry -- n )
dup value-length 4 <= [
adjust-offset/value
] [
[ offset/value>> seek-absolute seek-input ]
[ value-length read ]
[ type>> ] tri offset-bytes>obj
] if ;
: process-ifd-entry ( ifd-entry -- value class )
[ ifd-entry-value ] [ tag>> ] bi {
{ 254 [ new-subfile-type ] }
{ 256 [ image-width ] }
{ 257 [ image-length ] }
{ 258 [ bits-per-sample ] }
{ 259 [ lookup-compression compression ] }
{ 262 [ lookup-photometric-interpretation photometric-interpretation ] }
{ 266 [ fill-order ] }
{ 269 [ ascii decode document-name ] }
{ 273 [ strip-offsets ] }
{ 274 [ orientation ] }
{ 277 [ samples-per-pixel ] }
{ 278 [ rows-per-strip ] }
{ 279 [ strip-byte-counts ] }
{ 282 [ first x-resolution ] }
{ 283 [ first y-resolution ] }
{ 284 [ planar-configuration ] }
{ 285 [ page-name ] }
{ 286 [ x-position ] }
{ 287 [ y-position ] }
{ 296 [ lookup-resolution-unit resolution-unit ] }
{ 297 [ page-number ] }
{ 305 [ ascii decode software ] }
{ 306 [ ascii decode date-time ] }
{ 317 [ lookup-predictor predictor ] }
{ 330 [ sub-ifd ] }
{ 338 [ lookup-extra-samples extra-samples ] }
{ 339 [ lookup-sample-format sample-format ] }
{ 700 [ utf8 decode xmp ] }
{ 34377 [ photoshop ] }
{ 34665 [ exif-ifd ] }
{ 33723 [ iptc ] }
{ 34675 [ inter-color-profile ] }
[ nip unhandled-ifd-entry swap ]
} case ;
: process-ifd ( ifd -- ifd )
dup ifd-entries>>
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
ERROR: unhandled-compression compression ;
: (uncompress-strips) ( strips compression -- uncompressed-strips )
{
{ compression-none [ ] }
{ compression-lzw [ [ lzw-uncompress ] map ] }
[ unhandled-compression ]
} case ;
: uncompress-strips ( ifd -- ifd )
dup '[
_ compression find-tag (uncompress-strips)
] change-strips ;
: strips>bitmap ( ifd -- ifd )
dup strips>> concat >>bitmap ;
: (strips-predictor) ( ifd -- ifd )
[ ]
[ image-width find-tag ]
[ samples-per-pixel find-tag ] tri
[ * ] keep
'[
_ group [ _ group [ rest ] [ first ] bi
[ v+ ] accumulate swap suffix concat ] map
concat >byte-array
] change-bitmap ;
: strips-predictor ( ifd -- ifd )
dup predictor tag? [
dup predictor find-tag
{
{ predictor-none [ ] }
{ predictor-horizontal-differencing [ (strips-predictor) ] }
[ bad-predictor ]
} case
] when ;
ERROR: unknown-component-order ifd ;
: fix-bitmap-endianness ( ifd -- ifd )
dup [ bitmap>> ] [ bits-per-sample find-tag ] bi
{
{ { 32 32 32 32 } [ 4 seq>native-endianness ] }
{ { 32 32 32 } [ 4 seq>native-endianness ] }
{ { 16 16 16 16 } [ 2 seq>native-endianness ] }
{ { 16 16 16 } [ 2 seq>native-endianness ] }
{ { 8 8 8 8 } [ ] }
{ { 8 8 8 } [ ] }
[ unknown-component-order ]
} case >>bitmap ;
: ifd-component-order ( ifd -- byte-order )
bits-per-sample find-tag {
{ { 32 32 32 32 } [ R32G32B32A32 ] }
{ { 32 32 32 } [ R32G32B32 ] }
{ { 16 16 16 16 } [ R16G16B16A16 ] }
{ { 16 16 16 } [ R16G16B16 ] }
{ { 8 8 8 8 } [ RGBA ] }
{ { 8 8 8 } [ RGB ] }
[ unknown-component-order ]
} case ;
: ifd>image ( ifd -- image )
{
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order ]
[ bitmap>> ]
} cleave tiff-image boa ;
: tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ;
: load-tiff ( path -- parsed-tiff )
binary [
<parsed-tiff>
read-header dup endianness>> [
read-ifds
dup ifds>> [
process-ifd read-strips
uncompress-strips
strips>bitmap
fix-bitmap-endianness
strips-predictor
drop
] each
] with-endianness
] with-file-reader ;
! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image )
drop load-tiff tiff>image ;

4
basis/io/encodings/iana/iana.factor
View File

@ -47,8 +47,8 @@ PRIVATE>
"resource:basis/io/encodings/iana/character-sets" "resource:basis/io/encodings/iana/character-sets"
utf8 <file-reader> make-aliases aliases set-global utf8 <file-reader> make-aliases aliases set-global
n>e-table global [ initial-n>e or ] change-at n>e-table [ initial-n>e ] initialize
e>n-table global [ initial-e>n or ] change-at e>n-table [ initial-e>n ] initialize
: register-encoding ( descriptor name -- ) : register-encoding ( descriptor name -- )
[ [

7
basis/io/launcher/windows/nt/nt-tests.factor Normal file → Executable file
View File

@ -37,11 +37,12 @@ IN: io.launcher.windows.nt.tests
"out.txt" temp-file ascii file-lines first "out.txt" temp-file ascii file-lines first
] unit-test ] unit-test
[ ] [ [ "( scratchpad ) " ] [
<process> <process>
console-vm "-run=listener" 2array >>command console-vm "-run=listener" 2array >>command
+closed+ >>stdin +closed+ >>stdin
try-process +stdout+ >>stderr
ascii [ input-stream get contents ] with-process-reader
] unit-test ] unit-test
: launcher-test-path ( -- str ) : launcher-test-path ( -- str )
@ -162,3 +163,5 @@ IN: io.launcher.windows.nt.tests
"append-test" temp-file ascii file-contents "append-test" temp-file ascii file-contents
] unit-test ] unit-test

55
basis/lists/lazy/lazy-docs.factor
View File

@ -1,11 +1,54 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax sequences strings lists ; USING: help.markup help.syntax sequences strings lists ;
IN: lists.lazy IN: lists.lazy
ABOUT: "lists.lazy"
ARTICLE: "lists.lazy" "Lazy lists"
"The " { $vocab-link "lists.lazy" } " vocabulary implements lazy lists and standard operations to manipulate them."
{ $subsection { "lists.lazy" "construction" } }
{ $subsection { "lists.lazy" "manipulation" } }
{ $subsection { "lists.lazy" "combinators" } }
{ $subsection { "lists.lazy" "io" } } ;
ARTICLE: { "lists.lazy" "combinators" } "Combinators for manipulating lazy lists"
"The following combinators create lazy lists from other lazy lists:"
{ $subsection lmap }
{ $subsection lfilter }
{ $subsection luntil }
{ $subsection lwhile }
{ $subsection lfrom-by }
{ $subsection lcomp }
{ $subsection lcomp* } ;
ARTICLE: { "lists.lazy" "io" } "Lazy list I/O"
"Input from a stream can be read through a lazy list, using the following words:"
{ $subsection lcontents }
{ $subsection llines } ;
ARTICLE: { "lists.lazy" "construction" } "Constructing lazy lists"
"Words for constructing lazy lists:"
{ $subsection lazy-cons }
{ $subsection 1lazy-list }
{ $subsection 2lazy-list }
{ $subsection 3lazy-list }
{ $subsection seq>list }
{ $subsection >list }
{ $subsection lfrom } ;
ARTICLE: { "lists.lazy" "manipulation" } "Manipulating lazy lists"
"To make new lazy lists from old ones:"
{ $subsection <memoized-cons> }
{ $subsection lappend }
{ $subsection lconcat }
{ $subsection lcartesian-product }
{ $subsection lcartesian-product* }
{ $subsection lmerge }
{ $subsection ltake } ;
HELP: lazy-cons HELP: lazy-cons
{ $values { "car" { $quotation "( -- X )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } { $values { "car" { $quotation "( -- elt )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } }
{ $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } { $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." }
{ $see-also cons car cdr nil nil? } ; { $see-also cons car cdr nil nil? } ;
@ -28,16 +71,12 @@ HELP: <memoized-cons>
{ $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } { $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." }
{ $see-also cons car cdr nil nil? } ; { $see-also cons car cdr nil nil? } ;
{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words { lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
HELP: lazy-map HELP: lazy-map
{ $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } } { $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } }
{ $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-map> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
HELP: lazy-map-with
{ $values { "value" "an object" } { "list" "a cons object" } { "quot" { $quotation "( obj elt -- X )" } } { "result" "resulting cons object" } }
{ $description "Variant of " { $link lazy-map } " which pushes a retained object on each invocation of the quotation." } ;
HELP: ltake HELP: ltake
{ $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } } { $values { "n" "a non negative integer" } { "list" "a cons object" } { "result" "resulting cons object" } }
{ $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; { $description "Outputs a lazy list containing the first n items in the list. This is done a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-take> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
@ -86,7 +125,7 @@ HELP: >list
{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." }
{ $see-also seq>list } ; { $see-also seq>list } ;
{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words { leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words
HELP: lconcat HELP: lconcat
{ $values { "list" "a list of lists" } { "result" "a list" } } { $values { "list" "a list of lists" } { "result" "a list" } }

2
basis/lists/lazy/lazy-tests.factor
View File

@ -24,7 +24,7 @@ IN: lists.lazy.tests
] unit-test ] unit-test
[ { 4 5 6 } ] [ [ { 4 5 6 } ] [
3 { 1 2 3 } >list [ + ] lazy-map-with list>array 3 { 1 2 3 } >list [ + ] with lazy-map list>array
] unit-test ] unit-test
[ [ ] lmap ] must-infer [ [ ] lmap ] must-infer

11
basis/lists/lazy/lazy.factor
View File

@ -90,9 +90,6 @@ M: lazy-map cdr ( lazy-map -- cdr )
M: lazy-map nil? ( lazy-map -- bool ) M: lazy-map nil? ( lazy-map -- bool )
cons>> nil? ; cons>> nil? ;
: lazy-map-with ( value list quot -- result )
with lazy-map ;
TUPLE: lazy-take n cons ; TUPLE: lazy-take n cons ;
C: <lazy-take> lazy-take C: <lazy-take> lazy-take
@ -125,7 +122,7 @@ M: lazy-until car ( lazy-until -- car )
cons>> car ; cons>> car ;
M: lazy-until cdr ( lazy-until -- cdr ) M: lazy-until cdr ( lazy-until -- cdr )
[ cons>> uncons ] keep quot>> tuck call( elt -- ? ) [ cons>> unswons ] keep quot>> tuck call( elt -- ? )
[ 2drop nil ] [ luntil ] if ; [ 2drop nil ] [ luntil ] if ;
M: lazy-until nil? ( lazy-until -- bool ) M: lazy-until nil? ( lazy-until -- bool )
@ -284,7 +281,7 @@ DEFER: lconcat
dup nil? [ dup nil? [
drop nil drop nil
] [ ] [
uncons swap (lconcat) uncons (lconcat)
] if ; ] if ;
M: lazy-concat car ( lazy-concat -- car ) M: lazy-concat car ( lazy-concat -- car )
@ -301,14 +298,14 @@ M: lazy-concat nil? ( lazy-concat -- bool )
] if ; ] if ;
: lcartesian-product ( list1 list2 -- result ) : lcartesian-product ( list1 list2 -- result )
swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ; swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ;
: lcartesian-product* ( lists -- result ) : lcartesian-product* ( lists -- result )
dup nil? [ dup nil? [
drop nil drop nil
] [ ] [
[ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [
swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat
] reduce ] reduce
] if ; ] if ;

113
basis/lists/lists-docs.factor
View File

@ -1,15 +1,68 @@
! Copyright (C) 2006 Chris Double. ! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel help.markup help.syntax ; USING: kernel help.markup help.syntax arrays sequences math quotations ;
IN: lists IN: lists
{ car cons cdr nil nil? list? uncons } related-words ABOUT: "lists"
ARTICLE: "lists" "Lists"
"The " { $vocab-link "lists" } " vocabulary implements linked lists. There are simple strict linked lists, but a generic list protocol allows the implementation of lazy lists as well."
{ $subsection { "lists" "protocol" } }
{ $subsection { "lists" "strict" } }
{ $subsection { "lists" "manipulation" } }
{ $subsection { "lists" "combinators" } }
{ $vocab-subsection "Lazy lists" "lists.lazy" } ;
ARTICLE: { "lists" "protocol" } "The list protocol"
"Lists are instances of a mixin class"
{ $subsection list }
"Instances of the mixin must implement the following words:"
{ $subsection car }
{ $subsection cdr }
{ $subsection nil? } ;
ARTICLE: { "lists" "strict" } "Strict lists"
"Strict lists are simply cons cells where the car and cdr have already been evaluated. These are the lists of Lisp. To construct a strict list, the following words are provided:"
{ $subsection cons }
{ $subsection swons }
{ $subsection sequence>cons }
{ $subsection deep-sequence>cons }
{ $subsection 1list }
{ $subsection 2list }
{ $subsection 3list } ;
ARTICLE: { "lists" "combinators" } "Combinators for lists"
"Several combinators exist for list traversal."
{ $subsection leach }
{ $subsection lmap }
{ $subsection foldl }
{ $subsection foldr }
{ $subsection lmap>array }
{ $subsection lmap-as }
{ $subsection traverse } ;
ARTICLE: { "lists" "manipulation" } "Manipulating lists"
"To get at the contents of a list:"
{ $subsection uncons }
{ $subsection unswons }
{ $subsection lnth }
{ $subsection cadr }
{ $subsection llength }
"To get a new list from an old one:"
{ $subsection lreverse }
{ $subsection lappend }
{ $subsection lcut } ;
HELP: cons HELP: cons
{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } } { $values { "car" "the head of the list cell" } { "cdr" "the tail of the list cell" } { "cons" "a cons object" } }
{ $description "Constructs a cons cell." } ; { $description "Constructs a cons cell." } ;
HELP: swons
{ $values { "cdr" "the tail of the list cell" } { "car" "the head of the list cell" } { "cons" "a cons object" } }
{ $description "Constructs a cons cell." } ;
{ cons swons uncons unswons } related-words
HELP: car HELP: car
{ $values { "cons" "a cons object" } { "car" "the first item in the list" } } { $values { "cons" "a cons object" } { "car" "the first item in the list" } }
{ $description "Returns the first item in the list." } ; { $description "Returns the first item in the list." } ;
@ -18,6 +71,8 @@ HELP: cdr
{ $values { "cons" "a cons object" } { "cdr" "a cons object" } } { $values { "cons" "a cons object" } { "cdr" "a cons object" } }
{ $description "Returns the tail of the list." } ; { $description "Returns the tail of the list." } ;
{ car cdr } related-words
HELP: nil HELP: nil
{ $values { "symbol" "The empty cons (+nil+)" } } { $values { "symbol" "The empty cons (+nil+)" } }
{ $description "Returns a symbol representing the empty list" } ; { $description "Returns a symbol representing the empty list" } ;
@ -26,6 +81,8 @@ HELP: nil?
{ $values { "object" object } { "?" "a boolean" } } { $values { "object" object } { "?" "a boolean" } }
{ $description "Return true if the cons object is the nil cons." } ; { $description "Return true if the cons object is the nil cons." } ;
{ nil nil? } related-words
HELP: list? ( object -- ? ) HELP: list? ( object -- ? )
{ $values { "object" "an object" } { "?" "a boolean" } } { $values { "object" "an object" } { "?" "a boolean" } }
{ $description "Returns true if the object conforms to the list protocol." } ; { $description "Returns true if the object conforms to the list protocol." } ;
@ -55,7 +112,11 @@ HELP: llength
{ $see-also lnth cons car cdr } ; { $see-also lnth cons car cdr } ;
HELP: uncons HELP: uncons
{ $values { "cons" "a cons object" } { "cdr" "the tail of the list" } { "car" "the head of the list" } } { $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
{ $description "Put the head and tail of the list on the stack." } ;
HELP: unswons
{ $values { "cons" "a cons object" } { "car" "the head of the list" } { "cdr" "the tail of the list" } }
{ $description "Put the head and tail of the list on the stack." } ; { $description "Put the head and tail of the list on the stack." } ;
{ leach foldl lmap>array } related-words { leach foldl lmap>array } related-words
@ -77,23 +138,23 @@ HELP: lmap
{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ; { $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
HELP: lreverse HELP: lreverse
{ $values { "list" "a cons object" } { "newlist" "a new cons object" } } { $values { "list" list } { "newlist" list } }
{ $description "Reverses the input list, outputing a new, reversed list" } ; { $description "Reverses the input list, outputing a new, reversed list. The output is a strict cons list." } ;
HELP: list>seq HELP: list>array
{ $values { "list" "a cons object" } { "array" "an array object" } } { $values { "list" "a cons object" } { "array" array } }
{ $description "Turns the given cons object into an array, maintaing order." } ; { $description "Turns the given cons object into an array, maintaing order." } ;
HELP: seq>list HELP: sequence>cons
{ $values { "seq" "a sequence" } { "list" "a cons object" } } { $values { "sequence" sequence } { "list" cons } }
{ $description "Turns the given array into a cons object, maintaing order." } ; { $description "Turns the given array into a cons object, maintaing order." } ;
HELP: cons>seq HELP: deep-list>array
{ $values { "cons" "a cons object" } { "array" "an array object" } } { $values { "list" list } { "array" array } }
{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ; { $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ;
HELP: seq>cons HELP: deep-sequence>cons
{ $values { "seq" "a sequence object" } { "cons" "a cons object" } } { $values { "sequence" sequence } { "cons" cons } }
{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ; { $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ;
HELP: traverse HELP: traverse
@ -102,3 +163,25 @@ HELP: traverse
{ $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred" { $description "Recursively traverses the list object, replacing any elements (which can themselves be sublists) that pred"
" returns true for with the result of applying quot to." } ; " returns true for with the result of applying quot to." } ;
HELP: list
{ $class-description "The class of lists. All lists are expected to conform to " { $link { "lists" "protocol" } } "." } ;
HELP: cadr
{ $values { "list" list } { "elt" object } }
{ $description "Returns the second element of the list, ie the car of the cdr." } ;
HELP: lappend
{ $values { "list1" list } { "list2" list } { "newlist" list } }
{ $description "Appends the two lists to form a new list. The first list must be finite. The result is a strict cons cell, and the first list is exausted." } ;
HELP: lcut
{ $values { "list" list } { "index" integer } { "before" cons } { "after" cons } }
{ $description "Analogous to " { $link cut } ", this word cuts a list into two pieces at the given index." } ;
HELP: lmap>array
{ $values { "list" list } { "quot" quotation } { "array" array } }
{ $description "Executes the quotation on each element of the list, collecting the results in an array." } ;
HELP: lmap-as
{ $values { "list" list } { "quot" quotation } { "exemplar" sequence } { "sequence" sequence } }
{ $description "Executes the quotation on each element of the list, collecting the results in a sequence of the type given by the exemplar." } ;

23
basis/lists/lists-tests.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2008 James Cash ! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: tools.test lists math ; USING: tools.test lists math kernel ;
IN: lists.tests IN: lists.tests
{ { 3 4 5 6 7 } } [ { { 3 4 5 6 7 } } [
{ 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq { 1 2 3 4 5 } sequence>cons [ 2 + ] lmap list>array
] unit-test ] unit-test
{ { 3 4 5 6 } } [ { { 3 4 5 6 } } [
@ -38,33 +37,35 @@ IN: lists.tests
+nil+ } } } +nil+ } } }
+nil+ } } } +nil+ } } }
} [ } [
{ 1 2 { 3 4 { 5 } } } seq>cons { 1 2 { 3 4 { 5 } } } deep-sequence>cons
] unit-test ] unit-test
{ { 1 2 { 3 4 { 5 } } } } [ { { 1 2 { 3 4 { 5 } } } } [
{ 1 2 { 3 4 { 5 } } } seq>cons cons>seq { 1 2 { 3 4 { 5 } } } deep-sequence>cons deep-list>array
] unit-test ] unit-test
{ T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [
{ 1 2 3 4 } seq>cons [ 1+ ] lmap { 1 2 3 4 } sequence>cons [ 1+ ] lmap
] unit-test ] unit-test
{ 15 } [ { 15 } [
{ 1 2 3 4 5 } seq>list 0 [ + ] foldr { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr
] unit-test ] unit-test
{ { 5 4 3 2 1 } } [ { { 5 4 3 2 1 } } [
{ 1 2 3 4 5 } seq>list lreverse list>seq { 1 2 3 4 5 } sequence>cons lreverse list>array
] unit-test ] unit-test
{ 5 } [ { 5 } [
{ 1 2 3 4 5 } seq>list llength { 1 2 3 4 5 } sequence>cons llength
] unit-test ] unit-test
{ { 3 4 { 5 6 { 7 } } } } [ { { 3 4 { 5 6 { 7 } } } } [
{ 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq { 1 2 { 3 4 { 5 } } } deep-sequence>cons [ atom? ] [ 2 + ] traverse deep-list>array
] unit-test ] unit-test
{ { 1 2 3 4 5 6 } } [ { { 1 2 3 4 5 6 } } [
{ 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array
] unit-test ] unit-test
[ { 1 } { 2 } ] [ { 1 2 } sequence>cons 1 lcut [ list>array ] bi@ ] unit-test

98
basis/lists/lists.factor
View File

@ -1,6 +1,7 @@
! Copyright (C) 2008 James Cash ! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences accessors math arrays vectors classes words locals ; USING: kernel sequences accessors math arrays vectors classes words
combinators.short-circuit combinators locals ;
IN: lists IN: lists
! List Protocol ! List Protocol
@ -9,7 +10,7 @@ GENERIC: car ( cons -- car )
GENERIC: cdr ( cons -- cdr ) GENERIC: cdr ( cons -- cdr )
GENERIC: nil? ( object -- ? ) GENERIC: nil? ( object -- ? )
TUPLE: cons car cdr ; TUPLE: cons { car read-only } { cdr read-only } ;
C: cons cons C: cons cons
@ -19,40 +20,52 @@ M: cons car ( cons -- car )
M: cons cdr ( cons -- cdr ) M: cons cdr ( cons -- cdr )
cdr>> ; cdr>> ;
SYMBOL: +nil+ SINGLETON: +nil+
M: word nil? +nil+ eq? ; M: +nil+ nil? drop t ;
M: object nil? drop f ; M: object nil? drop f ;
: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ; : atom? ( obj -- ? )
list? not ;
: nil ( -- symbol ) +nil+ ; : nil ( -- symbol ) +nil+ ;
: uncons ( cons -- cdr car ) : uncons ( cons -- car cdr )
[ cdr ] [ car ] bi ; [ car ] [ cdr ] bi ;
: swons ( cdr car -- cons )
swap cons ;
: unswons ( cons -- cdr car )
uncons swap ;
: 1list ( obj -- cons ) : 1list ( obj -- cons )
nil cons ; nil cons ;
: 1list? ( list -- ? )
{ [ nil? not ] [ cdr nil? ] } 1&& ;
: 2list ( a b -- cons ) : 2list ( a b -- cons )
nil cons cons ; nil cons cons ;
: 3list ( a b c -- cons ) : 3list ( a b c -- cons )
nil cons cons cons ; nil cons cons cons ;
: cadr ( cons -- elt ) : cadr ( list -- elt )
cdr car ; cdr car ;
: 2car ( cons -- car caar ) : 2car ( list -- car caar )
[ car ] [ cdr car ] bi ; [ car ] [ cdr car ] bi ;
: 3car ( cons -- car cadr caddr ) : 3car ( list -- car cadr caddr )
[ car ] [ cdr car ] [ cdr cdr car ] tri ; [ car ] [ cdr car ] [ cdr cdr car ] tri ;
: lnth ( n list -- elt ) : lnth ( n list -- elt )
swap [ cdr ] times car ; swap [ cdr ] times car ;
<PRIVATE
: (leach) ( list quot -- cdr quot ) : (leach) ( list quot -- cdr quot )
[ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
PRIVATE>
: leach ( list quot: ( elt -- ) -- ) : leach ( list quot: ( elt -- ) -- )
over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
@ -63,10 +76,10 @@ M: object nil? drop f ;
: foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result ) : foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result )
swapd leach ; inline swapd leach ; inline
: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) :: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result )
pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ list nil? [ identity ] [
[ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi list cdr identity quot foldr
call list car quot call
] if ; inline recursive ] if ; inline recursive
: llength ( list -- n ) : llength ( list -- n )
@ -78,34 +91,57 @@ M: object nil? drop f ;
: lappend ( list1 list2 -- newlist ) : lappend ( list1 list2 -- newlist )
[ lreverse ] dip [ swap cons ] foldl ; [ lreverse ] dip [ swap cons ] foldl ;
: seq>list ( seq -- list ) : lcut ( list index -- before after )
[ nil ] dip
[ [ [ cdr ] [ car ] bi ] dip cons ] times
lreverse swap ;
: sequence>cons ( sequence -- list )
<reversed> nil [ swap cons ] reduce ; <reversed> nil [ swap cons ] reduce ;
<PRIVATE
: same? ( obj1 obj2 -- ? ) : same? ( obj1 obj2 -- ? )
[ class ] bi@ = ; [ class ] bi@ = ;
PRIVATE>
: seq>cons ( seq -- cons ) : deep-sequence>cons ( sequence -- cons )
[ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; [ <reversed> ] keep nil
[ tuck same? [ deep-sequence>cons ] when swons ] with reduce ;
: (lmap>array) ( acc cons quot: ( elt -- elt' ) -- newcons ) <PRIVATE
over nil? [ 2drop ] :: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )
[ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; list nil? [ acc ] [
inline recursive list car quot call acc push
acc list cdr quot (lmap>vector)
] if ; inline recursive
: lmap>array ( cons quot -- newcons ) : lmap>vector ( list quot -- array )
{ } -rot (lmap>array) ; inline [ V{ } clone ] 2dip (lmap>vector) ; inline
PRIVATE>
: lmap-as ( cons quot exemplar -- seq ) : lmap-as ( list quot exemplar -- sequence )
[ lmap>array ] dip like ; [ lmap>vector ] dip like ; inline
: cons>seq ( cons -- array ) : lmap>array ( list quot -- array )
[ dup cons? [ cons>seq ] when dup nil? [ drop { } ] when ] lmap>array ; { } lmap-as ; inline
: list>seq ( list -- array ) : deep-list>array ( list -- array )
[
{
{ [ dup nil? ] [ drop { } ] }
{ [ dup list? ] [ deep-list>array ] }
[ ]
} cond
] lmap>array ;
: list>array ( list -- array )
[ ] lmap>array ; [ ] lmap>array ;
: traverse ( list pred quot: ( list/elt -- result ) -- result ) :: traverse ( list pred quot: ( list/elt -- result ) -- result )
[ 2over call [ tuck [ call ] 2dip ] when list [| elt |
pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive elt dup pred call [ quot call ] when
dup list? [ pred quot traverse ] when
] lmap ; inline recursive
INSTANCE: cons list INSTANCE: cons list
INSTANCE: +nil+ list

Some files were not shown because too many files have changed in this diff Show More