*.bak
.#*
*.swo
+checksums.txt
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 ] ;
namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects continuations fry call ;
+accessors combinators effects continuations fry call classes ;
IN: alien.c-types
DEFER: <int>
: little-endian? ( -- ? ) 1 <int> *char 1 = ; foldable
TUPLE: c-type
-class
-boxer boxer-quot unboxer unboxer-quot
-getter setter
-reg-class size align stack-align? ;
-
-: new-c-type ( class -- type )
- new
- int-regs >>reg-class
- object >>class ; inline
+{ class class initial: object }
+boxer
+{ boxer-quot callable }
+unboxer
+{ unboxer-quot callable }
+{ getter callable }
+{ setter callable }
+{ reg-class initial: int-regs }
+size
+align
+stack-align? ;
: <c-type> ( -- type )
- \ c-type new-c-type ;
+ \ c-type new ;
SYMBOL: c-types
[ "Cannot read struct fields with this type" throw ]
] unless* ;
+: c-type-getter-boxer ( name -- quot )
+ [ c-getter ] [ c-type-boxer-quot ] bi append ;
+
: c-setter ( name -- quot )
c-type-setter [
[ "Cannot write struct fields with this type" throw ]
TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- type )
- long-long-type new-c-type ;
+ long-long-type new ;
M: long-long-type unbox-parameter ( n type -- )
c-type-unboxer %unbox-long-long ;
C{ 1.0 2.0 } <complex-holder> "h" set
] unit-test
-[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
\ No newline at end of file
+[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.complex.functor sequences kernel ;
+USING: alien.c-types alien.structs alien.complex.functor accessors
+sequences kernel ;
IN: alien.complex
-<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >>
\ No newline at end of file
+<<
+{ "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
+ >>
set-T-real DEFINES set-${T}-real
set-T-imaginary DEFINES set-${T}-imaginary
->T DEFINES >${T}
-T> DEFINES ${T}>
+<T> DEFINES <${T}>
+*T DEFINES *${T}
WHERE
-: >T ( z -- alien )
+: <T> ( z -- alien )
>rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
-: T> ( alien -- z )
+: *T ( alien -- z )
[ T-real ] [ T-imaginary ] bi rect> ; inline
T in get
define-struct
T c-type
-T> 1quotation >>boxer-quot
->T 1quotation >>unboxer-quot
+<T> 1quotation >>unboxer-quot
+*T 1quotation >>boxer-quot
drop
-;FUNCTOR
\ No newline at end of file
+;FUNCTOR
--- /dev/null
+! 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"
--- /dev/null
+! (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
--- /dev/null
+! (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
+
--- /dev/null
+GNU Fortran/G77/F2C alien interface
--- /dev/null
+fortran
+ffi
: define-getter ( type spec -- )
[ set-reader-props ] keep
[ reader>> ]
- [
- type>>
- [ c-getter ] [ c-type-boxer-quot ] bi append
- ]
+ [ type>> c-type-getter-boxer ]
[ ] tri
(( c-ptr -- value )) define-struct-slot-word ;
[ ] [ \ foox-x "help" get execute ] unit-test
[ ] [ \ set-foox-x "help" get execute ] unit-test
] when
+
+C-STRUCT: nested
+ { "int" "x" } ;
+
+C-STRUCT: nested-2
+ { "nested" "y" } ;
+
+[ 4 ] [
+ "nested-2" <c-object>
+ "nested" <c-object>
+ 4 over set-nested-x
+ over set-nested-2-y
+ nested-2-y
+ nested-x
+] unit-test
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays generic hashtables kernel kernel.private
+USING: accessors arrays assocs generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc fry
-alien.c-types alien.structs.fields cpu.architecture math.order ;
+alien.c-types alien.structs.fields cpu.architecture math.order
+quotations byte-arrays ;
IN: alien.structs
-TUPLE: struct-type size align fields boxer-quot unboxer-quot getter setter ;
+TUPLE: struct-type
+size
+align
+fields
+{ boxer-quot callable }
+{ unboxer-quot callable }
+{ getter callable }
+{ setter callable }
+return-in-registers? ;
+
+M: struct-type c-type ;
M: struct-type heap-size size>> ;
-M: struct-type c-type-class drop object ;
+M: struct-type c-type-class drop byte-array ;
M: struct-type c-type-align align>> ;
[ %box-large-struct ] [ box-parameter ] if-value-struct ;
: if-small-struct ( c-type true false -- ? )
- [ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
+ [ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
M: struct-type unbox-return
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
[ expand-constants ] map
[ [ heap-size ] [ max ] map-reduce ] keep
compute-struct-align f (define-struct) ;
+
+: offset-of ( field struct -- offset )
+ c-types get at fields>>
+ [ name>> = ] with find nip offset>> ;
+
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types accessors math alien.accessors kernel
-kernel.private locals sequences sequences.private byte-arrays
+kernel.private sequences sequences.private byte-arrays
parser prettyprint.custom fry ;
IN: bit-arrays
: ?{ \ } [ >bit-array ] parse-literal ; parsing
-:: integer>bit-array ( n -- bit-array )
- n zero? [ 0 <bit-array> ] [
- [let | out [ n log2 1+ <bit-array> ] i! [ 0 ] n'! [ n ] |
- [ n' zero? ] [
- n' out underlying>> i set-alien-unsigned-1
- n' -8 shift n'!
- i 1+ i!
- ] [ ] until
- out
- ]
+: integer>bit-array ( n -- bit-array )
+ dup 0 = [
+ <bit-array>
+ ] [
+ [ log2 1+ <bit-array> 0 ] keep
+ [ dup 0 = ] [
+ [ pick underlying>> pick set-alien-unsigned-1 ] keep
+ [ 1+ ] [ -8 shift ] bi*
+ ] [ ] until 2drop
] if ;
: bit-array>integer ( bit-array -- n )
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! 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
--- /dev/null
+! 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 ;
-USING: help.markup help.syntax io io.files io.pathnames ;
+USING: help.markup help.syntax io io.files io.pathnames strings ;
IN: bootstrap.image
ARTICLE: "bootstrap.image" "Bootstrapping new images"
ABOUT: "bootstrap.image"
HELP: make-image
-{ $values { "arch" "a string" } }
+{ $values { "arch" string } }
{ $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:"
-{ $code "x86.32" "x86.64" "ppc" "arm" }
+{ $code "x86.32" "unix-x86.64" "winnt-x86.64" "macosx-ppc" "linux-ppc" }
"The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;
SYMBOL: frameworks
-frameworks global [ V{ } clone or ] change-at
+frameworks [ V{ } clone ] initialize
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
SYMBOL: message-senders
SYMBOL: super-message-senders
-message-senders global [ H{ } assoc-like ] change-at
-super-message-senders global [ H{ } assoc-like ] change-at
+message-senders [ H{ } clone ] initialize
+super-message-senders [ H{ } clone ] initialize
: cache-stub ( method function hash -- )
[
SYMBOL: objc-methods
-objc-methods global [ H{ } assoc-like ] change-at
+objc-methods [ H{ } clone ] initialize
: lookup-method ( selector -- method )
dup objc-methods get at
! Runtime introspection
SYMBOL: class-init-hooks
-class-init-hooks global [ H{ } clone or ] change-at
+class-init-hooks [ H{ } clone ] initialize
: (objc-class) ( name word -- class )
2dup execute dup [ 2nip ] [
\ nested-smart-combo-test must-infer
-[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
\ No newline at end of file
+[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
+
+[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test
\ No newline at end of file
: sum-outputs ( quot -- n )
[ + ] reduce-outputs ; inline
+MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
+ [ dup infer out>> ] 2dip
+ [ swap '[ _ _ napply ] ]
+ [ [ 1 [-] ] dip n*quot ] bi-curry* bi
+ '[ @ @ @ ] ;
+
MACRO: append-outputs-as ( quot exemplar -- newquot )
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
IN: compiler.alien
: large-struct? ( ctype -- ? )
- dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
+ dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>
SYMBOL: yield-hook
-yield-hook global [ [ ] or ] change-at
+yield-hook [ [ ] ] initialize
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors tools.test compression.lzw ;
+IN: compression.lzw.tests
--- /dev/null
+! 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.syntax combinators system ;
+IN: compression.zlib.ffi
+
+<< "zlib" {
+ { [ os winnt? ] [ "zlib1.dll" ] }
+ { [ os macosx? ] [ "libz.dylib" ] }
+ { [ os unix? ] [ "libz.so" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: zlib
+
+CONSTANT: Z_OK 0
+CONSTANT: Z_STREAM_END 1
+CONSTANT: Z_NEED_DICT 2
+CONSTANT: Z_ERRNO -1
+CONSTANT: Z_STREAM_ERROR -2
+CONSTANT: Z_DATA_ERROR -3
+CONSTANT: Z_MEM_ERROR -4
+CONSTANT: Z_BUF_ERROR -5
+CONSTANT: Z_VERSION_ERROR -6
+
+TYPEDEF: void Bytef
+TYPEDEF: ulong uLongf
+TYPEDEF: ulong uLong
+
+FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
+FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ;
+FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel tools.test compression.zlib classes ;
+IN: compression.zlib.tests
+
+: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
+
+[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test
+[ t ] [ compress-me compress compressed instance? ] unit-test
--- /dev/null
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.syntax byte-arrays combinators
+kernel math math.functions sequences system accessors
+libc ;
+QUALIFIED: compression.zlib.ffi
+IN: compression.zlib
+
+TUPLE: compressed data length ;
+
+: <compressed> ( data length -- compressed )
+ compressed new
+ swap >>length
+ swap >>data ;
+
+ERROR: zlib-failed n string ;
+
+: zlib-error-message ( n -- * )
+ dup compression.zlib.ffi:Z_ERRNO = [
+ drop errno "native libc error"
+ ] [
+ dup {
+ "no error" "libc_error"
+ "stream error" "data error"
+ "memory error" "buffer error" "zlib version error"
+ } ?nth
+ ] if zlib-failed ;
+
+: zlib-error ( n -- )
+ dup compression.zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
+
+: compressed-size ( byte-array -- n )
+ length 1001/1000 * ceiling 12 + ;
+
+: compress ( byte-array -- compressed )
+ [
+ [ compressed-size <byte-array> dup length <ulong> ] keep [
+ dup length compression.zlib.ffi:compress zlib-error
+ ] 3keep drop *ulong head
+ ] keep length <compressed> ;
+
+: uncompress ( compressed -- byte-array )
+ [
+ length>> [ <byte-array> ] keep <ulong> 2dup
+ ] [
+ data>> dup length
+ compression.zlib.ffi:uncompress zlib-error
+ ] bi *ulong head ;
: get-process ( name -- process )\r
dup registered-processes at [ ] [ thread ] ?if ;\r
\r
-\ registered-processes global [ H{ } assoc-like ] change-at\r
+\ registered-processes [ H{ } clone ] initialize\r
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test constructors calendar kernel accessors
+combinators.short-circuit ;
+IN: constructors.tests
+
+TUPLE: stock-spread stock spread timestamp ;
+
+CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
+ now >>timestamp ;
+
+SYMBOL: AAPL
+
+[ t ] [
+ AAPL 1234 <stock-spread>
+ {
+ [ stock>> AAPL eq? ]
+ [ spread>> 1234 = ]
+ [ timestamp>> timestamp? ]
+ } 1&&
+] unit-test
\ No newline at end of file
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: slots kernel sequences fry accessors parser lexer words
+effects.parser macros ;
+IN: constructors
+
+! An experiment
+
+MACRO: set-slots ( slots -- quot )
+ <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
+
+: construct ( ... class slots -- instance )
+ [ new ] dip set-slots ; inline
+
+: define-constructor ( name class effect body -- )
+ [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
+ define-declared ;
+
+: CONSTRUCTOR:
+ scan-word [ name>> "<" ">" surround create-in ] keep
+ "(" expect ")" parse-effect
+ parse-definition
+ define-constructor ; parsing
\ No newline at end of file
HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? cpu ( c-type -- ? )
+HOOK: return-struct-in-registers? cpu ( c-type -- ? )
! Do we pass this struct by value or hidden reference?
HOOK: value-struct? cpu ( c-type -- ? )
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
-M: ppc struct-small-enough? ( size -- ? ) drop f ;
+M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
M: ppc %box-small-struct
drop "No small structs" throw ;
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
-M: x86.32 struct-small-enough? ( size -- ? )
- heap-size { 1 2 4 8 } member?
- os { linux netbsd solaris } member? not and ;
+M: x86.32 return-struct-in-registers? ( c-type -- ? )
+ c-type
+ [ return-in-registers?>> ]
+ [ heap-size { 1 2 4 8 } member? ] bi
+ os { linux netbsd solaris } member? not
+ and or ;
: struct-return@ ( n -- operand )
[ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;
flatten-small-struct
] if ;
-M: x86.64 struct-small-enough? ( size -- ? )
+M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ;
M: x86.64 dummy-stack-params? f ;
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? ;
-USING: io.streams.string csv tools.test shuffle kernel strings
+USING: io.streams.string csv tools.test kernel strings
io.pathnames io.files.unique io.encodings.utf8 io.files
io.directories ;
IN: csv.tests
! I like to name my unit tests
: named-unit-test ( name output input -- )
- nipd unit-test ; inline
-
-! tests nicked from the wikipedia csv article
-! http://en.wikipedia.org/wiki/Comma-separated_values
+ unit-test drop ; inline
"Fields are separated by commas"
[ { { "1997" "Ford" "E350" } } ]
{ { "writing,some,csv,tests" } } dup "csv-test2-"
unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
] unit-test
+
+[ { { "hello" "" "" "" "goodbye" "" } } ] [ "hello,,\"\",,goodbye," <string-reader> csv ] unit-test
: (row) ( -- sep )
field ,
- dup delimiter get = [ drop (row) ] when ;
+ dup delimiter> = [ drop (row) ] when ;
: row ( -- eof? array[string] )
[ (row) ] { } make ;
: (csv) ( -- )
- row harvest [ , ] unless-empty [ (csv) ] when ;
+ row
+ dup [ empty? ] all? [ drop ] [ , ] if
+ [ (csv) ] when ;
PRIVATE>
[ row nip ] with-input-stream ;
: csv ( stream -- rows )
- [ [ (csv) ] { } make ] with-input-stream ;
+ [ [ (csv) ] { } make ] with-input-stream
+ dup peek { "" } = [ but-last ] when ;
: file>csv ( path encoding -- csv )
<file-reader> csv ;
} cond "cdecl" add-library >>
! ConnSatusType
-: CONNECTION_OK HEX: 0 ; inline
-: CONNECTION_BAD HEX: 1 ; inline
-: CONNECTION_STARTED HEX: 2 ; inline
-: CONNECTION_MADE HEX: 3 ; inline
-: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
-: CONNECTION_AUTH_OK HEX: 5 ; inline
-: CONNECTION_SETENV HEX: 6 ; inline
-: CONNECTION_SSL_STARTUP HEX: 7 ; inline
-: CONNECTION_NEEDED HEX: 8 ; inline
+CONSTANT: CONNECTION_OK HEX: 0
+CONSTANT: CONNECTION_BAD HEX: 1
+CONSTANT: CONNECTION_STARTED HEX: 2
+CONSTANT: CONNECTION_MADE HEX: 3
+CONSTANT: CONNECTION_AWAITING_RESPONSE HEX: 4
+CONSTANT: CONNECTION_AUTH_OK HEX: 5
+CONSTANT: CONNECTION_SETENV HEX: 6
+CONSTANT: CONNECTION_SSL_STARTUP HEX: 7
+CONSTANT: CONNECTION_NEEDED HEX: 8
! PostgresPollingStatusType
-: PGRES_POLLING_FAILED HEX: 0 ; inline
-: PGRES_POLLING_READING HEX: 1 ; inline
-: PGRES_POLLING_WRITING HEX: 2 ; inline
-: PGRES_POLLING_OK HEX: 3 ; inline
-: PGRES_POLLING_ACTIVE HEX: 4 ; inline
+CONSTANT: PGRES_POLLING_FAILED HEX: 0
+CONSTANT: PGRES_POLLING_READING HEX: 1
+CONSTANT: PGRES_POLLING_WRITING HEX: 2
+CONSTANT: PGRES_POLLING_OK HEX: 3
+CONSTANT: PGRES_POLLING_ACTIVE HEX: 4
! ExecStatusType;
-: PGRES_EMPTY_QUERY HEX: 0 ; inline
-: PGRES_COMMAND_OK HEX: 1 ; inline
-: PGRES_TUPLES_OK HEX: 2 ; inline
-: PGRES_COPY_OUT HEX: 3 ; inline
-: PGRES_COPY_IN HEX: 4 ; inline
-: PGRES_BAD_RESPONSE HEX: 5 ; inline
-: PGRES_NONFATAL_ERROR HEX: 6 ; inline
-: PGRES_FATAL_ERROR HEX: 7 ; inline
+CONSTANT: PGRES_EMPTY_QUERY HEX: 0
+CONSTANT: PGRES_COMMAND_OK HEX: 1
+CONSTANT: PGRES_TUPLES_OK HEX: 2
+CONSTANT: PGRES_COPY_OUT HEX: 3
+CONSTANT: PGRES_COPY_IN HEX: 4
+CONSTANT: PGRES_BAD_RESPONSE HEX: 5
+CONSTANT: PGRES_NONFATAL_ERROR HEX: 6
+CONSTANT: PGRES_FATAL_ERROR HEX: 7
! PGTransactionStatusType;
-: PQTRANS_IDLE HEX: 0 ; inline
-: PQTRANS_ACTIVE HEX: 1 ; inline
-: PQTRANS_INTRANS HEX: 2 ; inline
-: PQTRANS_INERROR HEX: 3 ; inline
-: PQTRANS_UNKNOWN HEX: 4 ; inline
+CONSTANT: PQTRANS_IDLE HEX: 0
+CONSTANT: PQTRANS_ACTIVE HEX: 1
+CONSTANT: PQTRANS_INTRANS HEX: 2
+CONSTANT: PQTRANS_INERROR HEX: 3
+CONSTANT: PQTRANS_UNKNOWN HEX: 4
! PGVerbosity;
-: PQERRORS_TERSE HEX: 0 ; inline
-: PQERRORS_DEFAULT HEX: 1 ; inline
-: PQERRORS_VERBOSE HEX: 2 ; inline
+CONSTANT: PQERRORS_TERSE HEX: 0
+CONSTANT: PQERRORS_DEFAULT HEX: 1
+CONSTANT: PQERRORS_VERBOSE HEX: 2
-: InvalidOid 0 ; inline
+CONSTANT: InvalidOid 0
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType
FUNCTION: int PQenv2encoding ( ) ;
! From git, include/catalog/pg_type.h
-: BOOL-OID 16 ; inline
-: BYTEA-OID 17 ; inline
-: CHAR-OID 18 ; inline
-: NAME-OID 19 ; inline
-: INT8-OID 20 ; inline
-: INT2-OID 21 ; inline
-: INT4-OID 23 ; inline
-: TEXT-OID 23 ; inline
-: OID-OID 26 ; inline
-: FLOAT4-OID 700 ; inline
-: FLOAT8-OID 701 ; inline
-: VARCHAR-OID 1043 ; inline
-: DATE-OID 1082 ; inline
-: TIME-OID 1083 ; inline
-: TIMESTAMP-OID 1114 ; inline
-: TIMESTAMPTZ-OID 1184 ; inline
-: INTERVAL-OID 1186 ; inline
-: NUMERIC-OID 1700 ; inline
+CONSTANT: BOOL-OID 16
+CONSTANT: BYTEA-OID 17
+CONSTANT: CHAR-OID 18
+CONSTANT: NAME-OID 19
+CONSTANT: INT8-OID 20
+CONSTANT: INT2-OID 21
+CONSTANT: INT4-OID 23
+CONSTANT: TEXT-OID 23
+CONSTANT: OID-OID 26
+CONSTANT: FLOAT4-OID 700
+CONSTANT: FLOAT8-OID 701
+CONSTANT: VARCHAR-OID 1043
+CONSTANT: DATE-OID 1082
+CONSTANT: TIME-OID 1083
+CONSTANT: TIMESTAMP-OID 1114
+CONSTANT: TIMESTAMPTZ-OID 1184
+CONSTANT: INTERVAL-OID 1186
+CONSTANT: NUMERIC-OID 1700
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types tools.walker ascii splitting math.parser combinators
-libc shuffle calendar.format byte-arrays destructors prettyprint
+libc calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary io.encodings.utf8
alien.strings io.streams.byte-array summary present urls
specialized-arrays.uint specialized-arrays.alien db.private ;
: pq-get-string ( handle row column -- obj )
3dup PQgetvalue utf8 alien>string
- dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ;
+ dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ;
: pq-get-number ( handle row column -- obj )
pq-get-string dup [ string>number ] when ;
: pq-get-blob ( handle row column -- obj/f )
[ PQgetvalue ] 3keep 3dup PQgetlength
dup 0 > [
- 3nip
+ [ 3drop ] dip
[
memory>byte-array >string
0 <uint>
] bi attempt-all drop ;
: sql-props ( class -- columns table )
- [ db-columns ] [ db-table ] bi ;
+ [ db-columns ] [ db-table-name ] bi ;
: query-make ( class quot -- statements )
#! query, input, outputs, secondary queries
- over unparse "table" set
+ over db-table-name "table-name" set
[ sql-props ] dip
[ 0 sql-counter rot with-variable ] curry
{ "" { } { } { } } nmake
} cond "cdecl" add-library >>
! Return values from sqlite functions
-: SQLITE_OK 0 ; inline ! Successful result
-: SQLITE_ERROR 1 ; inline ! SQL error or missing database
-: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
-: SQLITE_PERM 3 ; inline ! Access permission denied
-: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
-: SQLITE_BUSY 5 ; inline ! The database file is locked
-: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
-: SQLITE_NOMEM 7 ; inline ! A malloc() failed
-: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
-: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
-: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
-: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
-: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
-: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
-: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
-: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
-: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
-: SQLITE_SCHEMA 17 ; inline ! The database schema changed
-: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
-: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
-: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
-: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
-: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
-: SQLITE_AUTH 23 ; inline ! Authorization denied
-: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
-: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
-: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
+CONSTANT: SQLITE_OK 0 ! Successful result
+CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database
+CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite
+CONSTANT: SQLITE_PERM 3 ! Access permission denied
+CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort
+CONSTANT: SQLITE_BUSY 5 ! The database file is locked
+CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked
+CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed
+CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database
+CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt()
+CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred
+CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed
+CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found
+CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full
+CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file
+CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error
+CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty
+CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed
+CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table
+CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation
+CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch
+CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly
+CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host
+CONSTANT: SQLITE_AUTH 23 ! Authorization denied
+CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error
+CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range
+CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file
: sqlite-error-messages ( -- seq ) {
"Successful result"
} ;
! Return values from sqlite3_step
-: SQLITE_ROW 100 ; inline
-: SQLITE_DONE 101 ; inline
+CONSTANT: SQLITE_ROW 100
+CONSTANT: SQLITE_DONE 101
! Return values from the sqlite3_column_type function
-: SQLITE_INTEGER 1 ; inline
-: SQLITE_FLOAT 2 ; inline
-: SQLITE_TEXT 3 ; inline
-: SQLITE_BLOB 4 ; inline
-: SQLITE_NULL 5 ; inline
+CONSTANT: SQLITE_INTEGER 1
+CONSTANT: SQLITE_FLOAT 2
+CONSTANT: SQLITE_TEXT 3
+CONSTANT: SQLITE_BLOB 4
+CONSTANT: SQLITE_NULL 5
! Values for the 'destructor' parameter of the 'bind' routines.
-: SQLITE_STATIC 0 ; inline
-: SQLITE_TRANSIENT -1 ; inline
+CONSTANT: SQLITE_STATIC 0
+CONSTANT: SQLITE_TRANSIENT -1
-: SQLITE_OPEN_READONLY HEX: 00000001 ; inline
-: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline
-: SQLITE_OPEN_CREATE HEX: 00000004 ; inline
-: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline
-: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline
-: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline
-: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline
-: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline
-: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline
-: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline
-: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline
-: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline
+CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001
+CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002
+CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004
+CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008
+CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010
+CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100
+CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200
+CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400
+CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800
+CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
+CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
+CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
TYPEDEF: void sqlite3
TYPEDEF: void sqlite3_stmt
"select * from person" sql-query length
] with-db
] unit-test
+
+! You don't need a primary key
+USING: accessors arrays sorting ;
+TUPLE: things one two ;
+
+things "THINGS" {
+ { "one" "ONE" INTEGER +not-null+ }
+ { "two" "TWO" INTEGER +not-null+ }
+} define-persistent
+
+[ { { 0 0 } { 0 1 } { 1 0 } { 1 1 } } ] [
+ test.db [
+ things create-table
+ 0 0 things boa insert-tuple
+ 0 1 things boa insert-tuple
+ 1 1 things boa insert-tuple
+ 1 0 things boa insert-tuple
+ f f things boa select-tuples
+ [ [ one>> ] [ two>> ] bi 2array ] map natural-sort
+ things drop-table
+ ] with-db
+] unit-test
+
+! Tables can have different names than the name of the tuple
+TUPLE: foo slot ;
+C: <foo> foo
+foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent
+
+TUPLE: hi bye try ;
+C: <hi> hi
+hi "HELLO" {
+ { "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } }
+ { "try" "RETHROW" INTEGER { +foreign-id+ foo "SOMETHING" } }
+} define-persistent
+
+[ T{ foo { slot 1 } } T{ hi { bye 1 } { try 1 } } ] [
+ test.db [
+ foo create-table
+ hi create-table
+ 1 <foo> insert-tuple
+ f <foo> select-tuple
+ 1 1 <hi> insert-tuple
+ f <hi> select-tuple
+ hi drop-table
+ foo drop-table
+ ] with-db
+] unit-test
+
+[ ] [
+ test.db [
+ hi create-table
+ hi drop-table
+ ] with-db
+] unit-test
+
+TUPLE: show id ;
+TUPLE: user username data ;
+TUPLE: watch show user ;
+
+user "USER" {
+ { "username" "USERNAME" TEXT +not-null+ +user-assigned-id+ }
+ { "data" "DATA" TEXT }
+} define-persistent
+
+show "SHOW" {
+ { "id" "ID" +db-assigned-id+ }
+} define-persistent
+
+watch "WATCH" {
+ { "user" "USER" TEXT +not-null+
+ { +foreign-id+ user "USERNAME" } +user-assigned-id+ }
+ { "show" "SHOW" BIG-INTEGER +not-null+
+ { +foreign-id+ show "ID" } +user-assigned-id+ }
+} define-persistent
+
+[ T{ user { username "littledan" } { data "foo" } } ] [
+ test.db [
+ user create-table
+ show create-table
+ watch create-table
+ "littledan" "foo" user boa insert-tuple
+ "mark" "bar" user boa insert-tuple
+ show new insert-tuple
+ show new select-tuple
+ "littledan" f user boa select-tuple
+ watch boa insert-tuple
+ watch new select-tuple
+ user>> f user boa select-tuple
+ ] with-db
+] unit-test
+
+[ \ swap ensure-table ] must-fail
modifiers 0%
] interleave
- ", " 0%
- find-primary-key
- "primary key(" 0%
- [ "," 0% ] [ column-name>> 0% ] interleave
- "));" 0%
+ find-primary-key [
+ ", " 0%
+ "primary key(" 0%
+ [ "," 0% ] [ column-name>> 0% ] interleave
+ ")" 0%
+ ] unless-empty
+ ");" 0%
] query-make ;
M: sqlite-db-connection drop-sql-statement ( class -- statement )
: insert-trigger ( -- string )
[
<"
- CREATE TRIGGER fki_${table}_${foreign-table}_id
- BEFORE INSERT ON ${table}
+ CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+ BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
- WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
+ WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
: insert-trigger-not-null ( -- string )
[
<"
- CREATE TRIGGER fki_${table}_${foreign-table}_id
- BEFORE INSERT ON ${table}
+ CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
+ BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+ SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE NEW.${foreign-table-id} IS NOT NULL
- AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
: update-trigger ( -- string )
[
<"
- CREATE TRIGGER fku_${table}_${foreign-table}_id
- BEFORE UPDATE ON ${table}
+ CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+ BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
- WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
+ WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
: update-trigger-not-null ( -- string )
[
<"
- CREATE TRIGGER fku_${table}_${foreign-table}_id
- BEFORE UPDATE ON ${table}
+ CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
+ BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
+ SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE NEW.${foreign-table-id} IS NOT NULL
- AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
+ AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
: delete-trigger-restrict ( -- string )
[
<"
- CREATE TRIGGER fkd_${table}_${foreign-table}_id
- BEFORE DELETE ON ${foreign-table}
+ CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+ BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
- SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
- WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
+ SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
+ WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
END;
"> interpolate
] with-string-writer ;
: delete-trigger-cascade ( -- string )
[
<"
- CREATE TRIGGER fkd_${table}_${foreign-table}_id
- BEFORE DELETE ON ${foreign-table}
+ CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
+ BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
- DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
+ DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
END;
"> interpolate
] with-string-writer ;
{ "default" [ first number>string " " glue ] }
{ "references" [
[ >reference-string ] keep
- first2 [ "foreign-table" set ]
+ first2 [ db-table-name "foreign-table-name" set ]
[ "foreign-table-id" set ] bi*
create-sqlite-triggers
] }
ERROR: not-persistent class ;
-: db-table ( class -- object )
+: db-table-name ( class -- object )
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- object )
: >reference-string ( string pair -- string )
first2
- [ [ unparse " " glue ] [ db-columns ] bi ] dip
+ [ [ db-table-name " " glue ] [ db-columns ] bi ] dip
swap [ column-name>> = ] with find nip
[ no-column ] unless*
column-name>> "(" ")" surround append ;
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser lexer kernel namespaces sequences definitions
io.files io.backend io.pathnames io summary continuations
tools.crossref tools.vocabs prettyprint source-files assocs
-vocabs vocabs.loader splitting accessors ;
+vocabs vocabs.loader splitting accessors debugger prettyprint
+help.topics ;
IN: editors
TUPLE: no-edit-hook ;
[ (normalize-path) ] dip edit-hook get-global
[ call ] [ no-edit-hook edit-location ] if* ;
+ERROR: cannot-find-source definition ;
+
+M: cannot-find-source error.
+ "Cannot find source for ``" write
+ definition>> pprint-short
+ "''" print ;
+
: edit ( defspec -- )
- where [ first2 edit-location ] when* ;
+ dup where
+ [ first2 edit-location ]
+ [ dup word-link? [ name>> edit ] [ cannot-find-source ] if ]
+ ?if ;
: edit-vocab ( name -- )
- vocab-source-path 1 edit-location ;
+ >vocab-link edit ;
GENERIC: error-file ( error -- file )
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types namespaces io.binary fry
-kernel math ;
+kernel math grouping sequences math.bitwise ;
IN: endian
SINGLETONS: big-endian little-endian ;
-: native-endianness ( -- class )
+: compute-native-endianness ( -- class )
1 <int> *char 0 = big-endian little-endian ? ;
-: >signed ( x n -- y )
- 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
-
-native-endianness \ native-endianness set-global
+SYMBOL: native-endianness
+native-endianness [ compute-native-endianness ] initialize
SYMBOL: endianness
+endianness [ native-endianness get-global ] initialize
-\ native-endianness get-global endianness set-global
-
-HOOK: >native-endian native-endianness ( obj n -- str )
+HOOK: >native-endian native-endianness ( obj n -- bytes )
M: big-endian >native-endian >be ;
M: little-endian >native-endian >le ;
-HOOK: unsigned-native-endian> native-endianness ( obj -- str )
+HOOK: unsigned-native-endian> native-endianness ( obj -- bytes )
M: big-endian unsigned-native-endian> be> ;
M: little-endian unsigned-native-endian> le> ;
-: signed-native-endian> ( obj n -- str )
+: signed-native-endian> ( obj n -- n' )
[ unsigned-native-endian> ] dip >signed ;
-HOOK: >endian endianness ( obj n -- str )
+HOOK: >endian endianness ( obj n -- bytes )
M: big-endian >endian >be ;
M: little-endian endian> le> ;
-HOOK: unsigned-endian> endianness ( obj -- str )
+HOOK: unsigned-endian> endianness ( obj -- bytes )
M: big-endian unsigned-endian> be> ;
M: little-endian unsigned-endian> le> ;
-: signed-endian> ( obj n -- str )
+: signed-endian> ( obj n -- bytes )
[ unsigned-endian> ] dip >signed ;
: with-endianness ( endian quot -- )
: with-native-endian ( quot -- )
\ native-endianness get-global swap with-endianness ; inline
+
+: seq>native-endianness ( seq n -- seq' )
+ native-endianness get-global dup endianness get = [
+ 2drop
+ ] [
+ [ [ <sliced-groups> ] keep ] dip
+ little-endian = [
+ '[ be> _ >le ] map
+ ] [
+ '[ le> _ >be ] map
+ ] if concat
+ ] if ; inline
CHLOE: base
compile-a-url [ [XML <base href=<->/> XML] ] [xml-code] ;
+: hidden-nested-fields ( -- xml )
+ nested-forms get " " join f like nested-forms-key
+ hidden-form-field ;
+
+: render-hidden ( for -- xml )
+ [ "," split [ hidden render>xml ] map ] [ f ] if* ;
+
: compile-hidden-form-fields ( for -- )
'[
- _ [ "," split [ hidden render>xml ] map ] [ f ] if*
- nested-forms get " " join f like nested-forms-key hidden-form-field>xml
- [ [ modify-form ] each-responder ] with-string-writer <unescaped>
+ _ render-hidden
+ hidden-nested-fields
+ form-modifications
[XML <div style="display: none;"><-><-><-></div> XML]
] [code] ;
IN: furnace.tests
USING: http http.server.dispatchers http.server.responses
http.server furnace furnace.utilities tools.test kernel
-namespaces accessors io.streams.string urls ;
+namespaces accessors io.streams.string urls xml.writer ;
TUPLE: funny-dispatcher < dispatcher ;
: <funny-dispatcher> funny-dispatcher new-dispatcher ;
] unit-test
[ "<input type=\"hidden\" value=\"&&&\" name=\"foo\"/>" ]
-[ [ "&&&" "foo" hidden-form-field ] with-string-writer ]
+[ "&&&" "foo" hidden-form-field xml>string ]
unit-test
[ f ] [ <request> request [ referrer ] with-variable ] unit-test
{ $description "Applies the quotation to each responder involved in processing the current request." } ;
HELP: hidden-form-field
-{ $values { "value" string } { "name" string } }
-{ $description "Renders an HTML hidden form field tag." }
+{ $values { "value" string } { "name" string } { "xml" "an XML chunk" } }
+{ $description "Renders an HTML hidden form field tag as XML." }
{ $notes "This word is used by session management, conversation scope and asides." }
{ $examples
{ $example
- "USING: furnace.utilities io ;"
- "\"bar\" \"foo\" hidden-form-field nl"
+ "USING: furnace.utilities io xml.writer ;"
+ "\"bar\" \"foo\" hidden-form-field write-xml nl"
"<input type=\"hidden\" value=\"bar\" name=\"foo\"/>"
}
} ;
{ $examples "Conversation scope adds attributes to link tags." } ;
HELP: modify-form
-{ $values { "responder" "a responder" } }
+{ $values { "responder" "a responder" } { "xml/f" "an XML chunk or f" } }
{ $contract "Emits hidden form fields using " { $link hidden-form-field } "." }
{ $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." }
{ $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ;
M: object link-attr 2drop ;
-GENERIC: modify-form ( responder -- )
+GENERIC: modify-form ( responder -- xml/f )
-M: object modify-form drop ;
+M: object modify-form drop f ;
-: hidden-form-field>xml ( value name -- xml )
+: form-modifications ( -- xml )
+ [ [ modify-form [ , ] when* ] each-responder ] { } make ;
+
+: hidden-form-field ( value name -- xml )
over [
[XML <input type="hidden" value=<-> name=<->/> XML]
] [ drop ] if ;
-: hidden-form-field ( value name -- )
- hidden-form-field>xml write-xml ;
-
: nested-forms-key "__n" ;
: request-params ( request -- assoc )
"placed on the top of the stack."\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }\r
+ { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" }\r
"Some core words expressed in terms of " { $link npick } ":"\r
{ $table\r
{ { $link dup } { $snippet "1 npick" } }\r
"placed on the top of the stack."\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }\r
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" }\r
"Some core words expressed in terms of " { $link ndup } ":"\r
{ $table\r
{ { $link dup } { $snippet "1 ndup" } }\r
"for any number of items."\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" }\r
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" }\r
"Some core words expressed in terms of " { $link nnip } ":"\r
{ $table\r
{ { $link nip } { $snippet "1 nnip" } }\r
"for any number of items."\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" }\r
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" }\r
"Some core words expressed in terms of " { $link ndrop } ":"\r
{ $table\r
{ { $link drop } { $snippet "1 ndrop" } }\r
"number of items on the stack. "\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }\r
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" }\r
"Some core words expressed in terms of " { $link nrot } ":"\r
{ $table\r
{ { $link swap } { $snippet "1 nrot" } }\r
"number of items on the stack. "\r
}\r
{ $examples\r
- { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }\r
+ { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" }\r
"Some core words expressed in terms of " { $link -nrot } ":"\r
{ $table\r
{ { $link swap } { $snippet "1 -nrot" } }\r
"stack. The quotation can consume and produce any number of items."\r
} \r
{ $examples\r
- { $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }\r
- { $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }\r
+ { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" }\r
+ { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" }\r
"Some core words expressed in terms of " { $link ndip } ":"\r
{ $table\r
{ { $link dip } { $snippet "1 ndip" } }\r
"removed from the stack, the quotation called, and the items restored."\r
} \r
{ $examples\r
- { $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }\r
+ { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" }\r
"Some core words expressed in terms of " { $link nslip } ":"\r
{ $table\r
{ { $link slip } { $snippet "1 nslip" } }\r
"saved, the quotation called, and the items restored."\r
} \r
{ $examples\r
- { $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" }\r
+ { $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" }\r
"Some core words expressed in terms of " { $link nkeep } ":"\r
{ $table\r
{ { $link keep } { $snippet "1 nkeep" } }\r
SYMBOL: help-hook
-help-hook global [ [ print-topic ] or ] change-at
+help-hook [ [ print-topic ] ] initialize
: help ( topic -- )
help-hook get call ;
! Help articles
SYMBOL: articles
-articles global [ H{ } assoc-like ] change-at
+articles [ H{ } clone ] initialize
SYMBOL: article-xref
-article-xref global [ H{ } assoc-like ] change-at
+article-xref [ H{ } clone ] initialize
GENERIC: article-name ( topic -- string )
GENERIC: article-title ( topic -- string )
{ $description "Hidden components render as a hidden form field. For example, a page for editing a weblog post might contain a hidden field with the post ID." } ;
HELP: html
-{ $description "HTML components render HTML verbatim, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
+{ $description "HTML components render HTML verbatim from a string, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
+
+HELP: xml
+{ $description "XML components render XML verbatim, from an XML chunk. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
HELP: inspector
{ $description "Inspector components render an arbitrary object by passing it to the " { $link describe } " word." } ;
{ $subsection inspector }
{ $subsection comparison }
{ $subsection html }
+{ $subsection xml }
"Tuple components:"
{ $subsection field }
{ $subsection password }
SINGLETON: html
M: html render* 2drop <unescaped> ;
+
+! XML component
+SINGLETON: xml
+
+M: xml render* 2drop ;
--- /dev/null
+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." } ;
</head>
<body><-></body>
</html>
- XML> ; inline
+ XML> ;
: render-error ( message -- xml )
[XML <span class="error"><-></span> XML] ;
IN: html.templates.chloe
-USING: help.markup help.syntax html.components html.forms
+USING: xml.data help.markup help.syntax html.components html.forms
html.templates html.templates.chloe.syntax
html.templates.chloe.compiler html.templates.chloe.components
-math xml.data strings quotations namespaces ;
+math strings quotations namespaces ;
HELP: <chloe>
{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } }
{ { $snippet "t:field" } { $link field } }
{ { $snippet "t:hidden" } { $link hidden } }
{ { $snippet "t:html" } { $link html } }
+ { { $snippet "t:xml" } { $link xml } }
{ { $snippet "t:inspector" } { $link inspector } }
{ { $snippet "t:label" } { $link label } }
{ { $snippet "t:link" } { $link link } }
COMPONENT: choice
COMPONENT: checkbox
COMPONENT: code
+COMPONENT: xml
SYMBOL: template-cache
SYMBOL: tags
-tags global [ H{ } clone or ] change-at
+tags [ H{ } clone ] initialize
: define-chloe-tag ( name quot -- ) swap tags get set-at ;
HELP: with-http-request
{ $values { "request" request } { "quot" { $quotation "( chunk -- )" } } { "response" response } }
-{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read." }
-{ $errors "Throws an error if the HTTP request fails." } ;
+{ $description "Sends an HTTP request to an HTTP server, and reads the response incrementally. Chunks of data are passed to the quotation as they are read. Does not throw an error if the HTTP request fails; to do so, call " { $link check-response } " on the " { $snippet "response" } "." } ;
ARTICLE: "http.client.get" "GET requests with the HTTP client"
"Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"
: check-response ( response -- response )
dup code>> success? [ download-failed ] unless ;
+: check-response-with-body ( response body -- response body )
+ [ >>body check-response ] keep ;
+
: with-http-request ( request quot -- response )
- [ (with-http-request) check-response ] with-destructors ; inline
+ [ (with-http-request) ] with-destructors ; inline
: http-request ( request -- response data )
[ [ % ] with-http-request ] B{ } make
- over content-charset>> decode ;
+ over content-charset>> decode check-response-with-body ;
: <get-request> ( url -- request )
"GET" <client-request> ;
{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
{ $side-effects "request/response" } ;
+HELP: set-basic-auth
+{ $values { "request" request } { "username" string } { "password" string } }
+{ $description "Sets the " { $snippet "Authorization" } " header of " { $snippet "request" } " to perform HTTP Basic authentication with the given " { $snippet "username" } " and " { $snippet "password" } "." }
+{ $notes "This word always returns the same object that was input. This allows for a “pipeline” coding style, where several header parameters are set in a row." }
+{ $side-effects "request" } ;
+
ARTICLE: "http.cookies" "HTTP cookies"
"Every " { $link request } " and " { $link response } " instance can contain cookies."
$nl
! Test cloning
[ f ] [ <404> dup clone "b" "a" set-header drop "a" header ] unit-test
[ f ] [ <404> dup clone "b" "a" <cookie> put-cookie drop "a" get-cookie ] unit-test
+
+! Test basic auth
+[ "Basic QWxhZGRpbjpvcGVuIHNlc2FtZQ==" ] [ <request> "Aladdin" "open sesame" set-basic-auth "Authorization" header ] unit-test
+
+
io io.encodings io.encodings.iana io.encodings.binary
io.encodings.8-bit io.crlf
unicode.case unicode.categories
-http.parsers ;
+http.parsers
+base64 ;
IN: http
: (read-header) ( -- alist )
: set-header ( request/response value key -- request/response )
pick header>> set-at ;
+: set-basic-auth ( request username password -- request )
+ ":" glue >base64 "Basic " prepend "Authorization" set-header ;
+
: <request> ( -- request )
request new
"1.1" >>version
: header ( request/response key -- value )
swap header>> at ;
+
TUPLE: response
version
code
M: trivial-responder call-responder* nip response>> clone ;
-main-responder global [ <404> <trivial-responder> or ] change-at
+main-responder [ <404> <trivial-responder> ] initialize
: invert-slice ( slice -- slice' )
dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ;
"If all you want to do is serve files from a directory, the following phrase does the trick:"
{ $code
"USING: namespaces http.server http.server.static ;"
- "/var/www/mysite.com/ <static> main-responder set"
+ "\"/var/www/mysite.com/\" <static> main-responder set"
"8080 httpd"
}
{ $subsection "http.server.static.extend" } ;
[ file-responder get hook>> call ] [ 2drop <304> ] if ;\r
\r
: serving-path ( filename -- filename )\r
- file-responder get root>> trim-tail-separators\r
- "/"\r
- rot "" or trim-head-separators 3append ;\r
+ [ file-responder get root>> trim-tail-separators "/" ] dip\r
+ "" or trim-head-separators 3append ;\r
\r
: serve-file ( filename -- response )\r
dup mime-type\r
--- /dev/null
+Doug Coleman
\ No newline at end of file
--- /dev/null
+Doug Coleman
--- /dev/null
+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
--- /dev/null
+! Copyright (C) 2007, 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien alien.c-types arrays byte-arrays columns
+combinators fry grouping io io.binary io.encodings.binary io.files
+kernel macros math math.bitwise math.functions namespaces sequences
+strings images endian summary ;
+IN: images.bitmap
+
+TUPLE: bitmap-image < image ;
+
+! Currently can only handle 24/32bit bitmaps.
+! Handles row-reversed bitmaps (their height is negative)
+
+TUPLE: bitmap magic size reserved offset header-length width
+height planes bit-count compression size-image
+x-pels y-pels color-used color-important rgb-quads color-index
+buffer ;
+
+: array-copy ( bitmap array -- bitmap array' )
+ over size-image>> abs memory>byte-array ;
+
+: 8bit>buffer ( bitmap -- array )
+ [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
+ [ color-index>> >array ] bi [ swap nth ] with map concat ;
+
+ERROR: bmp-not-supported n ;
+
+: raw-bitmap>buffer ( bitmap -- array )
+ dup bit-count>>
+ {
+ { 32 [ color-index>> ] }
+ { 24 [ color-index>> ] }
+ { 16 [ bmp-not-supported ] }
+ { 8 [ 8bit>buffer ] }
+ { 4 [ bmp-not-supported ] }
+ { 2 [ bmp-not-supported ] }
+ { 1 [ bmp-not-supported ] }
+ } case >byte-array ;
+
+ERROR: bitmap-magic ;
+
+M: bitmap-magic summary
+ drop "First two bytes of bitmap stream must be 'BM'" ;
+
+: read2 ( -- n ) 2 read le> ;
+: read4 ( -- n ) 4 read le> ;
+
+: parse-file-header ( bitmap -- bitmap )
+ 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
+ read4 >>size
+ read4 >>reserved
+ read4 >>offset ;
+
+: parse-bitmap-header ( bitmap -- bitmap )
+ read4 >>header-length
+ read4 >>width
+ read4 >>height
+ read2 >>planes
+ read2 >>bit-count
+ read4 >>compression
+ read4 >>size-image
+ read4 >>x-pels
+ read4 >>y-pels
+ read4 >>color-used
+ read4 >>color-important ;
+
+: rgb-quads-length ( bitmap -- n )
+ [ offset>> 14 - ] [ header-length>> ] bi - ;
+
+: color-index-length ( bitmap -- n )
+ {
+ [ width>> ]
+ [ planes>> * ]
+ [ bit-count>> * 31 + 32 /i 4 * ]
+ [ height>> abs * ]
+ } cleave ;
+
+: parse-bitmap ( bitmap -- bitmap )
+ dup rgb-quads-length read >>rgb-quads
+ dup color-index-length read >>color-index ;
+
+: load-bitmap-data ( path -- bitmap )
+ binary [
+ bitmap new
+ parse-file-header parse-bitmap-header parse-bitmap
+ ] with-file-reader ;
+
+: process-bitmap-data ( bitmap -- bitmap )
+ dup raw-bitmap>buffer >>buffer ;
+
+: load-bitmap ( path -- bitmap )
+ load-bitmap-data process-bitmap-data ;
+
+ERROR: unknown-component-order bitmap ;
+
+: bitmap>component-order ( bitmap -- object )
+ bit-count>> {
+ { 32 [ BGRA ] }
+ { 24 [ BGR ] }
+ { 8 [ BGR ] }
+ [ unknown-component-order ]
+ } case ;
+
+: >image ( bitmap -- bitmap-image )
+ {
+ [ [ width>> ] [ height>> ] bi 2array ]
+ [ bitmap>component-order ]
+ [ buffer>> ]
+ } cleave bitmap-image boa ;
+
+M: bitmap-image load-image* ( path bitmap -- bitmap-image )
+ drop load-bitmap >image ;
+
+M: bitmap-image normalize-scan-line-order
+ dup dim>> '[
+ _ first 4 * <sliced-groups> reverse concat
+ ] change-bitmap ;
+
+MACRO: (nbits>bitmap) ( bits -- )
+ [ -3 shift ] keep '[
+ bitmap new
+ 2over * _ * >>size-image
+ swap >>height
+ swap >>width
+ swap array-copy [ >>buffer ] [ >>color-index ] bi
+ _ >>bit-count >image
+ ] ;
+
+: bgr>bitmap ( array height width -- bitmap )
+ 24 (nbits>bitmap) ;
+
+: bgra>bitmap ( array height width -- bitmap )
+ 32 (nbits>bitmap) ;
+
+: write2 ( n -- ) 2 >le write ;
+: write4 ( n -- ) 4 >le write ;
+
+: save-bitmap ( bitmap path -- )
+ binary [
+ B{ CHAR: B CHAR: M } write
+ [
+ buffer>> length 14 + 40 + write4
+ 0 write4
+ 54 write4
+ 40 write4
+ ] [
+ {
+ [ width>> write4 ]
+ [ height>> write4 ]
+ [ planes>> 1 or write2 ]
+ [ bit-count>> 24 or write2 ]
+ [ compression>> 0 or write4 ]
+ [ size-image>> write4 ]
+ [ x-pels>> 0 or write4 ]
+ [ y-pels>> 0 or write4 ]
+ [ color-used>> 0 or write4 ]
+ [ color-important>> 0 or write4 ]
+ [ rgb-quads>> write ]
+ [ color-index>> write ]
+ } cleave
+ ] bi
+ ] with-file-writer ;
--- /dev/null
+! 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 ;
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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 ;
--- /dev/null
+bitmap graphics
--- /dev/null
+Doug Coleman
--- /dev/null
+! 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" ;
--- /dev/null
+! 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 ;
"resource:basis/io/encodings/iana/character-sets"
utf8 <file-reader> make-aliases aliases set-global
-n>e-table global [ initial-n>e or ] change-at
-e>n-table global [ initial-e>n or ] change-at
+n>e-table [ initial-n>e ] initialize
+e>n-table [ initial-e>n ] initialize
: register-encoding ( descriptor name -- )
[
"out.txt" temp-file ascii file-lines first
] unit-test
-[ ] [
+[ "( scratchpad ) " ] [
<process>
console-vm "-run=listener" 2array >>command
+closed+ >>stdin
- try-process
+ +stdout+ >>stderr
+ ascii [ input-stream get contents ] with-process-reader
] unit-test
: launcher-test-path ( -- str )
"append-test" temp-file ascii file-contents
] unit-test
+
+
! Copyright (C) 2006 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
-
USING: help.markup help.syntax sequences strings lists ;
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
-{ $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." }
{ $see-also cons car cdr nil nil? } ;
{ $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? } ;
-{ 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
{ $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." } ;
-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
{ $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 "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 } ;
-{ 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
{ $values { "list" "a list of lists" } { "result" "a list" } }
] unit-test
[ { 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
[ [ ] lmap ] must-infer
M: lazy-map nil? ( lazy-map -- bool )
cons>> nil? ;
-: lazy-map-with ( value list quot -- result )
- with lazy-map ;
-
TUPLE: lazy-take n cons ;
C: <lazy-take> lazy-take
cons>> car ;
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 ;
M: lazy-until nil? ( lazy-until -- bool )
dup nil? [
drop nil
] [
- uncons swap (lconcat)
+ uncons (lconcat)
] if ;
M: lazy-concat car ( lazy-concat -- car )
] if ;
: 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 )
dup nil? [
drop nil
] [
[ 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
] if ;
! Copyright (C) 2006 Chris Double.
! 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
-{ 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
-{ $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." } ;
+
+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
{ $values { "cons" "a cons object" } { "car" "the first item in the list" } }
{ $description "Returns the first item in the list." } ;
HELP: cdr
{ $values { "cons" "a cons object" } { "cdr" "a cons object" } }
{ $description "Returns the tail of the list." } ;
-
+
+{ car cdr } related-words
+
HELP: nil
{ $values { "symbol" "The empty cons (+nil+)" } }
{ $description "Returns a symbol representing the empty list" } ;
{ $values { "object" object } { "?" "a boolean" } }
{ $description "Return true if the cons object is the nil cons." } ;
+{ nil nil? } related-words
+
HELP: list? ( object -- ? )
{ $values { "object" "an object" } { "?" "a boolean" } }
{ $description "Returns true if the object conforms to the list protocol." } ;
HELP: 3list
{ $values { "a" "an object" } { "b" "an object" } { "c" "an object" } { "cons" "a cons object" } }
{ $description "Create a list with 3 elements." } ;
-
+
HELP: lnth
{ $values { "n" "an integer index" } { "list" "a cons object" } { "elt" "the element at the nth index" } }
{ $description "Outputs the nth element of the list." }
{ $see-also lnth cons car cdr } ;
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." } ;
{ leach foldl lmap>array } related-words
HELP: lmap
{ $values { "list" "a cons object" } { "quot" { $quotation "( old -- new )" } } { "result" "the final result" } }
{ $description "Applies the quotation to each element of the list in order, collecting the new elements into a new list." } ;
-
+
HELP: lreverse
-{ $values { "list" "a cons object" } { "newlist" "a new cons object" } }
-{ $description "Reverses the input list, outputing a new, reversed list" } ;
-
-HELP: list>seq
-{ $values { "list" "a cons object" } { "array" "an array object" } }
+{ $values { "list" list } { "newlist" list } }
+{ $description "Reverses the input list, outputing a new, reversed list. The output is a strict cons list." } ;
+
+HELP: list>array
+{ $values { "list" "a cons object" } { "array" array } }
{ $description "Turns the given cons object into an array, maintaing order." } ;
-
-HELP: seq>list
-{ $values { "seq" "a sequence" } { "list" "a cons object" } }
+
+HELP: sequence>cons
+{ $values { "sequence" sequence } { "list" cons } }
{ $description "Turns the given array into a cons object, maintaing order." } ;
-
-HELP: cons>seq
-{ $values { "cons" "a cons object" } { "array" "an array object" } }
+
+HELP: deep-list>array
+{ $values { "list" list } { "array" array } }
{ $description "Recursively turns the given cons object into an array, maintaing order and also converting nested lists." } ;
-
-HELP: seq>cons
-{ $values { "seq" "a sequence object" } { "cons" "a cons object" } }
+
+HELP: deep-sequence>cons
+{ $values { "sequence" sequence } { "cons" cons } }
{ $description "Recursively turns the given sequence into a cons object, maintaing order and also converting nested lists." } ;
-
+
HELP: traverse
{ $values { "list" "a cons object" } { "pred" { $quotation "( list/elt -- ? )" } }
{ "quot" { $quotation "( list/elt -- result)" } } { "result" "a new cons object" } }
{ $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." } ;
! Copyright (C) 2008 James Cash
! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test lists math ;
-
+USING: tools.test lists math kernel ;
IN: lists.tests
{ { 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
{ { 3 4 5 6 } } [
+nil+ } } }
+nil+ } } }
} [
- { 1 2 { 3 4 { 5 } } } seq>cons
+ { 1 2 { 3 4 { 5 } } } deep-sequence>cons
] unit-test
{ { 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
{ 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
{ 15 } [
- { 1 2 3 4 5 } seq>list 0 [ + ] foldr
+ { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr
] unit-test
{ { 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
{ 5 } [
- { 1 2 3 4 5 } seq>list llength
+ { 1 2 3 4 5 } sequence>cons llength
] unit-test
{ { 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
{ { 1 2 3 4 5 6 } } [
- { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq
-] unit-test
\ No newline at end of file
+ { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array
+] unit-test
+
+[ { 1 } { 2 } ] [ { 1 2 } sequence>cons 1 lcut [ list>array ] bi@ ] unit-test
! Copyright (C) 2008 James Cash
! 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
! List Protocol
MIXIN: list
-GENERIC: car ( cons -- car )
-GENERIC: cdr ( cons -- cdr )
-GENERIC: nil? ( object -- ? )
+GENERIC: car ( cons -- car )
+GENERIC: cdr ( cons -- cdr )
+GENERIC: nil? ( object -- ? )
-TUPLE: cons car cdr ;
+TUPLE: cons { car read-only } { cdr read-only } ;
C: cons cons
M: cons cdr ( cons -- cdr )
cdr>> ;
-
-SYMBOL: +nil+
-M: word nil? +nil+ eq? ;
+
+SINGLETON: +nil+
+M: +nil+ nil? drop t ;
M: object nil? drop f ;
-
-: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ;
+
+: atom? ( obj -- ? )
+ list? not ;
: nil ( -- symbol ) +nil+ ;
-
-: uncons ( cons -- cdr car )
- [ cdr ] [ car ] bi ;
-
+
+: uncons ( cons -- car cdr )
+ [ car ] [ cdr ] bi ;
+
+: swons ( cdr car -- cons )
+ swap cons ;
+
+: unswons ( cons -- cdr car )
+ uncons swap ;
+
: 1list ( obj -- cons )
nil cons ;
-
+
+: 1list? ( list -- ? )
+ { [ nil? not ] [ cdr nil? ] } 1&& ;
+
: 2list ( a b -- cons )
nil cons cons ;
: 3list ( a b c -- cons )
nil cons cons cons ;
-
-: cadr ( cons -- elt )
+
+: cadr ( list -- elt )
cdr car ;
-
-: 2car ( cons -- car caar )
+
+: 2car ( list -- car caar )
[ car ] [ cdr car ] bi ;
-
-: 3car ( cons -- car cadr caddr )
+
+: 3car ( list -- car cadr caddr )
[ car ] [ cdr car ] [ cdr cdr car ] tri ;
: lnth ( n list -- elt )
swap [ cdr ] times car ;
-
+
+<PRIVATE
: (leach) ( list quot -- cdr quot )
[ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
+PRIVATE>
: leach ( list quot: ( elt -- ) -- )
over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
: foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result )
swapd leach ; inline
-: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result )
- pick nil? [ [ drop ] [ ] [ drop ] tri* ] [
- [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi
- call
+:: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result )
+ list nil? [ identity ] [
+ list cdr identity quot foldr
+ list car quot call
] if ; inline recursive
: llength ( list -- n )
0 [ drop 1+ ] foldl ;
-
+
: lreverse ( list -- newlist )
nil [ swap cons ] foldl ;
-
+
: lappend ( list1 list2 -- newlist )
[ 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 ;
-
+
+<PRIVATE
: same? ( obj1 obj2 -- ? )
[ class ] bi@ = ;
-
-: seq>cons ( seq -- cons )
- [ <reversed> ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ;
-
-: (lmap>array) ( acc cons quot: ( elt -- elt' ) -- newcons )
- over nil? [ 2drop ]
- [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ;
- inline recursive
-
-: lmap>array ( cons quot -- newcons )
- { } -rot (lmap>array) ; inline
-
-: lmap-as ( cons quot exemplar -- seq )
- [ lmap>array ] dip like ;
-
-: cons>seq ( cons -- array )
- [ dup cons? [ cons>seq ] when dup nil? [ drop { } ] when ] lmap>array ;
-
-: list>seq ( list -- array )
+PRIVATE>
+
+: deep-sequence>cons ( sequence -- cons )
+ [ <reversed> ] keep nil
+ [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ;
+
+<PRIVATE
+:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )
+ list nil? [ acc ] [
+ list car quot call acc push
+ acc list cdr quot (lmap>vector)
+ ] if ; inline recursive
+
+: lmap>vector ( list quot -- array )
+ [ V{ } clone ] 2dip (lmap>vector) ; inline
+PRIVATE>
+
+: lmap-as ( list quot exemplar -- sequence )
+ [ lmap>vector ] dip like ; inline
+
+: lmap>array ( list quot -- array )
+ { } lmap-as ; inline
+
+: deep-list>array ( list -- array )
+ [
+ {
+ { [ dup nil? ] [ drop { } ] }
+ { [ dup list? ] [ deep-list>array ] }
+ [ ]
+ } cond
+ ] lmap>array ;
+
+: list>array ( list -- array )
[ ] lmap>array ;
-
-: traverse ( list pred quot: ( list/elt -- result ) -- result )
- [ 2over call [ tuck [ call ] 2dip ] when
- pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive
-
+
+:: traverse ( list pred quot: ( list/elt -- result ) -- result )
+ list [| elt |
+ elt dup pred call [ quot call ] when
+ dup list? [ pred quot traverse ] when
+ ] lmap ; inline recursive
+
INSTANCE: cons list
+INSTANCE: +nil+ list
: signed-be> ( bytes -- x )
<reversed> signed-le> ;
+
+: >signed ( x n -- y )
+ 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ;
+
+++ /dev/null
-USING: alien alien.c-types alien.syntax kernel system
-combinators ;
-IN: math.blas.cblas
-
-<<
-: load-atlas ( -- )
- "atlas" "libatlas.so" "cdecl" add-library ;
-: load-fortran ( -- )
- "I77" "libI77.so" "cdecl" add-library
- "F77" "libF77.so" "cdecl" add-library ;
-: load-blas ( -- )
- "blas" "libblas.so" "cdecl" add-library ;
-
-"cblas" {
- { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] }
- { [ os windows? ] [ "blas.dll" "cdecl" add-library ] }
- { [ os openbsd? ] [ "libcblas.so" "cdecl" add-library load-blas ] }
- { [ os netbsd? ] [
- load-fortran load-blas
- "/usr/local/lib/libcblas.so" "cdecl" add-library
- ] }
- { [ os freebsd? ] [ "libcblas.so" "cdecl" add-library load-atlas ] }
- [ "libblas.so" "cdecl" add-library ]
-} cond
->>
-
-LIBRARY: cblas
-
-TYPEDEF: int CBLAS_ORDER
-CONSTANT: CblasRowMajor 101
-CONSTANT: CblasColMajor 102
-
-TYPEDEF: int CBLAS_TRANSPOSE
-CONSTANT: CblasNoTrans 111
-CONSTANT: CblasTrans 112
-CONSTANT: CblasConjTrans 113
-
-TYPEDEF: int CBLAS_UPLO
-CONSTANT: CblasUpper 121
-CONSTANT: CblasLower 122
-
-TYPEDEF: int CBLAS_DIAG
-CONSTANT: CblasNonUnit 131
-CONSTANT: CblasUnit 132
-
-TYPEDEF: int CBLAS_SIDE
-CONSTANT: CblasLeft 141
-CONSTANT: CblasRight 142
-
-TYPEDEF: int CBLAS_INDEX
-
-C-STRUCT: float-complex
- { "float" "real" }
- { "float" "imag" } ;
-C-STRUCT: double-complex
- { "double" "real" }
- { "double" "imag" } ;
-
-! Level 1 BLAS (scalar-vector and vector-vector)
-
-FUNCTION: float cblas_sdsdot
- ( int N, float alpha, float* X, int incX, float* Y, int incY ) ;
-FUNCTION: double cblas_dsdot
- ( int N, float* X, int incX, float* Y, int incY ) ;
-FUNCTION: float cblas_sdot
- ( int N, float* X, int incX, float* Y, int incY ) ;
-FUNCTION: double cblas_ddot
- ( int N, double* X, int incX, double* Y, int incY ) ;
-
-FUNCTION: void cblas_cdotu_sub
- ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ;
-FUNCTION: void cblas_cdotc_sub
- ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ;
-
-FUNCTION: void cblas_zdotu_sub
- ( int N, void* X, int incX, void* Y, int incY, void* dotu ) ;
-FUNCTION: void cblas_zdotc_sub
- ( int N, void* X, int incX, void* Y, int incY, void* dotc ) ;
-
-FUNCTION: float cblas_snrm2
- ( int N, float* X, int incX ) ;
-FUNCTION: float cblas_sasum
- ( int N, float* X, int incX ) ;
-
-FUNCTION: double cblas_dnrm2
- ( int N, double* X, int incX ) ;
-FUNCTION: double cblas_dasum
- ( int N, double* X, int incX ) ;
-
-FUNCTION: float cblas_scnrm2
- ( int N, void* X, int incX ) ;
-FUNCTION: float cblas_scasum
- ( int N, void* X, int incX ) ;
-
-FUNCTION: double cblas_dznrm2
- ( int N, void* X, int incX ) ;
-FUNCTION: double cblas_dzasum
- ( int N, void* X, int incX ) ;
-
-FUNCTION: CBLAS_INDEX cblas_isamax
- ( int N, float* X, int incX ) ;
-FUNCTION: CBLAS_INDEX cblas_idamax
- ( int N, double* X, int incX ) ;
-FUNCTION: CBLAS_INDEX cblas_icamax
- ( int N, void* X, int incX ) ;
-FUNCTION: CBLAS_INDEX cblas_izamax
- ( int N, void* X, int incX ) ;
-
-FUNCTION: void cblas_sswap
- ( int N, float* X, int incX, float* Y, int incY ) ;
-FUNCTION: void cblas_scopy
- ( int N, float* X, int incX, float* Y, int incY ) ;
-FUNCTION: void cblas_saxpy
- ( int N, float alpha, float* X, int incX, float* Y, int incY ) ;
-
-FUNCTION: void cblas_dswap
- ( int N, double* X, int incX, double* Y, int incY ) ;
-FUNCTION: void cblas_dcopy
- ( int N, double* X, int incX, double* Y, int incY ) ;
-FUNCTION: void cblas_daxpy
- ( int N, double alpha, double* X, int incX, double* Y, int incY ) ;
-
-FUNCTION: void cblas_cswap
- ( int N, void* X, int incX, void* Y, int incY ) ;
-FUNCTION: void cblas_ccopy
- ( int N, void* X, int incX, void* Y, int incY ) ;
-FUNCTION: void cblas_caxpy
- ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ;
-
-FUNCTION: void cblas_zswap
- ( int N, void* X, int incX, void* Y, int incY ) ;
-FUNCTION: void cblas_zcopy
- ( int N, void* X, int incX, void* Y, int incY ) ;
-FUNCTION: void cblas_zaxpy
- ( int N, void* alpha, void* X, int incX, void* Y, int incY ) ;
-
-FUNCTION: void cblas_sscal
- ( int N, float alpha, float* X, int incX ) ;
-FUNCTION: void cblas_dscal
- ( int N, double alpha, double* X, int incX ) ;
-FUNCTION: void cblas_cscal
- ( int N, void* alpha, void* X, int incX ) ;
-FUNCTION: void cblas_zscal
- ( int N, void* alpha, void* X, int incX ) ;
-FUNCTION: void cblas_csscal
- ( int N, float alpha, void* X, int incX ) ;
-FUNCTION: void cblas_zdscal
- ( int N, double alpha, void* X, int incX ) ;
-
-FUNCTION: void cblas_srotg
- ( float* a, float* b, float* c, float* s ) ;
-FUNCTION: void cblas_srotmg
- ( float* d1, float* d2, float* b1, float b2, float* P ) ;
-FUNCTION: void cblas_srot
- ( int N, float* X, int incX, float* Y, int incY, float c, float s ) ;
-FUNCTION: void cblas_srotm
- ( int N, float* X, int incX, float* Y, int incY, float* P ) ;
-
-FUNCTION: void cblas_drotg
- ( double* a, double* b, double* c, double* s ) ;
-FUNCTION: void cblas_drotmg
- ( double* d1, double* d2, double* b1, double b2, double* P ) ;
-FUNCTION: void cblas_drot
- ( int N, double* X, int incX, double* Y, int incY, double c, double s ) ;
-FUNCTION: void cblas_drotm
- ( int N, double* X, int incX, double* Y, int incY, double* P ) ;
-
-! Level 2 BLAS (matrix-vector)
-
-FUNCTION: void cblas_sgemv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- float alpha, float* A, int lda,
- float* X, int incX, float beta,
- float* Y, int incY ) ;
-FUNCTION: void cblas_sgbmv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- int KL, int KU, float alpha,
- float* A, int lda, float* X,
- int incX, float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_strmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, float* A, int lda,
- float* X, int incX ) ;
-FUNCTION: void cblas_stbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, float* A, int lda,
- float* X, int incX ) ;
-FUNCTION: void cblas_stpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, float* Ap, float* X, int incX ) ;
-FUNCTION: void cblas_strsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, float* A, int lda, float* X,
- int incX ) ;
-FUNCTION: void cblas_stbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, float* A, int lda,
- float* X, int incX ) ;
-FUNCTION: void cblas_stpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, float* Ap, float* X, int incX ) ;
-
-FUNCTION: void cblas_dgemv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- double alpha, double* A, int lda,
- double* X, int incX, double beta,
- double* Y, int incY ) ;
-FUNCTION: void cblas_dgbmv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- int KL, int KU, double alpha,
- double* A, int lda, double* X,
- int incX, double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dtrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, double* A, int lda,
- double* X, int incX ) ;
-FUNCTION: void cblas_dtbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, double* A, int lda,
- double* X, int incX ) ;
-FUNCTION: void cblas_dtpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, double* Ap, double* X, int incX ) ;
-FUNCTION: void cblas_dtrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, double* A, int lda, double* X,
- int incX ) ;
-FUNCTION: void cblas_dtbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, double* A, int lda,
- double* X, int incX ) ;
-FUNCTION: void cblas_dtpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, double* Ap, double* X, int incX ) ;
-
-FUNCTION: void cblas_cgemv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- void* alpha, void* A, int lda,
- void* X, int incX, void* beta,
- void* Y, int incY ) ;
-FUNCTION: void cblas_cgbmv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- int KL, int KU, void* alpha,
- void* A, int lda, void* X,
- int incX, void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_ctrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ctbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ctpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* Ap, void* X, int incX ) ;
-FUNCTION: void cblas_ctrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* A, int lda, void* X,
- int incX ) ;
-FUNCTION: void cblas_ctbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ctpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* Ap, void* X, int incX ) ;
-
-FUNCTION: void cblas_zgemv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- void* alpha, void* A, int lda,
- void* X, int incX, void* beta,
- void* Y, int incY ) ;
-FUNCTION: void cblas_zgbmv ( CBLAS_ORDER Order,
- CBLAS_TRANSPOSE TransA, int M, int N,
- int KL, int KU, void* alpha,
- void* A, int lda, void* X,
- int incX, void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_ztrmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ztbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ztpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* Ap, void* X, int incX ) ;
-FUNCTION: void cblas_ztrsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* A, int lda, void* X,
- int incX ) ;
-FUNCTION: void cblas_ztbsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, int K, void* A, int lda,
- void* X, int incX ) ;
-FUNCTION: void cblas_ztpsv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE TransA, CBLAS_DIAG Diag,
- int N, void* Ap, void* X, int incX ) ;
-
-
-FUNCTION: void cblas_ssymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* A,
- int lda, float* X, int incX,
- float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_ssbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, int K, float alpha, float* A,
- int lda, float* X, int incX,
- float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_sspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* Ap,
- float* X, int incX,
- float beta, float* Y, int incY ) ;
-FUNCTION: void cblas_sger ( CBLAS_ORDER Order, int M, int N,
- float alpha, float* X, int incX,
- float* Y, int incY, float* A, int lda ) ;
-FUNCTION: void cblas_ssyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* X,
- int incX, float* A, int lda ) ;
-FUNCTION: void cblas_sspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* X,
- int incX, float* Ap ) ;
-FUNCTION: void cblas_ssyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* X,
- int incX, float* Y, int incY, float* A,
- int lda ) ;
-FUNCTION: void cblas_sspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, float* X,
- int incX, float* Y, int incY, float* A ) ;
-
-FUNCTION: void cblas_dsymv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* A,
- int lda, double* X, int incX,
- double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dsbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, int K, double alpha, double* A,
- int lda, double* X, int incX,
- double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dspmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* Ap,
- double* X, int incX,
- double beta, double* Y, int incY ) ;
-FUNCTION: void cblas_dger ( CBLAS_ORDER Order, int M, int N,
- double alpha, double* X, int incX,
- double* Y, int incY, double* A, int lda ) ;
-FUNCTION: void cblas_dsyr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* X,
- int incX, double* A, int lda ) ;
-FUNCTION: void cblas_dspr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* X,
- int incX, double* Ap ) ;
-FUNCTION: void cblas_dsyr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* X,
- int incX, double* Y, int incY, double* A,
- int lda ) ;
-FUNCTION: void cblas_dspr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, double* X,
- int incX, double* Y, int incY, double* A ) ;
-
-
-FUNCTION: void cblas_chemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, void* alpha, void* A,
- int lda, void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_chbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, int K, void* alpha, void* A,
- int lda, void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_chpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, void* alpha, void* Ap,
- void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_cgeru ( CBLAS_ORDER Order, int M, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_cgerc ( CBLAS_ORDER Order, int M, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_cher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, void* X, int incX,
- void* A, int lda ) ;
-FUNCTION: void cblas_chpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, float alpha, void* X,
- int incX, void* A ) ;
-FUNCTION: void cblas_cher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_chpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* Ap ) ;
-
-FUNCTION: void cblas_zhemv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, void* alpha, void* A,
- int lda, void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_zhbmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, int K, void* alpha, void* A,
- int lda, void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_zhpmv ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, void* alpha, void* Ap,
- void* X, int incX,
- void* beta, void* Y, int incY ) ;
-FUNCTION: void cblas_zgeru ( CBLAS_ORDER Order, int M, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_zgerc ( CBLAS_ORDER Order, int M, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_zher ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, void* X, int incX,
- void* A, int lda ) ;
-FUNCTION: void cblas_zhpr ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- int N, double alpha, void* X,
- int incX, void* A ) ;
-FUNCTION: void cblas_zher2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* A, int lda ) ;
-FUNCTION: void cblas_zhpr2 ( CBLAS_ORDER Order, CBLAS_UPLO Uplo, int N,
- void* alpha, void* X, int incX,
- void* Y, int incY, void* Ap ) ;
-
-! Level 3 BLAS (matrix-matrix)
-
-FUNCTION: void cblas_sgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
- CBLAS_TRANSPOSE TransB, int M, int N,
- int K, float alpha, float* A,
- int lda, float* B, int ldb,
- float beta, float* C, int ldc ) ;
-FUNCTION: void cblas_ssymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- float alpha, float* A, int lda,
- float* B, int ldb, float beta,
- float* C, int ldc ) ;
-FUNCTION: void cblas_ssyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- float alpha, float* A, int lda,
- float beta, float* C, int ldc ) ;
-FUNCTION: void cblas_ssyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- float alpha, float* A, int lda,
- float* B, int ldb, float beta,
- float* C, int ldc ) ;
-FUNCTION: void cblas_strmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- float alpha, float* A, int lda,
- float* B, int ldb ) ;
-FUNCTION: void cblas_strsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- float alpha, float* A, int lda,
- float* B, int ldb ) ;
-
-FUNCTION: void cblas_dgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
- CBLAS_TRANSPOSE TransB, int M, int N,
- int K, double alpha, double* A,
- int lda, double* B, int ldb,
- double beta, double* C, int ldc ) ;
-FUNCTION: void cblas_dsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- double alpha, double* A, int lda,
- double* B, int ldb, double beta,
- double* C, int ldc ) ;
-FUNCTION: void cblas_dsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- double alpha, double* A, int lda,
- double beta, double* C, int ldc ) ;
-FUNCTION: void cblas_dsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- double alpha, double* A, int lda,
- double* B, int ldb, double beta,
- double* C, int ldc ) ;
-FUNCTION: void cblas_dtrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- double alpha, double* A, int lda,
- double* B, int ldb ) ;
-FUNCTION: void cblas_dtrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- double alpha, double* A, int lda,
- double* B, int ldb ) ;
-
-FUNCTION: void cblas_cgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
- CBLAS_TRANSPOSE TransB, int M, int N,
- int K, void* alpha, void* A,
- int lda, void* B, int ldb,
- void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_csymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_csyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_csyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_ctrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb ) ;
-FUNCTION: void cblas_ctrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb ) ;
-
-FUNCTION: void cblas_zgemm ( CBLAS_ORDER Order, CBLAS_TRANSPOSE TransA,
- CBLAS_TRANSPOSE TransB, int M, int N,
- int K, void* alpha, void* A,
- int lda, void* B, int ldb,
- void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_zsymm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_zsyrk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* beta, void* C, int ldc ) ;
-FUNCTION: void cblas_zsyr2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_ztrmm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb ) ;
-FUNCTION: void cblas_ztrsm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, CBLAS_TRANSPOSE TransA,
- CBLAS_DIAG Diag, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb ) ;
-
-FUNCTION: void cblas_chemm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_cherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- float alpha, void* A, int lda,
- float beta, void* C, int ldc ) ;
-FUNCTION: void cblas_cher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* B, int ldb, float beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_zhemm ( CBLAS_ORDER Order, CBLAS_SIDE Side,
- CBLAS_UPLO Uplo, int M, int N,
- void* alpha, void* A, int lda,
- void* B, int ldb, void* beta,
- void* C, int ldc ) ;
-FUNCTION: void cblas_zherk ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- double alpha, void* A, int lda,
- double beta, void* C, int ldc ) ;
-FUNCTION: void cblas_zher2k ( CBLAS_ORDER Order, CBLAS_UPLO Uplo,
- CBLAS_TRANSPOSE Trans, int N, int K,
- void* alpha, void* A, int lda,
- void* B, int ldb, double beta,
- void* C, int ldc ) ;
-
+++ /dev/null
-Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library
+++ /dev/null
-math
-bindings
--- /dev/null
+USING: alien alien.fortran kernel system combinators ;
+IN: math.blas.ffi
+
+<<
+"blas" {
+ { [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
+ { [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
+ { [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] }
+ { [ os freebsd? ] [ "libblas.so" gfortran-abi add-fortran-library ] }
+ [ "libblas.so" f2c-abi add-fortran-library ]
+} cond
+>>
+
+LIBRARY: blas
+
+! Level 1 BLAS (scalar-vector and vector-vector)
+
+FUNCTION: REAL SDSDOT
+ ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+FUNCTION: DOUBLE-PRECISION DSDOT
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+FUNCTION: REAL SDOT
+ ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+FUNCTION: DOUBLE-PRECISION DDOT
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+
+FUNCTION: COMPLEX CDOTU
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+FUNCTION: COMPLEX CDOTC
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+
+FUNCTION: DOUBLE-COMPLEX ZDOTU
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+FUNCTION: DOUBLE-COMPLEX ZDOTC
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+
+FUNCTION: REAL SNRM2
+ ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
+FUNCTION: REAL SASUM
+ ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
+
+FUNCTION: DOUBLE-PRECISION DNRM2
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+FUNCTION: DOUBLE-PRECISION DASUM
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+
+FUNCTION: REAL SCNRM2
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
+FUNCTION: REAL SCASUM
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
+
+FUNCTION: DOUBLE-PRECISION DZNRM2
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+FUNCTION: DOUBLE-PRECISION DZASUM
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+FUNCTION: INTEGER ISAMAX
+ ( INTEGER N, REAL(*) X, INTEGER INCX ) ;
+FUNCTION: INTEGER IDAMAX
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+FUNCTION: INTEGER ICAMAX
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX ) ;
+FUNCTION: INTEGER IZAMAX
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: SSWAP
+ ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SCOPY
+ ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SAXPY
+ ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: DSWAP
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DCOPY
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DAXPY
+ ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: CSWAP
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CCOPY
+ ( INTEGER N, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CAXPY
+ ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX, COMPLEX(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: ZSWAP
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZCOPY
+ ( INTEGER N, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZAXPY
+ ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+
+SUBROUTINE: SSCAL
+ ( INTEGER N, REAL ALPHA, REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: DSCAL
+ ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: CSCAL
+ ( INTEGER N, COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZSCAL
+ ( INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CSSCAL
+ ( INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZDSCAL
+ ( INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: SROTG
+ ( REAL(*) A, REAL(*) B, REAL(*) C, REAL(*) S ) ;
+SUBROUTINE: SROTMG
+ ( REAL(*) D1, REAL(*) D2, REAL(*) B1, REAL B2, REAL(*) P ) ;
+SUBROUTINE: SROT
+ ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL C, REAL S ) ;
+SUBROUTINE: SROTM
+ ( INTEGER N, REAL(*) X, INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) P ) ;
+
+SUBROUTINE: DROTG
+ ( DOUBLE-PRECISION(*) A, DOUBLE-PRECISION(*) B, DOUBLE-PRECISION(*) C, DOUBLE-PRECISION(*) S ) ;
+SUBROUTINE: DROTMG
+ ( DOUBLE-PRECISION(*) D1, DOUBLE-PRECISION(*) D2, DOUBLE-PRECISION(*) B1, DOUBLE-PRECISION B2, DOUBLE-PRECISION(*) P ) ;
+SUBROUTINE: DROT
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION C, DOUBLE-PRECISION S ) ;
+SUBROUTINE: DROTM
+ ( INTEGER N, DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) P ) ;
+
+! LEVEL 2 BLAS (MATRIX-VECTOR)
+
+SUBROUTINE: SGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL(*) X, INTEGER INCX, REAL BETA,
+ REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ INTEGER KL, INTEGER KU, REAL ALPHA,
+ REAL(*) A, INTEGER LDA, REAL(*) X,
+ INTEGER INCX, REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: STRMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, REAL(*) A, INTEGER LDA,
+ REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STBMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA,
+ REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STPMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STRSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, REAL(*) A, INTEGER LDA, REAL(*) X,
+ INTEGER INCX ) ;
+SUBROUTINE: STBSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, REAL(*) A, INTEGER LDA,
+ REAL(*) X, INTEGER INCX ) ;
+SUBROUTINE: STPSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, REAL(*) AP, REAL(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: DGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) X, INTEGER INCX, DOUBLE-PRECISION BETA,
+ DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ INTEGER KL, INTEGER KU, DOUBLE-PRECISION ALPHA,
+ DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX, DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DTRMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTBMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTPMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTRSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-PRECISION(*) A, INTEGER LDA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX ) ;
+SUBROUTINE: DTBSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+SUBROUTINE: DTPSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-PRECISION(*) AP, DOUBLE-PRECISION(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: CGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) X, INTEGER INCX, COMPLEX BETA,
+ COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ INTEGER KL, INTEGER KU, COMPLEX ALPHA,
+ COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
+ INTEGER INCX, COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CTRMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTBMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTPMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTRSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, COMPLEX(*) A, INTEGER LDA, COMPLEX(*) X,
+ INTEGER INCX ) ;
+SUBROUTINE: CTBSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: CTPSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, COMPLEX(*) AP, COMPLEX(*) X, INTEGER INCX ) ;
+
+SUBROUTINE: ZGEMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) X, INTEGER INCX, DOUBLE-COMPLEX BETA,
+ DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZGBMV ( CHARACTER*1 TRANSA, INTEGER M, INTEGER N,
+ INTEGER KL, INTEGER KU, DOUBLE-COMPLEX ALPHA,
+ DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
+ INTEGER INCX, DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZTRMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTBMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTPMV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTRSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-COMPLEX(*) A, INTEGER LDA, DOUBLE-COMPLEX(*) X,
+ INTEGER INCX ) ;
+SUBROUTINE: ZTBSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, INTEGER K, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+SUBROUTINE: ZTPSV ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANSA, CHARACTER*1 DIAG,
+ INTEGER N, DOUBLE-COMPLEX(*) AP, DOUBLE-COMPLEX(*) X, INTEGER INCX ) ;
+
+
+SUBROUTINE: SSYMV ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) A,
+ INTEGER LDA, REAL(*) X, INTEGER INCX,
+ REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SSBMV ( CHARACTER*1 UPLO,
+ INTEGER N, INTEGER K, REAL ALPHA, REAL(*) A,
+ INTEGER LDA, REAL(*) X, INTEGER INCX,
+ REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SSPMV ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) AP,
+ REAL(*) X, INTEGER INCX,
+ REAL BETA, REAL(*) Y, INTEGER INCY ) ;
+SUBROUTINE: SGER ( INTEGER M, INTEGER N,
+ REAL ALPHA, REAL(*) X, INTEGER INCX,
+ REAL(*) Y, INTEGER INCY, REAL(*) A, INTEGER LDA ) ;
+SUBROUTINE: SSYR ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) X,
+ INTEGER INCX, REAL(*) A, INTEGER LDA ) ;
+SUBROUTINE: SSPR ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) X,
+ INTEGER INCX, REAL(*) AP ) ;
+SUBROUTINE: SSYR2 ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) X,
+ INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A,
+ INTEGER LDA ) ;
+SUBROUTINE: SSPR2 ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, REAL(*) X,
+ INTEGER INCX, REAL(*) Y, INTEGER INCY, REAL(*) A ) ;
+
+SUBROUTINE: DSYMV ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
+ INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX,
+ DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DSBMV ( CHARACTER*1 UPLO,
+ INTEGER N, INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
+ INTEGER LDA, DOUBLE-PRECISION(*) X, INTEGER INCX,
+ DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DSPMV ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) AP,
+ DOUBLE-PRECISION(*) X, INTEGER INCX,
+ DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) Y, INTEGER INCY ) ;
+SUBROUTINE: DGER ( INTEGER M, INTEGER N,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X, INTEGER INCX,
+ DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A, INTEGER LDA ) ;
+SUBROUTINE: DSYR ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX, DOUBLE-PRECISION(*) A, INTEGER LDA ) ;
+SUBROUTINE: DSPR ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX, DOUBLE-PRECISION(*) AP ) ;
+SUBROUTINE: DSYR2 ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A,
+ INTEGER LDA ) ;
+SUBROUTINE: DSPR2 ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) X,
+ INTEGER INCX, DOUBLE-PRECISION(*) Y, INTEGER INCY, DOUBLE-PRECISION(*) A ) ;
+
+
+SUBROUTINE: CHEMV ( CHARACTER*1 UPLO,
+ INTEGER N, COMPLEX ALPHA, COMPLEX(*) A,
+ INTEGER LDA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CHBMV ( CHARACTER*1 UPLO,
+ INTEGER N, INTEGER K, COMPLEX ALPHA, COMPLEX(*) A,
+ INTEGER LDA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CHPMV ( CHARACTER*1 UPLO,
+ INTEGER N, COMPLEX ALPHA, COMPLEX(*) AP,
+ COMPLEX(*) X, INTEGER INCX,
+ COMPLEX BETA, COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: CGERU ( INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CGERC ( INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CHER ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CHPR ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, COMPLEX(*) X,
+ INTEGER INCX, COMPLEX(*) A ) ;
+SUBROUTINE: CHER2 ( CHARACTER*1 UPLO, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: CHPR2 ( CHARACTER*1 UPLO, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) X, INTEGER INCX,
+ COMPLEX(*) Y, INTEGER INCY, COMPLEX(*) AP ) ;
+
+SUBROUTINE: ZHEMV ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
+ INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZHBMV ( CHARACTER*1 UPLO,
+ INTEGER N, INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
+ INTEGER LDA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZHPMV ( CHARACTER*1 UPLO,
+ INTEGER N, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) AP,
+ DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) Y, INTEGER INCY ) ;
+SUBROUTINE: ZGERU ( INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZGERC ( INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZHER ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZHPR ( CHARACTER*1 UPLO,
+ INTEGER N, REAL ALPHA, DOUBLE-COMPLEX(*) X,
+ INTEGER INCX, DOUBLE-COMPLEX(*) A ) ;
+SUBROUTINE: ZHER2 ( CHARACTER*1 UPLO, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) A, INTEGER LDA ) ;
+SUBROUTINE: ZHPR2 ( CHARACTER*1 UPLO, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) X, INTEGER INCX,
+ DOUBLE-COMPLEX(*) Y, INTEGER INCY, DOUBLE-COMPLEX(*) AP ) ;
+
+! LEVEL 3 BLAS (MATRIX-MATRIX)
+
+SUBROUTINE: SGEMM ( CHARACTER*1 TRANSA,
+ CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+ INTEGER K, REAL ALPHA, REAL(*) A,
+ INTEGER LDA, REAL(*) B, INTEGER LDB,
+ REAL BETA, REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: SSYMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL(*) B, INTEGER LDB, REAL BETA,
+ REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: SSYRK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL BETA, REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: SSYR2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL(*) B, INTEGER LDB, REAL BETA,
+ REAL(*) C, INTEGER LDC ) ;
+SUBROUTINE: STRMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL(*) B, INTEGER LDB ) ;
+SUBROUTINE: STRSM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ REAL ALPHA, REAL(*) A, INTEGER LDA,
+ REAL(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: DGEMM ( CHARACTER*1 TRANSA,
+ CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+ INTEGER K, DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A,
+ INTEGER LDA, DOUBLE-PRECISION(*) B, INTEGER LDB,
+ DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DSYMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA,
+ DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DSYRK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION BETA, DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DSYR2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) B, INTEGER LDB, DOUBLE-PRECISION BETA,
+ DOUBLE-PRECISION(*) C, INTEGER LDC ) ;
+SUBROUTINE: DTRMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) B, INTEGER LDB ) ;
+SUBROUTINE: DTRSM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ DOUBLE-PRECISION ALPHA, DOUBLE-PRECISION(*) A, INTEGER LDA,
+ DOUBLE-PRECISION(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: CGEMM ( CHARACTER*1 TRANSA,
+ CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+ INTEGER K, COMPLEX ALPHA, COMPLEX(*) A,
+ INTEGER LDA, COMPLEX(*) B, INTEGER LDB,
+ COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CSYMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
+ COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CSYRK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX BETA, COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CSYR2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
+ COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CTRMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB ) ;
+SUBROUTINE: CTRSM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: ZGEMM ( CHARACTER*1 TRANSA,
+ CHARACTER*1 TRANSB, INTEGER M, INTEGER N,
+ INTEGER K, DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A,
+ INTEGER LDA, DOUBLE-COMPLEX(*) B, INTEGER LDB,
+ DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZSYMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
+ DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZSYRK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZSYR2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
+ DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZTRMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB ) ;
+SUBROUTINE: ZTRSM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, CHARACTER*1 TRANSA,
+ CHARACTER*1 DIAG, INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB ) ;
+
+SUBROUTINE: CHEMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB, COMPLEX BETA,
+ COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CHERK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ REAL ALPHA, COMPLEX(*) A, INTEGER LDA,
+ REAL BETA, COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: CHER2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ COMPLEX ALPHA, COMPLEX(*) A, INTEGER LDA,
+ COMPLEX(*) B, INTEGER LDB, REAL BETA,
+ COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZHEMM ( CHARACTER*1 SIDE,
+ CHARACTER*1 UPLO, INTEGER M, INTEGER N,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB, DOUBLE-COMPLEX BETA,
+ DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZHERK ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ REAL ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ REAL BETA, DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
+SUBROUTINE: ZHER2K ( CHARACTER*1 UPLO,
+ CHARACTER*1 TRANS, INTEGER N, INTEGER K,
+ DOUBLE-COMPLEX ALPHA, DOUBLE-COMPLEX(*) A, INTEGER LDA,
+ DOUBLE-COMPLEX(*) B, INTEGER LDB, REAL BETA,
+ DOUBLE-COMPLEX(*) C, INTEGER LDC ) ;
--- /dev/null
+Low-level bindings to the Basic Linear Algebra Subroutines (BLAS) library
--- /dev/null
+math
+bindings
+fortran
{ $subsection "math.blas.vectors" }
"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
{ $subsection "math.blas.matrices" }
-"The low-level BLAS C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ;
+"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ;
ARTICLE: "math.blas-types" "BLAS interface types"
"BLAS vectors come in single- and double-precision, real and complex flavors:"
{ $subsection float-blas-vector }
{ $subsection double-blas-vector }
-{ $subsection float-complex-blas-vector }
-{ $subsection double-complex-blas-vector }
+{ $subsection complex-float-blas-vector }
+{ $subsection complex-double-blas-vector }
"These vector types all follow the " { $link sequence } " protocol. In addition, there are corresponding types for matrix data:"
{ $subsection float-blas-matrix }
{ $subsection double-blas-matrix }
-{ $subsection float-complex-blas-matrix }
-{ $subsection double-complex-blas-matrix }
+{ $subsection complex-float-blas-matrix }
+{ $subsection complex-double-blas-matrix }
"There are BOA constructors for all vector and matrix types, which provide the most flexibility in specifying memory layout:"
{ $subsection <float-blas-vector> }
{ $subsection <double-blas-vector> }
-{ $subsection <float-complex-blas-vector> }
-{ $subsection <double-complex-blas-vector> }
+{ $subsection <complex-float-blas-vector> }
+{ $subsection <complex-double-blas-vector> }
{ $subsection <float-blas-matrix> }
{ $subsection <double-blas-matrix> }
-{ $subsection <float-complex-blas-matrix> }
-{ $subsection <double-complex-blas-matrix> }
+{ $subsection <complex-float-blas-matrix> }
+{ $subsection <complex-double-blas-matrix> }
"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:"
{ $subsection <empty-vector> }
{ $subsection <empty-matrix> }
"BLAS vectors and matrices can also be constructed from other Factor sequences:"
{ $subsection >float-blas-vector }
{ $subsection >double-blas-vector }
-{ $subsection >float-complex-blas-vector }
-{ $subsection >double-complex-blas-vector }
+{ $subsection >complex-float-blas-vector }
+{ $subsection >complex-double-blas-vector }
{ $subsection >float-blas-matrix }
{ $subsection >double-blas-matrix }
-{ $subsection >float-complex-blas-matrix }
-{ $subsection >double-complex-blas-matrix } ;
+{ $subsection >complex-float-blas-matrix }
+{ $subsection >complex-double-blas-matrix } ;
ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
"Transposing and slicing matrices:"
{ $list
{ { $link float-blas-matrix } }
{ { $link double-blas-matrix } }
- { { $link float-complex-blas-matrix } }
- { { $link double-complex-blas-matrix } }
+ { { $link complex-float-blas-matrix } }
+ { { $link complex-double-blas-matrix } }
}
"All of these subclasses share the same tuple layout:"
{ $list
{ $class-description "A matrix of single-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
HELP: double-blas-matrix
{ $class-description "A matrix of double-precision floating-point values. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-HELP: float-complex-blas-matrix
+HELP: complex-float-blas-matrix
{ $class-description "A matrix of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
-HELP: double-complex-blas-matrix
+HELP: complex-double-blas-matrix
{ $class-description "A matrix of double-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-matrix-base } "." } ;
{
- float-blas-matrix double-blas-matrix float-complex-blas-matrix double-complex-blas-matrix
- float-blas-vector double-blas-vector float-complex-blas-vector double-complex-blas-vector
+ float-blas-matrix double-blas-matrix complex-float-blas-matrix complex-double-blas-matrix
+ float-blas-vector double-blas-vector complex-float-blas-vector complex-double-blas-vector
} related-words
HELP: Mwidth
{ 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
} "> }
-{ $description "Construct a literal " { $link float-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+{ $description "Construct a literal " { $link complex-float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
HELP: zmatrix{
{ $syntax <" zmatrix{
{ 0.0 0.0 -1.0 3.0 }
{ 0.0 0.0 0.0 C{ 0.0 -1.0 } }
} "> }
-{ $description "Construct a literal " { $link double-complex-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
+{ $description "Construct a literal " { $link complex-double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ;
{
POSTPONE: smatrix{ POSTPONE: dmatrix{
USING: accessors alien alien.c-types arrays byte-arrays combinators
combinators.short-circuit fry kernel locals macros
-math math.blas.cblas math.blas.vectors math.blas.vectors.private
+math math.blas.ffi math.blas.vectors math.blas.vectors.private
math.complex math.functions math.order functors words
sequences sequences.merged sequences.private shuffle
specialized-arrays.direct.float specialized-arrays.direct.double
specialized-arrays.float specialized-arrays.double
-parser prettyprint.backend prettyprint.custom ;
+specialized-arrays.direct.complex-float specialized-arrays.direct.complex-double
+specialized-arrays.complex-float specialized-arrays.complex-double
+parser prettyprint.backend prettyprint.custom ascii ;
IN: math.blas.matrices
TUPLE: blas-matrix-base underlying ld rows cols transpose ;
<PRIVATE
: (blas-transpose) ( matrix -- integer )
- transpose>> [ CblasTrans ] [ CblasNoTrans ] if ;
+ transpose>> [ "T" ] [ "N" ] if ;
GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix )
unless ;
:: (prepare-gemv)
- ( alpha A x beta y >c-arg -- order A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc
- y )
+ ( alpha A x beta y -- A-trans m n alpha A-data A-ld x-data x-inc beta y-data y-inc
+ y )
A x y (validate-gemv)
- CblasColMajor
A (blas-transpose)
A rows>>
A cols>>
- alpha >c-arg call
- A underlying>>
+ alpha
+ A
A ld>>
- x underlying>>
+ x
x inc>>
- beta >c-arg call
- y underlying>>
+ beta
+ y
y inc>>
y ; inline
: (validate-ger) ( x y A -- )
{
- [ nip [ length>> ] [ Mheight ] bi* = ]
- [ nipd [ length>> ] [ Mwidth ] bi* = ]
+ [ [ length>> ] [ drop ] [ Mheight ] tri* = ]
+ [ [ drop ] [ length>> ] [ Mwidth ] tri* = ]
} 3&&
[ "Mismatched vertices and matrix in vector outer product" throw ]
unless ;
:: (prepare-ger)
- ( alpha x y A >c-arg -- order m n alpha x-data x-inc y-data y-inc A-data A-ld
- A )
+ ( alpha x y A -- m n alpha x-data x-inc y-data y-inc A-data A-ld
+ A )
x y A (validate-ger)
- CblasColMajor
A rows>>
A cols>>
- alpha >c-arg call
- x underlying>>
+ alpha
+ x
x inc>>
- y underlying>>
+ y
y inc>>
- A underlying>>
+ A
A ld>>
A f >>transpose ; inline
: (validate-gemm) ( A B C -- )
{
- [ drop [ Mwidth ] [ Mheight ] bi* = ]
- [ nip [ Mheight ] bi@ = ]
- [ nipd [ Mwidth ] bi@ = ]
+ [ [ Mwidth ] [ Mheight ] [ drop ] tri* = ]
+ [ [ Mheight ] [ drop ] [ Mheight ] tri* = ]
+ [ [ drop ] [ Mwidth ] [ Mwidth ] tri* = ]
} 3&&
[ "Mismatched matrices in matrix multiplication" throw ]
unless ;
:: (prepare-gemm)
- ( alpha A B beta C >c-arg -- order A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld
- C )
+ ( alpha A B beta C -- A-trans B-trans m n k alpha A-data A-ld B-data B-ld beta C-data C-ld
+ C )
A B C (validate-gemm)
- CblasColMajor
A (blas-transpose)
B (blas-transpose)
C rows>>
C cols>>
A Mwidth
- alpha >c-arg call
- A underlying>>
+ alpha
+ A
A ld>>
- B underlying>>
+ B
B ld>>
- beta >c-arg call
- C underlying>>
+ beta
+ C
C ld>>
C f >>transpose ; inline
VECTOR IS ${TYPE}-blas-vector
<VECTOR> IS <${TYPE}-blas-vector>
>ARRAY IS >${TYPE}-array
-TYPE>ARG IS ${TYPE}>arg
-XGEMV IS cblas_${T}gemv
-XGEMM IS cblas_${T}gemm
-XGERU IS cblas_${T}ger${U}
-XGERC IS cblas_${T}ger${C}
+XGEMV IS ${T}GEMV
+XGEMM IS ${T}GEMM
+XGERU IS ${T}GER${U}
+XGERC IS ${T}GER${C}
MATRIX DEFINES-CLASS ${TYPE}-blas-matrix
<MATRIX> DEFINES <${TYPE}-blas-matrix>
>MATRIX DEFINES >${TYPE}-blas-matrix
-XMATRIX{ DEFINES ${T}matrix{
+
+t [ T >lower ]
+
+XMATRIX{ DEFINES ${t}matrix{
WHERE
drop <VECTOR> ;
: >MATRIX ( arrays -- matrix )
- [ >ARRAY underlying>> ] (>matrix)
- <MATRIX> ;
+ [ >ARRAY underlying>> ] (>matrix) <MATRIX> ;
M: VECTOR n*M.V+n*V!
- [ TYPE>ARG ] (prepare-gemv)
- [ XGEMV ] dip ;
+ (prepare-gemv) [ XGEMV ] dip ;
M: MATRIX n*M.M+n*M!
- [ TYPE>ARG ] (prepare-gemm)
- [ XGEMM ] dip ;
+ (prepare-gemm) [ XGEMM ] dip ;
M: MATRIX n*V(*)V+M!
- [ TYPE>ARG ] (prepare-ger)
- [ XGERU ] dip ;
+ (prepare-ger) [ XGERU ] dip ;
M: MATRIX n*V(*)Vconj+M!
- [ TYPE>ARG ] (prepare-ger)
- [ XGERC ] dip ;
+ (prepare-ger) [ XGERC ] dip ;
: XMATRIX{ \ } [ >MATRIX ] parse-literal ; parsing
: define-real-blas-matrix ( TYPE T -- )
"" "" (define-blas-matrix) ;
: define-complex-blas-matrix ( TYPE T -- )
- "u" "c" (define-blas-matrix) ;
+ "U" "C" (define-blas-matrix) ;
-"float" "s" define-real-blas-matrix
-"double" "d" define-real-blas-matrix
-"float-complex" "c" define-complex-blas-matrix
-"double-complex" "z" define-complex-blas-matrix
+"float" "S" define-real-blas-matrix
+"double" "D" define-real-blas-matrix
+"complex-float" "C" define-complex-blas-matrix
+"complex-double" "Z" define-complex-blas-matrix
>>
{ $list
{ { $link float-blas-vector } }
{ { $link double-blas-vector } }
- { { $link float-complex-blas-vector } }
- { { $link double-complex-blas-vector } }
+ { { $link complex-float-blas-vector } }
+ { { $link complex-double-blas-vector } }
}
"All of these subclasses share the same tuple layout:"
{ $list
{ $class-description "A vector of single-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
HELP: double-blas-vector
{ $class-description "A vector of double-precision floating-point values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: float-complex-blas-vector
-{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: double-complex-blas-vector
-{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: complex-float-blas-vector
+{ $class-description "A vector of single-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
+HELP: complex-double-blas-vector
+{ $class-description "A vector of double-precision floating-point complex values. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
HELP: n*V+V!
{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" blas-vector-base } }
HELP: Vamax
{ $values { "x" blas-vector-base } { "max" number } }
-{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the first element. Corresponds to the IxAMAX routines in BLAS." } ;
+{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the element closest to the beginning. Corresponds to the IxAMAX routines in BLAS." } ;
{ Viamax Vamax } related-words
HELP: cvector{
{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
-{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ;
+{ $description "Construct a literal " { $link complex-float-blas-vector } "." } ;
HELP: zvector{
{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" }
-{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ;
+{ $description "Construct a literal " { $link complex-double-blas-vector } "." } ;
{
POSTPONE: svector{ POSTPONE: dvector{
-USING: kernel math.blas.vectors sequences tools.test ;
+USING: kernel math.blas.vectors math.functions sequences tools.test ;
IN: math.blas.vectors.tests
! clone
! Vnorm
-[ 5.0 ] [ svector{ 3.0 4.0 } Vnorm ] unit-test
-[ 5.0 ] [ dvector{ 3.0 4.0 } Vnorm ] unit-test
+[ t ] [ svector{ 3.0 4.0 } Vnorm 5.0 0.000001 ~ ] unit-test
+[ t ] [ dvector{ 3.0 4.0 } Vnorm 5.0 0.000001 ~ ] unit-test
-[ 13.0 ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test
-[ 13.0 ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test
+[ t ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm 13.0 0.000001 ~ ] unit-test
+[ t ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm 13.0 0.000001 ~ ] unit-test
! Vasum
-USING: accessors alien alien.c-types arrays byte-arrays combinators
-combinators.short-circuit fry kernel math math.blas.cblas
-math.complex math.functions math.order sequences.complex
-sequences.complex-components sequences sequences.private
+USING: accessors alien alien.c-types arrays ascii byte-arrays combinators
+combinators.short-circuit fry kernel math math.blas.ffi
+math.complex math.functions math.order sequences sequences.private
functors words locals parser prettyprint.backend prettyprint.custom
specialized-arrays.float specialized-arrays.double
-specialized-arrays.direct.float specialized-arrays.direct.double ;
+specialized-arrays.direct.float specialized-arrays.direct.double
+specialized-arrays.complex-float specialized-arrays.complex-double
+specialized-arrays.direct.complex-float
+specialized-arrays.direct.complex-double ;
IN: math.blas.vectors
TUPLE: blas-vector-base underlying length inc ;
: shorter-length ( v1 v2 -- length )
[ length>> ] bi@ min ; inline
: data-and-inc ( v -- data inc )
- [ underlying>> ] [ inc>> ] bi ; inline
+ [ ] [ inc>> ] bi ; inline
: datas-and-incs ( v1 v2 -- v1-data v1-inc v2-data v2-inc )
[ data-and-inc ] bi@ ; inline
<DIRECT-ARRAY> IS <direct-${TYPE}-array>
>ARRAY IS >${TYPE}-array
-XCOPY IS cblas_${T}copy
-XSWAP IS cblas_${T}swap
-IXAMAX IS cblas_i${T}amax
+XCOPY IS ${T}COPY
+XSWAP IS ${T}SWAP
+IXAMAX IS I${T}AMAX
VECTOR DEFINES-CLASS ${TYPE}-blas-vector
<VECTOR> DEFINES <${TYPE}-blas-vector>
>VECTOR DEFINES >${TYPE}-blas-vector
-XVECTOR{ DEFINES ${T}vector{
+t [ T >lower ]
+
+XVECTOR{ DEFINES ${t}vector{
+
+XAXPY IS ${T}AXPY
+XSCAL IS ${T}SCAL
WHERE
M: VECTOR Vswap
(prepare-swap) [ XSWAP ] 2dip ;
M: VECTOR Viamax
- (prepare-nrm2) IXAMAX ;
+ (prepare-nrm2) IXAMAX 1- ;
M: VECTOR (blas-vector-like)
drop <VECTOR> ;
[ [ length>> ] [ inc>> ] bi * ] bi
<DIRECT-ARRAY> ;
+M: VECTOR n*V+V!
+ (prepare-axpy) [ XAXPY ] dip ;
+M: VECTOR n*V!
+ (prepare-scal) [ XSCAL ] dip ;
+
: XVECTOR{ \ } [ >VECTOR ] parse-literal ; parsing
M: VECTOR pprint-delims
FUNCTOR: (define-real-blas-vector) ( TYPE T -- )
VECTOR IS ${TYPE}-blas-vector
-XDOT IS cblas_${T}dot
-XNRM2 IS cblas_${T}nrm2
-XASUM IS cblas_${T}asum
-XAXPY IS cblas_${T}axpy
-XSCAL IS cblas_${T}scal
+XDOT IS ${T}DOT
+XNRM2 IS ${T}NRM2
+XASUM IS ${T}ASUM
WHERE
(prepare-nrm2) XNRM2 ;
M: VECTOR Vasum
(prepare-nrm2) XASUM ;
-M: VECTOR n*V+V!
- (prepare-axpy) [ XAXPY ] dip ;
-M: VECTOR n*V!
- (prepare-scal) [ XSCAL ] dip ;
-
-;FUNCTOR
-
-
-FUNCTOR: (define-complex-helpers) ( TYPE -- )
-
-<DIRECT-COMPLEX-ARRAY> DEFINES <direct-${TYPE}-complex-array>
->COMPLEX-ARRAY DEFINES >${TYPE}-complex-array
-ARG>COMPLEX DEFINES arg>${TYPE}-complex
-COMPLEX>ARG DEFINES ${TYPE}-complex>arg
-<DIRECT-ARRAY> IS <direct-${TYPE}-array>
->ARRAY IS >${TYPE}-array
-
-WHERE
-
-: <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
- 1 shift <DIRECT-ARRAY> <complex-sequence> ;
-: >COMPLEX-ARRAY ( sequence -- sequence )
- <complex-components> >ARRAY ;
-: COMPLEX>ARG ( complex -- alien )
- >rect 2array >ARRAY underlying>> ;
-: ARG>COMPLEX ( alien -- complex )
- 2 <DIRECT-ARRAY> first2 rect> ;
;FUNCTOR
FUNCTOR: (define-complex-blas-vector) ( TYPE C S -- )
VECTOR IS ${TYPE}-blas-vector
-XDOTU_SUB IS cblas_${C}dotu_sub
-XDOTC_SUB IS cblas_${C}dotc_sub
-XXNRM2 IS cblas_${S}${C}nrm2
-XXASUM IS cblas_${S}${C}asum
-XAXPY IS cblas_${C}axpy
-XSCAL IS cblas_${C}scal
-TYPE>ARG IS ${TYPE}>arg
-ARG>TYPE IS arg>${TYPE}
+XDOTU IS ${C}DOTU
+XDOTC IS ${C}DOTC
+XXNRM2 IS ${S}${C}NRM2
+XXASUM IS ${S}${C}ASUM
WHERE
M: VECTOR V.
- (prepare-dot) TYPE <c-object>
- [ XDOTU_SUB ] keep
- ARG>TYPE ;
+ (prepare-dot) XDOTU ;
M: VECTOR V.conj
- (prepare-dot) TYPE <c-object>
- [ XDOTC_SUB ] keep
- ARG>TYPE ;
+ (prepare-dot) XDOTC ;
M: VECTOR Vnorm
(prepare-nrm2) XXNRM2 ;
M: VECTOR Vasum
(prepare-nrm2) XXASUM ;
-M: VECTOR n*V+V!
- [ TYPE>ARG ] 2dip
- (prepare-axpy) [ XAXPY ] dip ;
-M: VECTOR n*V!
- [ TYPE>ARG ] dip
- (prepare-scal) [ XSCAL ] dip ;
;FUNCTOR
: define-real-blas-vector ( TYPE T -- )
[ (define-blas-vector) ]
[ (define-real-blas-vector) ] 2bi ;
-:: define-complex-blas-vector ( TYPE C S -- )
- TYPE (define-complex-helpers)
- TYPE "-complex" append
- [ C (define-blas-vector) ]
- [ C S (define-complex-blas-vector) ] bi ;
-
-"float" "s" define-real-blas-vector
-"double" "d" define-real-blas-vector
-"float" "c" "s" define-complex-blas-vector
-"double" "z" "d" define-complex-blas-vector
+: define-complex-blas-vector ( TYPE C S -- )
+ [ drop (define-blas-vector) ]
+ [ (define-complex-blas-vector) ] 3bi ;
+
+"float" "S" define-real-blas-vector
+"double" "D" define-real-blas-vector
+"complex-float" "C" "S" define-complex-blas-vector
+"complex-double" "Z" "D" define-complex-blas-vector
>>
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel make math math.order math.vectors sequences shuffle
+USING: arrays kernel make math math.order math.vectors sequences
splitting vectors ;
IN: math.polynomials
PRIVATE>
: pgcd ( p q -- a d )
- swap V{ 0 } clone V{ 1 } clone 2swap (pgcd) [ >array ] bi@ ;
+ [ V{ 0 } clone V{ 1 } clone ] 2dip swap (pgcd) [ >array ] bi@ ;
: pdiff ( p -- p' )
dup length v* { 0 } ?head drop ;
{ CHAR: D 8 }
}
+PRIVATE>
+
MACRO: pack ( str -- quot )
[ pack-table at '[ _ execute ] ] { } map-as
'[ [ [ _ spread ] input<sequence ] B{ } append-outputs-as ] ;
-PRIVATE>
-
: ch>packed-length ( ch -- n )
packed-length-table at ; inline
: start/end ( seq -- seq1 seq2 )
[ 0 [ + ] accumulate nip dup ] keep v+ ; inline
+PRIVATE>
+
MACRO: unpack ( str -- quot )
[ [ ch>packed-length ] { } map-as start/end ]
[ [ unpack-table at '[ @ ] ] { } map-as ] bi
[ '[ [ _ _ ] dip <slice> @ ] ] 3map
'[ [ _ cleave ] output>array ] ;
-PRIVATE>
-
: unpack-native ( seq str -- seq )
'[ _ _ unpack ] with-native-endian ; inline
+! Copyright (C) 2008 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel sequences ;
IN: persistent.deques
-! Copyback (C) 2008 Daniel Ehrenberg
+! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors math lists ;
-QUALIFIED: sequences
+USING: kernel accessors math lists sequences combinators.short-circuit ;
IN: persistent.deques
! Amortized O(1) push/pop on both ends for single-threaded access
! same source, it could take O(m) amortized time per update.
<PRIVATE
-
-: each ( list quot: ( elt -- ) -- )
- over
- [ [ [ car ] dip call ] [ [ cdr ] dip ] 2bi each ]
- [ 2drop ] if ; inline recursive
-
-: reduce ( list start quot -- end )
- swapd each ; inline
-
-: reverse ( list -- reversed )
- f [ swap cons ] reduce ;
-
-: length ( list -- length )
- 0 [ drop 1+ ] reduce ;
-
-: cut ( list index -- back front-reversed )
- f swap [ [ [ cdr ] [ car ] bi ] dip cons ] times ;
-
: split-reverse ( list -- back-reversed front )
- dup length 2/ cut [ reverse ] bi@ ;
+ dup llength 2/ lcut lreverse swap ;
PRIVATE>
TUPLE: deque { front read-only } { back read-only } ;
-: <deque> ( -- deque ) T{ deque } ;
+: <deque> ( -- deque )
+ T{ deque f +nil+ +nil+ } ;
<PRIVATE
: flip ( deque -- newdeque )
PRIVATE>
: deque-empty? ( deque -- ? )
- [ front>> ] [ back>> ] bi or not ;
+ { [ front>> nil? ] [ back>> nil? ] } 1&& ;
<PRIVATE
: push ( item deque -- newdeque )
[ front>> car ] [ [ front>> cdr ] [ back>> ] bi deque boa ] bi ; inline
: transfer ( deque -- item newdeque )
- back>> [ split-reverse deque boa remove ]
- [ "Popping from an empty deque" throw ] if* ; inline
+ back>> dup nil?
+ [ "Popping from an empty deque" throw ]
+ [ split-reverse deque boa remove ] if ; inline
: pop ( deque -- item newdeque )
- dup front>> [ remove ] [ transfer ] if ; inline
+ dup front>> nil? [ transfer ] [ remove ] if ; inline
PRIVATE>
: pop-front ( deque -- item newdeque )
: pop-back ( deque -- item newdeque )
[ pop ] flipped ;
-: peek-front ( deque -- item ) pop-front drop ;
+: peek-front ( deque -- item )
+ pop-front drop ;
-: peek-back ( deque -- item ) pop-back drop ;
+: peek-back ( deque -- item )
+ pop-back drop ;
: sequence>deque ( sequence -- deque )
- <deque> [ push-back ] sequences:reduce ;
+ <deque> [ push-back ] reduce ;
: deque>sequence ( deque -- sequence )
- [ dup deque-empty? not ] [ pop-front swap ] [ ] sequences:produce nip ;
+ [ dup deque-empty? not ] [ pop-front swap ] [ ] produce nip ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators kernel math
quotations sequences regexp.parser regexp.classes fry arrays
-combinators.short-circuit regexp.utils prettyprint regexp.nfa
-shuffle ;
+combinators.short-circuit regexp.utils prettyprint regexp.nfa ;
IN: regexp.traversal
TUPLE: dfa-traverser
] [ drop ] if ;
: match-default ( transition from-state table -- to-state/f )
- nipd transitions>> at t swap at ;
+ [ drop ] 2dip transitions>> at t swap at ;
: match-transition ( obj from-state dfa -- to-state/f )
{ [ match-literal ] [ match-class ] [ match-default ] } 3|| ;
USING: shuffle tools.test ;
-[ 8 ] [ 5 6 7 8 3nip ] unit-test
-[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test
[ 1 2 3 4 ] [ 3 4 1 2 2swap ] unit-test
+
+[ 4 2 3 ] [ 1 2 3 4 shuffle( a b c d -- d b c ) ] unit-test
! Copyright (C) 2007 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel generalizations ;
-
+USING: accessors assocs combinators effects.parser generalizations
+hashtables kernel locals locals.backend macros make math
+parser sequences ;
IN: shuffle
-: 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
+<PRIVATE
+
+: >index-assoc ( sequence -- assoc )
+ dup length zip >hashtable ;
-: nipd ( a b c -- b c ) rot drop ; inline
+PRIVATE>
-: 3nip ( a b c d -- d ) 3 nnip ; inline
+MACRO: shuffle-effect ( effect -- )
+ [ out>> ] [ in>> >index-assoc ] bi
+ [
+ [ nip assoc-size , \ narray , ]
+ [ [ at \ swap \ nth [ ] 3sequence ] curry map , \ cleave , ] 2bi
+ ] [ ] make ;
-: 4nip ( a b c d e -- e ) 4 nnip ; inline
+: shuffle(
+ ")" parse-effect parsed \ shuffle-effect parsed ; parsing
+
+: 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline
: 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline
: 4drop ( a b c d -- ) 3drop drop ; inline
-
-: tuckd ( x y z -- z x y z ) 2 ntuck ; inline
--- /dev/null
+USING: kernel sequences specialized-arrays.complex-double tools.test ;
+IN: specialized-arrays.complex-double.tests
+
+[ C{ 3.0 2.0 } ]
+[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } second ] unit-test
+
+[ C{ 1.0 0.0 } ]
+[ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 } first ] unit-test
+
+[ complex-double-array{ 1.0 C{ 6.0 -7.0 } 5.0 } ] [
+ complex-double-array{ 1.0 C{ 3.0 2.0 } 5.0 }
+ dup [ C{ 6.0 -7.0 } 1 ] dip set-nth
+] unit-test
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.complex-double
+
+<< "complex-double" define-array >>
--- /dev/null
+USE: specialized-arrays.functor
+IN: specialized-arrays.complex-float
+
+<< "complex-float" define-array >>
--- /dev/null
+USING: specialized-arrays.complex-double specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.complex-double
+
+<< "complex-double" define-direct-array >>
--- /dev/null
+USING: specialized-arrays.complex-float specialized-arrays.direct.functor ;
+IN: specialized-arrays.direct.complex-float
+
+<< "complex-float" define-direct-array >>
A DEFINES-CLASS direct-${T}-array
<A> DEFINES <${A}>
-NTH [ T dup c-getter array-accessor ]
+NTH [ T dup c-type-getter-boxer array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]
WHERE
byte-array>A DEFINES byte-array>${A}
A{ DEFINES ${A}{
-NTH [ T dup c-getter array-accessor ]
+NTH [ T dup c-type-getter-boxer array-accessor ]
SET-NTH [ T dup c-setter array-accessor ]
WHERE
{ $snippet "ulonglong" }
{ $snippet "float" }
{ $snippet "double" }
+ { $snippet "complex-float" }
+ { $snippet "complex-double" }
{ $snippet "void*" }
{ $snippet "bool" }
}
SYMBOL: word-timing
-word-timing global [ H{ } clone or ] change-at
+word-timing [ H{ } clone ] initialize
: reset-word-timing ( -- )
word-timing get clear-assoc ;
destructors accessors ;
IN: tools.deploy.backend
-: copy-vm ( executable bundle-name extension -- vm )
- [ prepend-path ] dip append vm over copy-file ;
+: copy-vm ( executable bundle-name -- vm )
+ prepend-path vm over copy-file ;
: copy-fonts ( name dir -- )
deploy-ui? get [
} cleave
]
[ create-app-plist ]
- [ "Contents/MacOS/" append-path "" copy-vm ] 2tri
+ [ "Contents/MacOS/" append-path copy-vm ] 2tri
dup OCT: 755 set-file-permissions ;
: deploy.app-image ( vocab bundle-name -- str )
: create-app-dir ( vocab bundle-name -- vm )
dup "" copy-fonts
- "" copy-vm
+ copy-vm
dup OCT: 755 set-file-permissions ;
: bundle-name ( -- str )
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.files io.directories kernel namespaces sequences system
-tools.deploy.backend tools.deploy.config
-tools.deploy.config.editor assocs hashtables prettyprint
-combinators windows.shell32 windows.user32 ;
+USING: io io.files io.pathnames io.directories kernel namespaces
+sequences locals system splitting tools.deploy.backend
+tools.deploy.config tools.deploy.config.editor assocs hashtables
+prettyprint combinators windows.shell32 windows.user32 ;
IN: tools.deploy.windows
: copy-dll ( bundle-name -- )
"resource:zlib1.dll"
} swap copy-files-into ;
+:: copy-vm ( executable bundle-name extension -- vm )
+ vm "." split1-last drop extension append
+ bundle-name executable ".exe" append append-path
+ [ copy-file ] keep ;
+
: create-exe-dir ( vocab bundle-name -- vm )
dup copy-dll
deploy-ui? get [
- dup copy-freetype
- dup "" copy-fonts
- ] when
- ".exe" copy-vm ;
+ [ copy-freetype ]
+ [ "" copy-fonts ]
+ [ ".exe" copy-vm ] tri
+ ] [ ".com" copy-vm ] if ;
M: winnt deploy*
"resource:" [
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays io io.streams.string kernel math math.parser
-namespaces sequences splitting grouping strings ascii byte-arrays ;
+namespaces sequences splitting grouping strings ascii
+byte-arrays byte-vectors ;
IN: tools.hexdump
<PRIVATE
: write-hex-line ( bytes lineno -- )
write-offset [ >hex-digits write ] [ >ascii write ] bi nl ;
+: hexdump-bytes ( bytes -- )
+ [ length write-header ]
+ [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
+
PRIVATE>
GENERIC: hexdump. ( byte-array -- )
-M: byte-array hexdump.
- [ length write-header ]
- [ 16 <sliced-groups> [ write-hex-line ] each-index ] bi ;
+M: byte-array hexdump. hexdump-bytes ;
+
+M: byte-vector hexdump. hexdump-bytes ;
: hexdump ( byte-array -- str )
[ hexdump. ] with-string-writer ;
SYMBOL: cocoa-init-hook
-cocoa-init-hook global [
- [ "MiniFactor.nib" load-nib install-app-delegate ] or
-] change-at
+cocoa-init-hook [
+ [ "MiniFactor.nib" load-nib install-app-delegate ]
+] initialize
M: cocoa-ui-backend ui
"UI" assert.app [
: ui-error ( error -- )
ui-error-hook get [ call ] [ die ] if* ;
-ui-error-hook global [ [ rethrow ] or ] change-at
+ui-error-hook [ [ rethrow ] ] initialize
: draw-world ( world -- )
dup draw-world? [
{ $notes "This word is used by " { $link >url } ". It can also be used directly to parse " { $snippet "host:port" } " strings which are not full URLs." }
{ $examples
{ $example
- "USING: prettyprint urls ;"
- "\"sbcl.org:80\" parse-host .s"
+ "USING: prettyprint urls kernel ;"
+ "\"sbcl.org:80\" parse-host .s 2drop"
"\"sbcl.org\"\n80"
}
} ;
" " wrap-indented-string
] unit-test
-[ "this text\nhas lots\nof spaces" ]
+[ "this text\nhas lots of\nspaces" ]
[ "this text has lots of spaces" 12 wrap-string ] unit-test
[ "hello\nhow\nare\nyou\ntoday?" ]
[ "aaa bb\nccccccc\nddddddd" ] [ "aaa bb ccccccc ddddddd" 6 wrap-string ] unit-test
\ wrap-string must-infer
+
+[ "a b c d e f\ng h" ] [ "a b c d e f g h" 11 wrap-string ] unit-test
! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel splitting.monotonic accessors wrap grouping ;
+USING: sequences kernel splitting.monotonic accessors grouping wrap ;
IN: wrap.words
TUPLE: word key width break? ;
: element-length ( element -- n )
[ black>> ] [ white>> ] bi + ;
-: swons ( cdr car -- cons )
- swap cons ;
-
-: unswons ( cons -- cdr car )
- [ cdr ] [ car ] bi ;
-
-: 1list? ( list -- ? )
- { [ ] [ cdr +nil+ = ] } 1&& ;
-
-: lists>arrays ( lists -- arrays )
- [ list>seq ] lmap>array ;
-
TUPLE: paragraph lines head-width tail-cost ;
C: <paragraph> paragraph
] each drop ; inline
: paragraph-cost ( paragraph -- cost )
- [ head-width>> deviation ]
- [ tail-cost>> ] bi + ;
+ dup lines>> 1list? [ drop 0 ] [
+ [ head-width>> deviation ]
+ [ tail-cost>> ] bi +
+ ] if ;
: min-cost ( paragraphs -- paragraph )
[ paragraph-cost ] min-by ;
0 <paragraph> ;
: post-process ( paragraph -- array )
- lines>> lists>arrays
+ lines>> deep-list>array
[ [ contents>> ] map ] map ;
: initialize ( elements -- elements paragraph )
TAG: double xml>item children>number ;
TAG: boolean xml>item
- dup children>string {
- { [ dup "1" = ] [ 2drop t ] }
- { [ "0" = ] [ drop f ] }
+ children>string {
+ { "1" [ t ] }
+ { "0" [ f ] }
[ "Bad boolean" server-error ]
- } cond ;
+ } case ;
: unstruct-member ( tag -- )
children-tags first2
: [XML
"XML]" [ string>chunk ] parse-def ; parsing
+<PRIVATE
+
: remove-blanks ( seq -- newseq )
[ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ;
[undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ;
\ interpolate-xml 1 [ undo-xml ] define-pop-inverse
+
+PRIVATE>
IN: xml.tests
USING: kernel xml tools.test io namespaces make sequences
xml.errors xml.entities.html parser strings xml.data io.files
-xml.traversal continuations assocs
+xml.traversal continuations assocs io.encodings.binary
sequences.deep accessors io.streams.string ;
! This is insufficient
\ string>xml must-infer
SYMBOL: xml-file
-[ ] [ "resource:basis/xml/tests/test.xml"
- [ file>xml ] with-html-entities xml-file set ] unit-test
+[ ] [
+ "resource:basis/xml/tests/test.xml"
+ [ file>xml ] with-html-entities xml-file set
+] unit-test
+[ t ] [
+ "resource:basis/xml/tests/test.xml" binary file-contents
+ [ bytes>xml ] with-html-entities xml-file get =
+] unit-test
[ "1.0" ] [ xml-file get prolog>> version>> ] unit-test
[ f ] [ xml-file get prolog>> standalone>> ] unit-test
[ "a" ] [ xml-file get space>> ] unit-test
! Copyright (C) 2005, 2009 Daniel Ehrenberg\r
! See http://factorcode.org/license.txt for BSD license.\r
-USING: help.markup help.syntax xml.data io strings ;\r
+USING: help.markup help.syntax xml.data io strings byte-arrays ;\r
IN: xml\r
\r
HELP: string>xml\r
{ $values { "filename" string } { "xml" xml } }\r
{ $description "Opens the given file, reads it in as XML, closes the file and returns the corresponding XML tree. The encoding is automatically detected." } ;\r
\r
-{ string>xml read-xml file>xml } related-words\r
+HELP: bytes>xml\r
+{ $values { "byte-array" byte-array } { "xml" xml } }\r
+{ $description "Parses a byte array as an XML document. The encoding is automatically detected." } ;\r
+\r
+{ string>xml read-xml file>xml bytes>xml } related-words\r
\r
HELP: read-xml-chunk\r
{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }\r
{ $subsection read-xml-chunk }\r
{ $subsection string>xml-chunk }\r
{ $subsection file>xml }\r
+ { $subsection bytes>xml }\r
"To read a DTD:"\r
{ $subsection read-dtd }\r
{ $subsection file>dtd }\r
io.streams.string kernel namespaces sequences strings io.encodings.utf8
xml.data xml.errors xml.elements ascii xml.entities
xml.writer xml.state xml.autoencoding assocs xml.tokenize
-combinators.short-circuit xml.name splitting ;
+combinators.short-circuit xml.name splitting io.streams.byte-array ;
IN: xml
<PRIVATE
: file>xml ( filename -- xml )
binary <file-reader> read-xml ;
+: bytes>xml ( byte-array -- xml )
+ binary <byte-reader> read-xml ;
+
: read-dtd ( stream -- dtd )
[
H{ } clone extra-entities set
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax combinators system ;
-IN: zlib.ffi
-
-<< "zlib" {
- { [ os winnt? ] [ "zlib1.dll" ] }
- { [ os macosx? ] [ "libz.dylib" ] }
- { [ os unix? ] [ "libz.so" ] }
-} cond "cdecl" add-library >>
-
-LIBRARY: zlib
-
-CONSTANT: Z_OK 0
-CONSTANT: Z_STREAM_END 1
-CONSTANT: Z_NEED_DICT 2
-CONSTANT: Z_ERRNO -1
-CONSTANT: Z_STREAM_ERROR -2
-CONSTANT: Z_DATA_ERROR -3
-CONSTANT: Z_MEM_ERROR -4
-CONSTANT: Z_BUF_ERROR -5
-CONSTANT: Z_VERSION_ERROR -6
-
-TYPEDEF: void Bytef
-TYPEDEF: ulong uLongf
-TYPEDEF: ulong uLong
-
-FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
-FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ;
-FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel tools.test zlib classes ;
-IN: zlib.tests
-
-: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
-
-[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test
-[ t ] [ compress-me compress compressed instance? ] unit-test
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.syntax byte-arrays combinators
-kernel math math.functions sequences system accessors
-libc ;
-QUALIFIED: zlib.ffi
-IN: zlib
-
-TUPLE: compressed data length ;
-
-: <compressed> ( data length -- compressed )
- compressed new
- swap >>length
- swap >>data ;
-
-ERROR: zlib-failed n string ;
-
-: zlib-error-message ( n -- * )
- dup zlib.ffi:Z_ERRNO = [
- drop errno "native libc error"
- ] [
- dup {
- "no error" "libc_error"
- "stream error" "data error"
- "memory error" "buffer error" "zlib version error"
- } ?nth
- ] if zlib-failed ;
-
-: zlib-error ( n -- )
- dup zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
-
-: compressed-size ( byte-array -- n )
- length 1001/1000 * ceiling 12 + ;
-
-: compress ( byte-array -- compressed )
- [
- [ compressed-size <byte-array> dup length <ulong> ] keep [
- dup length zlib.ffi:compress zlib-error
- ] 3keep drop *ulong head
- ] keep length <compressed> ;
-
-: uncompress ( compressed -- byte-array )
- [
- length>> [ <byte-array> ] keep <ulong> 2dup
- ] [
- data>> dup length
- zlib.ffi:uncompress zlib-error
- ] bi *ulong head ;
SYMBOL: libraries
-libraries global [ H{ } assoc-like ] change-at
+libraries [ H{ } clone ] initialize
TUPLE: library path abi dll ;
}
"An example of using a changer:"
{ $code
- ": positions"
+ ": positions ( -- seq )"
" {"
" \"junior programmer\""
" \"senior programmer\""
[ t ] [ \ corner-case-1 optimized>> ] unit-test
[ 4 ] [ 2 corner-case-1 ] unit-test
-[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
\ No newline at end of file
+[ 4 ] [ 2 2 [ + ] curry 1array case ] unit-test
+
+: test-case-8 ( n -- )
+ {
+ { 1 [ "foo" ] }
+ } case ;
+
+[ 3 test-case-8 ]
+[ object>> 3 = ] must-fail-with
+
+[
+ 3 {
+ { 1 [ "foo" ] }
+ } case
+] [ object>> 3 = ] must-fail-with
reverse [ no-cond ] swap alist>quot ;
! case
-ERROR: no-case ;
+ERROR: no-case object ;
: case-find ( obj assoc -- obj' )
[
case-find {
{ [ dup array? ] [ nip second call ] }
{ [ dup callable? ] [ call ] }
- { [ dup not ] [ no-case ] }
+ { [ dup not ] [ drop no-case ] }
} cond ;
: linear-case-quot ( default assoc -- quot )
: default-recompile-hook ( words -- alist )
[ f ] { } map>assoc ;
-recompile-hook global
-[ [ default-recompile-hook ] or ]
-change-at
+recompile-hook [ [ default-recompile-hook ] ] initialize
SINGLETON: c-io-backend
-io-backend global [ c-io-backend or ] change-at
+io-backend [ c-io-backend ] initialize
HOOK: init-io io-backend ( -- )
"hi hi hi" }
"A fun loop:"
{ $example "USING: kernel prettyprint math ; "
- "3 [ dup . 7 + 11 mod dup 3 = not ] loop"
+ "3 [ dup . 7 + 11 mod dup 3 = not ] loop drop"
"3\n10\n6\n2\n9\n5\n1\n8\n4\n0\n7" }
} ;
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel.private slots.private math.private
classes.tuple.private ;
! Default
: ?if ( default cond true false -- )
- pick [ roll 2drop call ] [ 2nip call ] if ; inline
+ pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
! Slippers and dippers.
! Not declared inline because the compiler special-cases them
: 2tri@ ( u v w y x z quot -- )
dup dup 2tri* ; inline
-! Object protocol
-GENERIC: hashcode* ( depth obj -- code )
-
-M: object hashcode* 2drop 0 ;
-
-M: f hashcode* 2drop 31337 ;
-
-: hashcode ( obj -- code ) 3 swap hashcode* ; inline
-
-GENERIC: equal? ( obj1 obj2 -- ? )
-
-M: object equal? 2drop f ;
-
-TUPLE: identity-tuple ;
-
-M: identity-tuple equal? 2drop f ;
-
-: = ( obj1 obj2 -- ? )
- 2dup eq? [ 2drop t ] [
- 2dup both-fixnums? [ 2drop f ] [ equal? ] if
- ] if ; inline
-
-GENERIC: clone ( obj -- cloned )
-
-M: object clone ;
-
-M: callstack clone (clone) ;
-
-! Tuple construction
-GENERIC: new ( class -- tuple )
-
-GENERIC: boa ( ... class -- tuple )
-
! Quotation building
: 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline
: prepose ( quot1 quot2 -- compose )
swap compose ; inline
+! Curried cleavers
+<PRIVATE
+
+: [curry] ( quot -- quot' ) [ curry ] curry ; inline
+
+PRIVATE>
+
+: bi-curry ( x p q -- p' q' ) [ [curry] ] bi@ bi ; inline
+
+: tri-curry ( x p q r -- p' q' r' ) [ [curry] ] tri@ tri ; inline
+
+: bi-curry* ( x y p q -- p' q' ) [ [curry] ] bi@ bi* ; inline
+
+: tri-curry* ( x y z p q r -- p' q' r' ) [ [curry] ] tri@ tri* ; inline
+
+: bi-curry@ ( x y q -- p' q' ) [curry] bi@ ; inline
+
+: tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline
+
! Booleans
: not ( obj -- ? ) [ f ] [ t ] if ; inline
! Loops
: loop ( pred: ( -- ? ) -- )
- dup slip swap [ loop ] [ drop ] if ; inline recursive
+ [ call ] keep [ loop ] curry when ; inline recursive
: do ( pred body tail -- pred body tail )
over 3dip ; inline
: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
[ [ not ] compose ] 2dip while ; inline
+! Object protocol
+GENERIC: hashcode* ( depth obj -- code )
+
+M: object hashcode* 2drop 0 ;
+
+M: f hashcode* 2drop 31337 ;
+
+: hashcode ( obj -- code ) 3 swap hashcode* ; inline
+
+GENERIC: equal? ( obj1 obj2 -- ? )
+
+M: object equal? 2drop f ;
+
+TUPLE: identity-tuple ;
+
+M: identity-tuple equal? 2drop f ;
+
+: = ( obj1 obj2 -- ? )
+ 2dup eq? [ 2drop t ] [
+ 2dup both-fixnums? [ 2drop f ] [ equal? ] if
+ ] if ; inline
+
+GENERIC: clone ( obj -- cloned )
+
+M: object clone ;
+
+M: callstack clone (clone) ;
+
+! Tuple construction
+GENERIC: new ( class -- tuple )
+
+GENERIC: boa ( ... class -- tuple )
+
! Error handling -- defined early so that other files can
! throw errors before continuations are loaded
: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;
{ $description "Tests if " { $snippet "x" } " is an IEEE Infinity value. While " { $snippet "x" } " can be any real number, this word will only ever yield true if " { $snippet "x" } " is a " { $link float } "." }
{ $examples
{ $example "USING: math prettyprint ;" "1/0. fp-infinity? ." "t" }
- { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi [ \"negative infinity\" print ] when" "negative infinity" }
+ { $example "USING: io kernel math ;" "-1/0. [ fp-infinity? ] [ 0 < ] bi and [ \"negative infinity\" print ] when" "negative infinity" }
} ;
{ fp-nan? fp-infinity? } related-words
USING: help.markup help.syntax kernel kernel.private
sequences words namespaces.private quotations vectors
-math.parser math ;
+math.parser math words.symbol ;
IN: namespaces
ARTICLE: "namespaces-combinators" "Namespace combinators"
{ $subsection namespace }
{ $subsection global }
{ $subsection get-global }
-{ $subsection set-global } ;
+{ $subsection set-global }
+{ $subsection initialize } ;
ARTICLE: "namespaces.private" "Namespace implementation details"
"The namestack holds namespaces."
HELP: init-namespaces
{ $description "Resets the name stack to its initial state, holding a single copy of the global namespace." }
$low-level-note ;
+
+HELP: initialize
+{ $values { "variable" symbol } { "quot" quotation } }
+{ $description "If " { $snippet "variable" } " does not have a value in the global namespace, calls " { $snippet "quot" } " and assigns the result to " { $snippet "variable" } " in the global namespace." } ;
[ f ]
[ H{ } clone [ f "some-global" set "some-global" get ] bind ]
unit-test
+
+SYMBOL: test-initialize
+test-initialize [ 1 ] initialize
+test-initialize [ 2 ] initialize
+
+[ 1 ] [ test-initialize get-global ] unit-test
+
+f test-initialize set-global
+test-initialize [ 5 ] initialize
+
+[ 5 ] [ test-initialize get-global ] unit-test
H{ } clone >n call ndrop ; inline
: with-variable ( value key quot -- )
- [ associate >n ] dip call ndrop ; inline
+ [ associate >n ] dip call ndrop ; inline
+
+: initialize ( variable quot -- )
+ [ global ] [ [ unless* ] curry ] bi* change-at ;
SYMBOL: print-use-hook
-print-use-hook global [ [ ] or ] change-at
+print-use-hook [ [ ] ] initialize
: parse-fresh ( lines -- quot )
[
$nl
"Concretely, a quotation is an immutable sequence of objects, some of which may be words, together with a block of machine code which may be executed to achieve the effect of evaluating the quotation. The machine code is generated by a fast non-optimizing quotation compiler which is always running and is transparent to the developer."
$nl
+"Quotations form a class of objects, however in most cases, methods should dispatch on " { $link callable } " instead, so that " { $link curry } " and " { $link compose } " values can participate."
+{ $subsection quotation }
+{ $subsection quotation? }
"Quotations evaluate sequentially from beginning to end. Literals are pushed on the stack and words are executed. Details can be found in " { $link "evaluator" } "."
$nl
"Quotation literal syntax is documented in " { $link "syntax-quots" } "."
{ [ array bootstrap-word over class<= ] [ { } ] }
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
{ [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
+ { [ quotation bootstrap-word over class<= ] [ [ ] ] }
[ dup initial-value* ]
} cond nip ;
SYMBOL: name>char-hook
-name>char-hook global [
- [ "Unicode support not available" throw ] or
-] change-at
+name>char-hook [
+ [ "Unicode support not available" throw ]
+] initialize
: unicode-escape ( str -- ch str' )
"{" ?head-slice [
SYMBOL: compiled-crossref
-compiled-crossref global [ H{ } assoc-like ] change-at
+compiled-crossref [ H{ } clone ] initialize
SYMBOL: compiled-generic-crossref
-compiled-generic-crossref global [ H{ } assoc-like ] change-at
+compiled-generic-crossref [ H{ } clone ] initialize
: (compiled-xref) ( word dependencies word-prop variable -- )
[ [ set-word-prop ] curry ]
--- /dev/null
+USING: accessors arrays combinators definitions generalizations
+help help.markup help.topics kernel sequences sorting vocabs
+words ;
+IN: annotations
+
+<PRIVATE
+: comment-word ( base -- word ) "!" prepend "annotations" lookup ;
+: comment-usage-word ( base -- word ) "s" append "annotations" lookup ;
+: comment-usage.-word ( base -- word ) "s." append "annotations" lookup ;
+PRIVATE>
+
+"Code annotations"
+{
+ "The " { $vocab-link "annotations" } " vocabulary provides syntax for comment-like annotations that can be looked up with Factor's " { $link usage } " mechanism."
+}
+annotation-tags natural-sort
+[
+ [ \ $subsection swap comment-word 2array ] map append
+ "To look up annotations:" suffix
+] [
+ [ \ $subsection swap comment-usage.-word 2array ] map append
+] bi
+<article> "annotations" add-article
+
+"annotations" vocab "annotations" >>help drop
+
+annotation-tags [
+ {
+ [ [ \ $syntax ] dip "!" " your comment here" surround 2array ]
+ [ [ \ $description "Treats the rest of the line after the exclamation point as a code annotation that can be looked up with the " \ $link ] dip comment-usage.-word 2array " word." 4array ]
+ [ [ \ $unchecked-example ] dip ": foo ( x y z -- w )\n !" " --w-ó()ò-w-- kilroy was here\n + * ;" surround 2array 3array ]
+ [ comment-word set-word-help ]
+
+ [ [ \ $description "Displays a list of words, help articles, and vocabularies that contain " \ $link ] dip comment-word 2array " annotations." 4array 1array ]
+ [ comment-usage.-word set-word-help ]
+
+ [ [ { $values { "usages" sequence } } \ $description "Returns a list of words, help articles, and vocabularies that contain " \ $link ] dip [ comment-word 2array " annotations. For a more user-friendly display, use the " \ $link ] [ comment-usage.-word 2array " word." 6 narray 2array ] bi ]
+ [ comment-usage-word set-word-help ]
+
+ [ [ comment-word ] [ comment-usage-word ] [ comment-usage.-word ] tri 3array related-words ]
+ } cleave
+] each
--- /dev/null
+USING: accessors annotations combinators.short-circuit
+io.pathnames kernel math sequences sorting tools.test ;
+IN: annotations.tests
+
+!NOTE testing toplevel form
+
+: three ( -- x )
+ !BROKEN english plz
+ "þrij" ;
+
+: four ( -- x )
+ !BROKEN this code is broken
+ 2 2 + 1+ ;
+
+: five ( -- x )
+ !TODO return 5
+ f ;
+
+[ t ] [
+ NOTEs {
+ [ length 1 = ]
+ [ first string>> file-name "annotations-tests.factor" = ]
+ } 1&&
+] unit-test
+
+[ { four three } ] [ BROKENs natural-sort ] unit-test
+[ { five } ] [ TODOs ] unit-test
--- /dev/null
+! (c)2009 Joe Groff, Doug Coleman. see BSD license
+USING: accessors combinators.short-circuit definitions functors
+kernel lexer namespaces parser prettyprint sequences words ;
+IN: annotations
+
+<<
+
+: (parse-annotation) ( accum -- accum )
+ lexer get [ line-text>> parsed ] [ next-line ] bi ;
+
+: (non-annotation-usage) ( word -- usages )
+ smart-usage
+ [ { [ word? ] [ vocabulary>> "annotations" = ] } 1&& not ]
+ filter ;
+
+FUNCTOR: define-annotation ( NAME -- )
+
+(NAME) DEFINES (${NAME})
+!NAME DEFINES !${NAME}
+NAMEs DEFINES ${NAME}s
+NAMEs. DEFINES ${NAME}s.
+
+WHERE
+
+: (NAME) ( str -- ) drop ; inline
+: !NAME (parse-annotation) \ (NAME) parsed ; parsing
+
+: NAMEs ( -- usages )
+ \ (NAME) (non-annotation-usage) ;
+: NAMEs. ( -- )
+ NAMEs sorted-definitions. ;
+
+;FUNCTOR
+
+CONSTANT: annotation-tags {
+ "XXX" "TODO" "FIXME" "BUG" "REVIEW" "LICENSE"
+ "AUTHOR" "BROKEN" "HACK" "LOL" "NOTE"
+}
+
+annotation-tags [ define-annotation ] each
+
+>>
+
--- /dev/null
+Joe Groff
+Doug Coleman
--- /dev/null
+Code annotation comment syntax
--- /dev/null
+comments
+annotation
! Copyright (C) 2008 Doug Coleman, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays kernel math namespaces
-opengl.gl sequences math.vectors ui graphics.bitmap graphics.viewer
+opengl.gl sequences math.vectors ui images.bitmap images.viewer
models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
IN: cap
[ screenshot ] dip save-bitmap ;
: screenshot. ( window -- )
- [ screenshot <graphics-gadget> ] [ title>> ] bi open-window ;
+ [ screenshot <image-gadget> ] [ title>> ] bi open-window ;
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test constructors calendar kernel accessors
-combinators.short-circuit ;
-IN: constructors.tests
-
-TUPLE: stock-spread stock spread timestamp ;
-
-CONSTRUCTOR: stock-spread ( stock spread -- stock-spread )
- now >>timestamp ;
-
-SYMBOL: AAPL
-
-[ t ] [
- AAPL 1234 <stock-spread>
- {
- [ stock>> AAPL eq? ]
- [ spread>> 1234 = ]
- [ timestamp>> timestamp? ]
- } 1&&
-] unit-test
\ No newline at end of file
+++ /dev/null
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: slots kernel sequences fry accessors parser lexer words
-effects.parser macros ;
-IN: constructors
-
-! An experiment
-
-MACRO: set-slots ( slots -- quot )
- <reversed> [ setter-word '[ swap _ execute ] ] map [ ] join ;
-
-: construct ( ... class slots -- instance )
- [ new ] dip set-slots ; inline
-
-: define-constructor ( name class effect body -- )
- [ [ in>> '[ _ _ construct ] ] dip compose ] [ drop ] 2bi
- define-declared ;
-
-: CONSTRUCTOR:
- scan-word [ name>> "<" ">" surround create-in ] keep
- "(" expect ")" parse-effect
- parse-definition
- define-constructor ; parsing
\ No newline at end of file
+++ /dev/null
-Doug Coleman
+++ /dev/null
-Doug Coleman
+++ /dev/null
-USING: graphics.bitmap graphics.viewer io.encodings.binary
-io.files io.files.unique kernel tools.test ;
-IN: graphics.bitmap.tests
-
-: test-bitmap32-alpha ( -- path )
- "resource:extra/graphics/bitmap/test-images/32alpha.bmp" ;
-
-: test-bitmap24 ( -- path )
- "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" ;
-
-: test-bitmap16 ( -- path )
- "resource:extra/graphics/bitmap/test-images/rgb16bit.bmp" ;
-
-: test-bitmap8 ( -- path )
- "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" ;
-
-: test-bitmap4 ( -- path )
- "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" ;
-
-: test-bitmap1 ( -- path )
- "resource:extra/graphics/bitmap/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
+++ /dev/null
-! Copyright (C) 2007, 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors alien alien.c-types arrays byte-arrays columns
-combinators fry grouping io io.binary io.encodings.binary
-io.files kernel libc macros math math.bitwise math.functions
-namespaces opengl opengl.gl prettyprint sequences strings
-summary ui ui.gadgets.panes ;
-IN: graphics.bitmap
-
-! Currently can only handle 24/32bit bitmaps.
-! Handles row-reversed bitmaps (their height is negative)
-
-TUPLE: bitmap magic size reserved offset header-length width
-height planes bit-count compression size-image
-x-pels y-pels color-used color-important rgb-quads color-index
-alpha-channel-zero?
-array ;
-
-: array-copy ( bitmap array -- bitmap array' )
- over size-image>> abs memory>byte-array ;
-
-MACRO: (nbits>bitmap) ( bits -- )
- [ -3 shift ] keep '[
- bitmap new
- 2over * _ * >>size-image
- swap >>height
- swap >>width
- swap array-copy [ >>array ] [ >>color-index ] bi
- _ >>bit-count
- ] ;
-
-: bgr>bitmap ( array height width -- bitmap )
- 24 (nbits>bitmap) ;
-
-: bgra>bitmap ( array height width -- bitmap )
- 32 (nbits>bitmap) ;
-
-: 8bit>array ( bitmap -- array )
- [ rgb-quads>> 4 <sliced-groups> [ 3 head-slice ] map ]
- [ color-index>> >array ] bi [ swap nth ] with map concat ;
-
-ERROR: bmp-not-supported n ;
-
-: raw-bitmap>array ( bitmap -- array )
- dup bit-count>>
- {
- { 32 [ color-index>> ] }
- { 24 [ color-index>> ] }
- { 16 [ bmp-not-supported ] }
- { 8 [ 8bit>array ] }
- { 4 [ bmp-not-supported ] }
- { 2 [ bmp-not-supported ] }
- { 1 [ bmp-not-supported ] }
- } case >byte-array ;
-
-ERROR: bitmap-magic ;
-
-M: bitmap-magic summary
- drop "First two bytes of bitmap stream must be 'BM'" ;
-
-: read2 ( -- n ) 2 read le> ;
-: read4 ( -- n ) 4 read le> ;
-
-: parse-file-header ( bitmap -- bitmap )
- 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic
- read4 >>size
- read4 >>reserved
- read4 >>offset ;
-
-: parse-bitmap-header ( bitmap -- bitmap )
- read4 >>header-length
- read4 >>width
- read4 >>height
- read2 >>planes
- read2 >>bit-count
- read4 >>compression
- read4 >>size-image
- read4 >>x-pels
- read4 >>y-pels
- read4 >>color-used
- read4 >>color-important ;
-
-: rgb-quads-length ( bitmap -- n )
- [ offset>> 14 - ] [ header-length>> ] bi - ;
-
-: color-index-length ( bitmap -- n )
- {
- [ width>> ]
- [ planes>> * ]
- [ bit-count>> * 31 + 32 /i 4 * ]
- [ height>> abs * ]
- } cleave ;
-
-: parse-bitmap ( bitmap -- bitmap )
- dup rgb-quads-length read >>rgb-quads
- dup color-index-length read >>color-index ;
-
-: (load-bitmap) ( path -- bitmap )
- binary [
- bitmap new
- parse-file-header parse-bitmap-header parse-bitmap
- ] with-file-reader ;
-
-: alpha-channel-zero? ( bitmap -- ? )
- array>> 4 <sliced-groups> 3 <column> [ 0 = ] all? ;
-
-: load-bitmap ( path -- bitmap )
- (load-bitmap)
- dup raw-bitmap>array >>array
- dup alpha-channel-zero? >>alpha-channel-zero? ;
-
-: write2 ( n -- ) 2 >le write ;
-: write4 ( n -- ) 4 >le write ;
-
-: save-bitmap ( bitmap path -- )
- binary [
- B{ CHAR: B CHAR: M } write
- [
- array>> length 14 + 40 + write4
- 0 write4
- 54 write4
- 40 write4
- ] [
- {
- [ width>> write4 ]
- [ height>> write4 ]
- [ planes>> 1 or write2 ]
- [ bit-count>> 24 or write2 ]
- [ compression>> 0 or write4 ]
- [ size-image>> write4 ]
- [ x-pels>> 0 or write4 ]
- [ y-pels>> 0 or write4 ]
- [ color-used>> 0 or write4 ]
- [ color-important>> 0 or write4 ]
- [ rgb-quads>> write ]
- [ color-index>> write ]
- } cleave
- ] bi
- ] with-file-writer ;
+++ /dev/null
-bitmap graphics
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2009 Your name.
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test graphics.tiff ;
-IN: graphics.tiff.tests
-
-: tiff-test-path ( -- path )
- "resource:extra/graphics/tiff/rgb.tiff" ;
-
-
+++ /dev/null
-! Copyright (C) 2009 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io io.encodings.binary io.files
-kernel pack endian tools.hexdump constructors sequences arrays
-sorting.slots math.order math.parser prettyprint classes ;
-IN: graphics.tiff
-
-TUPLE: tiff
-endianness
-the-answer
-ifd-offset
-ifds ;
-
-CONSTRUCTOR: tiff ( -- tiff )
- V{ } clone >>ifds ;
-
-TUPLE: ifd count ifd-entries next processed-tags strips ;
-
-CONSTRUCTOR: ifd ( count ifd-entries next -- ifd ) ;
-
-TUPLE: ifd-entry tag type count offset ;
-
-CONSTRUCTOR: ifd-entry ( tag type count offset -- ifd-entry ) ;
-
-
-TUPLE: photometric-interpretation color ;
-
-CONSTRUCTOR: photometric-interpretation ( color -- object ) ;
-
-SINGLETONS: white-is-zero black-is-zero rgb palette-color ;
-
-ERROR: bad-photometric-interpretation n ;
-
-: lookup-photometric-interpretation ( n -- singleton )
- {
- { 0 [ white-is-zero ] }
- { 1 [ black-is-zero ] }
- { 2 [ rgb ] }
- { 3 [ palette-color ] }
- [ bad-photometric-interpretation ]
- } case <photometric-interpretation> ;
-
-
-TUPLE: compression method ;
-
-CONSTRUCTOR: compression ( method -- object ) ;
-
-SINGLETONS: no-compression CCITT-2 pack-bits lzw ;
-
-ERROR: bad-compression n ;
-
-: lookup-compression ( n -- compression )
- {
- { 1 [ no-compression ] }
- { 2 [ CCITT-2 ] }
- { 5 [ lzw ] }
- { 32773 [ pack-bits ] }
- [ bad-compression ]
- } case <compression> ;
-
-TUPLE: image-length n ;
-CONSTRUCTOR: image-length ( n -- object ) ;
-
-TUPLE: image-width n ;
-CONSTRUCTOR: image-width ( n -- object ) ;
-
-TUPLE: x-resolution n ;
-CONSTRUCTOR: x-resolution ( n -- object ) ;
-
-TUPLE: y-resolution n ;
-CONSTRUCTOR: y-resolution ( n -- object ) ;
-
-TUPLE: rows-per-strip n ;
-CONSTRUCTOR: rows-per-strip ( n -- object ) ;
-
-TUPLE: strip-offsets n ;
-CONSTRUCTOR: strip-offsets ( n -- object ) ;
-
-TUPLE: strip-byte-counts n ;
-CONSTRUCTOR: strip-byte-counts ( n -- object ) ;
-
-TUPLE: bits-per-sample n ;
-CONSTRUCTOR: bits-per-sample ( n -- object ) ;
-
-TUPLE: samples-per-pixel n ;
-CONSTRUCTOR: samples-per-pixel ( n -- object ) ;
-
-SINGLETONS: no-resolution-unit
-inch-resolution-unit
-centimeter-resolution-unit ;
-
-TUPLE: resolution-unit type ;
-CONSTRUCTOR: resolution-unit ( type -- object ) ;
-
-ERROR: bad-resolution-unit n ;
-
-: lookup-resolution-unit ( n -- object )
- {
- { 1 [ no-resolution-unit ] }
- { 2 [ inch-resolution-unit ] }
- { 3 [ centimeter-resolution-unit ] }
- [ bad-resolution-unit ]
- } case <resolution-unit> ;
-
-
-TUPLE: predictor type ;
-CONSTRUCTOR: predictor ( type -- object ) ;
-
-SINGLETONS: no-predictor horizontal-differencing-predictor ;
-
-ERROR: bad-predictor n ;
-
-: lookup-predictor ( n -- object )
- {
- { 1 [ no-predictor ] }
- { 2 [ horizontal-differencing-predictor ] }
- [ bad-predictor ]
- } case <predictor> ;
-
-
-TUPLE: planar-configuration type ;
-CONSTRUCTOR: planar-configuration ( type -- object ) ;
-
-SINGLETONS: chunky planar ;
-
-ERROR: bad-planar-configuration n ;
-
-: lookup-planar-configuration ( n -- object )
- {
- { 1 [ no-predictor ] }
- { 2 [ horizontal-differencing-predictor ] }
- [ bad-predictor ]
- } case <planar-configuration> ;
-
-
-TUPLE: new-subfile-type n ;
-CONSTRUCTOR: new-subfile-type ( n -- object ) ;
-
-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 ;
-
-: with-tiff-endianness ( tiff quot -- tiff )
- [ dup endianness>> ] dip with-endianness ; inline
-
-: 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
- ] with-tiff-endianness ;
-
-: read-strips ( ifd -- ifd )
- dup processed-tags>>
- [ [ strip-byte-counts instance? ] find nip n>> ]
- [ [ strip-offsets instance? ] find nip n>> ] bi
- [ seek-absolute seek-input read ] { } 2map-as >>strips ;
-
-! ERROR: unhandled-ifd-entry data n ;
-
-: unhandled-ifd-entry ;
-
-: ifd-entry-value ( ifd-entry -- n )
- dup count>> 1 = [
- offset>>
- ] [
- [ offset>> seek-absolute seek-input ] [ count>> read ] bi
- ] if ;
-
-: process-ifd-entry ( ifd-entry -- object )
- [ ifd-entry-value ] [ tag>> ] bi {
- { 254 [ <new-subfile-type> ] }
- { 256 [ <image-width> ] }
- { 257 [ <image-length> ] }
- { 258 [ <bits-per-sample> ] }
- { 259 [ lookup-compression ] }
- { 262 [ lookup-photometric-interpretation ] }
- { 273 [ <strip-offsets> ] }
- { 277 [ <samples-per-pixel> ] }
- { 278 [ <rows-per-strip> ] }
- { 279 [ <strip-byte-counts> ] }
- { 282 [ <x-resolution> ] }
- { 283 [ <y-resolution> ] }
- { 284 [ <planar-configuration> ] }
- { 296 [ lookup-resolution-unit ] }
- { 317 [ lookup-predictor ] }
- [ unhandled-ifd-entry swap 2array ]
- } case ;
-
-: process-ifd ( ifd -- ifd )
- dup ifd-entries>> [ process-ifd-entry ] map >>processed-tags ;
-
-: (load-tiff) ( path -- tiff )
- binary [
- <tiff>
- read-header
- read-ifds
- dup ifds>> [ process-ifd read-strips drop ] each
- ] with-file-reader ;
-
-: load-tiff ( path -- tiff )
- (load-tiff) ;
-
-! TODO: duplicate ifds = error, seeking out of bounds = error
+++ /dev/null
-Doug Coleman
+++ /dev/null
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays combinators graphics.bitmap kernel math
-math.functions namespaces opengl opengl.gl ui ui.gadgets
-ui.gadgets.panes ui.render ;
-IN: graphics.viewer
-
-TUPLE: graphics-gadget < gadget image ;
-
-GENERIC: draw-image ( image -- )
-GENERIC: width ( image -- w )
-GENERIC: height ( image -- h )
-
-M: graphics-gadget pref-dim*
- image>> [ width ] keep height abs 2array ;
-
-M: graphics-gadget draw-gadget* ( gadget -- )
- origin get [ image>> draw-image ] with-translation ;
-
-: <graphics-gadget> ( bitmap -- gadget )
- \ graphics-gadget new-gadget
- swap >>image ;
-
-M: bitmap draw-image ( bitmap -- )
- dup height>> 0 < [
- 0 0 glRasterPos2i
- 1.0 -1.0 glPixelZoom
- ] [
- 0 over height>> abs glRasterPos2i
- 1.0 1.0 glPixelZoom
- ] if
- [ width>> ] keep
- [
- [ height>> abs ] keep
- bit-count>> {
- { 32 [ GL_BGRA GL_UNSIGNED_BYTE ] }
- { 24 [ GL_BGR GL_UNSIGNED_BYTE ] }
- { 8 [ GL_BGR GL_UNSIGNED_BYTE ] }
- { 4 [ GL_BGR GL_UNSIGNED_BYTE ] }
- } case
- ] keep array>> glDrawPixels ;
-
-M: bitmap width ( bitmap -- ) width>> ;
-M: bitmap height ( bitmap -- ) height>> ;
-
-: bitmap. ( path -- )
- load-bitmap <graphics-gadget> gadget. ;
-
-: bitmap-window ( path -- gadget )
- load-bitmap <graphics-gadget> [ "bitmap" open-window ] keep ;
--- /dev/null
+Tim Wawrzynczak
+
--- /dev/null
+! Copyright (C) 2008 Tim Wawrzynczak
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax sequences kernel ;
+IN: id3
+
+HELP: file-id3-tags
+{ $values
+ { "path" "a path string" }
+ { "object/f" "a tuple storing ID3 metadata or f" } }
+{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present." } ;
+
+ARTICLE: "id3" "ID3 tags"
+"The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl
+"Parsing ID3 tags from an MP3 file:"
+{ $subsection file-id3-tags } ;
+
+ABOUT: "id3"
--- /dev/null
+! Copyright (C) 2009 Tim Wawrzynczak
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test id3 ;
+IN: id3.tests
+
+[ T{ mp3v2-file
+ { header T{ header f t 0 502 } }
+ { frames
+ {
+ T{ frame
+ { frame-id "COMM" }
+ { flags B{ 0 0 } }
+ { size 19 }
+ { data "eng, AG# 08E1C12E" }
+ }
+ T{ frame
+ { frame-id "TIT2" }
+ { flags B{ 0 0 } }
+ { size 15 }
+ { data "Stormy Weather" }
+ }
+ T{ frame
+ { frame-id "TRCK" }
+ { flags B{ 0 0 } }
+ { size 3 }
+ { data "32" }
+ }
+ T{ frame
+ { frame-id "TCON" }
+ { flags B{ 0 0 } }
+ { size 5 }
+ { data "(96)" }
+ }
+ T{ frame
+ { frame-id "TALB" }
+ { flags B{ 0 0 } }
+ { size 28 }
+ { data "Night and Day Frank Sinatra" }
+ }
+ T{ frame
+ { frame-id "PRIV" }
+ { flags B{ 0 0 } }
+ { size 39 }
+ { data "WM/MediaClassPrimaryID�}`�#��K�H�*(D" }
+ }
+ T{ frame
+ { frame-id "PRIV" }
+ { flags B{ 0 0 } }
+ { size 41 }
+ { data "WM/MediaClassSecondaryID" }
+ }
+ T{ frame
+ { frame-id "TPE1" }
+ { flags B{ 0 0 } }
+ { size 14 }
+ { data "Frank Sinatra" }
+ }
+ }
+ }
+}
+] [ "resource:extra/id3/tests/blah3.mp3" file-id3-tags ] unit-test
+
+[
+ T{ mp3v2-file
+ { header
+ T{ header { version t } { flags 0 } { size 1405 } }
+ }
+ { frames
+ {
+ T{ frame
+ { frame-id "TIT2" }
+ { flags B{ 0 0 } }
+ { size 22 }
+ { data "Anthem of the Trinity" }
+ }
+ T{ frame
+ { frame-id "TPE1" }
+ { flags B{ 0 0 } }
+ { size 12 }
+ { data "Terry Riley" }
+ }
+ T{ frame
+ { frame-id "TALB" }
+ { flags B{ 0 0 } }
+ { size 11 }
+ { data "Shri Camel" }
+ }
+ T{ frame
+ { frame-id "TCON" }
+ { flags B{ 0 0 } }
+ { size 10 }
+ { data "Classical" }
+ }
+ T{ frame
+ { frame-id "UFID" }
+ { flags B{ 0 0 } }
+ { size 23 }
+ { data "http://musicbrainz.org" }
+ }
+ T{ frame
+ { frame-id "TXXX" }
+ { flags B{ 0 0 } }
+ { size 23 }
+ { data "MusicBrainz Artist Id" }
+ }
+ T{ frame
+ { frame-id "TXXX" }
+ { flags B{ 0 0 } }
+ { size 22 }
+ { data "musicbrainz_artistid" }
+ }
+ T{ frame
+ { frame-id "TRCK" }
+ { flags B{ 0 0 } }
+ { size 2 }
+ { data "1" }
+ }
+ T{ frame
+ { frame-id "TXXX" }
+ { flags B{ 0 0 } }
+ { size 22 }
+ { data "MusicBrainz Album Id" }
+ }
+ T{ frame
+ { frame-id "TXXX" }
+ { flags B{ 0 0 } }
+ { size 21 }
+ { data "musicbrainz_albumid" }
+ }
+ T{ frame
+ { frame-id "TXXX" }
+ { flags B{ 0 0 } }
+ { size 29 }
+ { data "MusicBrainz Album Artist Id" }
+ }
+ T{ frame
+ { frame-id "TXXX" }
+ { flags B{ 0 0 } }
+ { size 27 }
+ { data "musicbrainz_albumartistid" }
+ }
+ T{ frame
+ { frame-id "TPOS" }
+ { flags B{ 0 0 } }
+ { size 2 }
+ { data "1" }
+ }
+ T{ frame
+ { frame-id "TSOP" }
+ { flags B{ 0 0 } }
+ { size 1 }
+ }
+ T{ frame
+ { frame-id "TMED" }
+ { flags B{ 0 0 } }
+ { size 4 }
+ { data "DIG" }
+ }
+ }
+ }
+}
+] [ "resource:extra/id3/tests/blah2.mp3" file-id3-tags ] unit-test
+
+[
+ T{ mp3v1-file
+ { title
+ "BLAH\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
+ }
+ { artist
+ "ARTIST\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
+ }
+ { album
+ "ALBUM\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
+ }
+ { year "2009" }
+ { comment
+ "COMMENT\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0\0"
+ }
+ { genre 89 }
+ }
+] [ "resource:extra/id3/tests/blah.mp3" file-id3-tags ] unit-test
+
--- /dev/null
+! Copyright (C) 2009 Tim Wawrzynczak
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences io io.encodings.binary io.files io.pathnames strings kernel math io.mmap io.mmap.uchar accessors syntax combinators math.ranges unicode.categories byte-arrays prettyprint io.encodings.string io.encodings.ascii ;
+IN: id3
+
+! tuples
+
+TUPLE: header version flags size ;
+
+TUPLE: frame frame-id flags size data ;
+
+TUPLE: mp3v2-file header frames ;
+
+TUPLE: mp3v1-file title artist album year comment genre ;
+
+: <mp3v1-file> ( -- object ) mp3v1-file new ;
+
+: <mp3v2-file> ( header frames -- object ) mp3v2-file boa ;
+
+: <header> ( -- object ) header new ;
+
+: <frame> ( -- object ) frame new ;
+
+<PRIVATE
+
+! utility words
+
+: id3v2? ( mmap -- ? )
+ "ID3" head? ;
+
+: id3v1? ( mmap -- ? )
+ 128 tail-slice* "TAG" head? ;
+
+: >28bitword ( seq -- int )
+ 0 [ swap 7 shift bitor ] reduce ;
+
+: filter-text-data ( data -- filtered )
+ [ printable? ] filter ;
+
+! frame details stuff
+
+: valid-frame-id? ( id -- ? )
+ [ [ digit? ] [ LETTER? ] bi or ] all? ;
+
+: read-frame-id ( mmap -- id )
+ 4 head-slice ;
+
+: read-frame-size ( mmap -- size )
+ [ 4 8 ] dip subseq ;
+
+: read-frame-flags ( mmap -- flags )
+ [ 8 10 ] dip subseq ;
+
+: read-frame-data ( frame mmap -- frame data )
+ [ 10 over size>> 10 + ] dip <slice> filter-text-data ;
+
+! read whole frames
+
+: (read-frame) ( mmap -- frame )
+ [ <frame> ] dip
+ {
+ [ read-frame-id ascii decode >>frame-id ]
+ [ read-frame-flags >byte-array >>flags ]
+ [ read-frame-size >28bitword >>size ]
+ [ read-frame-data ascii decode >>data ]
+ } cleave ;
+
+: read-frame ( mmap -- frame/f )
+ dup read-frame-id valid-frame-id? [ (read-frame) ] [ drop f ] if ;
+
+: remove-frame ( mmap frame -- mmap )
+ size>> 10 + tail-slice ;
+
+: read-frames ( mmap -- frames )
+ [ dup read-frame dup ]
+ [ [ remove-frame ] keep ]
+ [ drop ] produce nip ;
+
+! header stuff
+
+: read-header-supported-version? ( mmap -- ? )
+ 3 tail-slice [ { 4 } head? ] [ { 3 } head? ] bi or ;
+
+: read-header-flags ( mmap -- flags )
+ 5 swap nth ;
+
+: read-header-size ( mmap -- size )
+ [ 6 10 ] dip <slice> >28bitword ;
+
+: read-v2-header ( mmap -- id3header )
+ [ <header> ] dip
+ {
+ [ read-header-supported-version? >>version ]
+ [ read-header-flags >>flags ]
+ [ read-header-size >>size ]
+ } cleave ;
+
+: drop-header ( mmap -- seq1 seq2 )
+ dup 10 tail-slice swap ;
+
+: read-v2-tag-data ( seq -- mp3v2-file )
+ drop-header read-v2-header swap read-frames <mp3v2-file> ;
+
+! v1 information
+
+: skip-to-v1-data ( seq -- seq )
+ 125 tail-slice* ;
+
+: read-title ( seq -- title )
+ 30 head-slice ;
+
+: read-artist ( seq -- title )
+ [ 30 60 ] dip subseq ;
+
+: read-album ( seq -- album )
+ [ 60 90 ] dip subseq ;
+
+: read-year ( seq -- year )
+ [ 90 94 ] dip subseq ;
+
+: read-comment ( seq -- comment )
+ [ 94 124 ] dip subseq ;
+
+: read-genre ( seq -- genre )
+ [ 124 ] dip nth ;
+
+: (read-v1-tag-data) ( seq -- mp3-file )
+ [ <mp3v1-file> ] dip
+ {
+ [ read-title ascii decode >>title ]
+ [ read-artist ascii decode >>artist ]
+ [ read-album ascii decode >>album ]
+ [ read-year ascii decode >>year ]
+ [ read-comment ascii decode >>comment ]
+ [ read-genre >fixnum >>genre ]
+ } cleave ;
+
+: read-v1-tag-data ( seq -- mp3-file )
+ skip-to-v1-data (read-v1-tag-data) ;
+
+PRIVATE>
+
+! main stuff
+
+: file-id3-tags ( path -- object/f )
+ [
+ {
+ { [ dup id3v2? ] [ read-v2-tag-data ] } ! ( ? -- mp3v2-file )
+ { [ dup id3v1? ] [ read-v1-tag-data ] } ! ( ? -- mp3v1-file )
+ [ drop f ] ! ( mmap -- f )
+ } cond
+ ] with-mapped-uchar-file ;
+
+! end
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors images images.loader io.pathnames kernel
+namespaces opengl opengl.gl sequences strings ui ui.gadgets
+ui.gadgets.panes ui.render ;
+IN: images.viewer
+
+TUPLE: image-gadget < gadget { image image } ;
+
+M: image-gadget pref-dim*
+ image>> dim>> ;
+
+: draw-image ( tiff -- )
+ 0 0 glRasterPos2i 1.0 -1.0 glPixelZoom
+ [ dim>> first2 GL_RGBA GL_UNSIGNED_BYTE ]
+ [ bitmap>> ] bi glDrawPixels ;
+
+M: image-gadget draw-gadget* ( gadget -- )
+ origin get [ image>> draw-image ] with-translation ;
+
+: <image-gadget> ( image -- gadget )
+ \ image-gadget new-gadget
+ swap >>image ;
+
+: image-window ( path -- gadget )
+ [ load-image <image-gadget> dup ] [ open-window ] bi ;
+
+GENERIC: image. ( object -- )
+
+: default-image. ( path -- )
+ <image-gadget> gadget. ;
+
+M: string image. ( image -- ) load-image default-image. ;
+
+M: pathname image. ( image -- ) load-image default-image. ;
+
+M: image image. ( image -- ) default-image. ;
+! Copyright (C) 2009 Philipp Brüschweiler
+! See http://factorcode.org/license.txt for BSD license.
IN: infix.ast
TUPLE: ast-number value ;
--- /dev/null
+Philipp Brüschweiler
-USING: help.syntax help.markup prettyprint locals ;
+! Copyright (C) 2009 Philipp Brüschweiler
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup math prettyprint locals sequences ;
IN: infix
HELP: [infix
} ;
{ POSTPONE: [infix POSTPONE: [infix| } related-words
+
+ARTICLE: "infix" "Infix notation"
+"The " { $vocab-link "infix" } " vocabulary implements support for infix notation in Factor source code."
+{ $subsection POSTPONE: [infix }
+{ $subsection POSTPONE: [infix| }
+$nl
+"The usual infix math operators are supported:"
+{ $list
+ { $link + }
+ { $link - }
+ { $link * }
+ { $link / }
+ { { $snippet "%" } ", which is the infix operator for " { $link mod } "." }
+}
+"The standard precedence rules apply: Grouping with parentheses before " { $snippet "*" } ", " { $snippet "/" } "and " { $snippet "%" } " before " { $snippet "+" } " and " { $snippet "-" } "."
+{ $example
+ "USING: infix prettyprint ;"
+ "[infix 5-40/10*2 infix] ."
+ "-3"
+}
+$nl
+"You can call Factor words in infix expressions just as you would in C. There are some restrictions on which words are legal to use though:"
+{ $list
+ "The word must return exactly one value."
+ "The word name must consist of the letters a-z, A-Z, _ or 0-9, and the first character can't be a number."
+}
+{ $example
+ "USING: infix locals math math.functions prettyprint ;"
+ ":: binary_entropy ( p -- h )"
+ " [infix -(p*log(p) + (1-p)*log(1-p)) / log(2) infix] ;"
+ "[infix binary_entropy( sqrt(0.25) ) infix] ."
+ "1.0"
+}
+$nl
+"You can access " { $vocab-link "sequences" } " inside infix expressions with the familiar " { $snippet "arr[index]" } " notation."
+{ $example
+ "USING: arrays infix prettyprint ;"
+ "[infix| myarr [ { 1 2 3 4 } ] | myarr[4/2]*3 infix] ."
+ "9"
+}
+"Please note: in Factor " { $emphasis "fixnums are sequences too." } " If you are not careful with sequence accesses you may introduce subtle bugs:"
+{ $example
+ "USING: arrays infix locals prettyprint ;"
+ ":: add-2nd-element ( x y -- res )"
+ " [infix x[1] + y[1] infix] ;"
+ "{ 1 2 3 } 5 add-2nd-element ."
+ "3"
+}
+;
+
+ABOUT: "infix"
+! Copyright (C) 2009 Philipp Brüschweiler
+! See http://factorcode.org/license.txt for BSD license.
USING: infix infix.private kernel locals math math.functions
tools.test ;
IN: infix.tests
+! Copyright (C) 2009 Philipp Brüschweiler
+! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs combinators combinators.short-circuit
effects fry infix.parser infix.ast kernel locals.parser
locals.types math multiline namespaces parser quotations
+! Copyright (C) 2009 Philipp Brüschweiler
+! See http://factorcode.org/license.txt for BSD license.
USING: infix.ast infix.parser infix.tokenizer tools.test ;
IN: infix.parser.tests
+! Copyright (C) 2009 Philipp Brüschweiler
+! See http://factorcode.org/license.txt for BSD license.
USING: infix.ast infix.tokenizer kernel math peg.ebnf sequences
strings vectors ;
IN: infix.parser
--- /dev/null
+Support for infix notation in Factor programs
--- /dev/null
+extensions
+! Copyright (C) 2009 Philipp Brüschweiler
+! See http://factorcode.org/license.txt for BSD license.
USING: infix.ast infix.tokenizer tools.test ;
IN: infix.tokenizer.tests
+! Copyright (C) 2009 Philipp Brüschweiler
+! See http://factorcode.org/license.txt for BSD license.
USING: infix.ast kernel peg peg.ebnf math.parser sequences
strings ;
IN: infix.tokenizer
! Optional: override ssh and scp command names
SYMBOL: scp-command
-scp-command global [ "scp" or ] change-at
+scp-command [ "scp" ] initialize
SYMBOL: ssh-command
-ssh-command global [ "ssh" or ] change-at
+ssh-command [ "ssh" ] initialize
: parse-1 ( input parser -- result )
dupd parse dup nil? [
- rot cannot-parse
+ swap cannot-parse
] [
nip car parsed>>
] if ;
[ parsed>> ] dip
[ parsed>> 2array ] keep
unparsed>> <parse-result>
- ] lazy-map-with
- ] lazy-map-with lconcat ;
+ ] with lazy-map
+ ] with lazy-map lconcat ;
M: and-parser parse ( input parser -- list )
#! Parse 'input' by sequentially combining the
#! of parser1 and parser2 being applied to the same
#! input. This implements the choice parsing operator.
parsers>> 0 swap seq>list
- [ parse ] lazy-map-with lconcat ;
+ [ parse ] with lazy-map lconcat ;
: trim-head-slice ( string -- string )
#! Return a new string without any leading whitespace
-rot parse [
[ parsed>> swap call ] keep
unparsed>> <parse-result>
- ] lazy-map-with ;
+ ] with lazy-map ;
TUPLE: some-parser p1 ;
! Copyright (c) 2007, 2008 Aaron Schaefer, Alexander Solovyov, Vishal Talwar.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences shuffle ;
+USING: kernel math sequences ;
IN: project-euler.002
! http://projecteuler.net/index.php?section=problems&id=2
! -------------------
: fib-upto* ( n -- seq )
- 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce 3nip
+ 0 1 [ pick over >= ] [ tuck + dup ] [ ] produce [ 3drop ] dip
but-last-slice { 0 1 } prepend ;
: euler002a ( -- answer )
PRIVATE>
: euler134 ( -- answer )
- 0 5 lprimes-from uncons swap [ 1000000 > ] luntil
+ 0 5 lprimes-from uncons [ 1000000 > ] luntil
[ [ s + ] keep ] leach drop ;
! [ euler134 ] 10 ave-time
{ 3drop 1 }\r
{ 3dup 2 }\r
{ 3keep 3 }\r
- { 3nip 4 }\r
{ 3slip 3 }\r
{ 4drop 2 }\r
{ 4dup 3 }\r
{ ndrop 2 }\r
{ ndup 3 }\r
{ nip 2 }\r
- { nipd 3 }\r
{ nkeep 5 }\r
{ npick 6 }\r
{ nrot 5 }\r
{ swap 1 }\r
{ swapd 3 }\r
{ tuck 2 }\r
- { tuckd 4 }\r
{ with 1/2 }\r
\r
{ bi 1/2 }\r
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: unix alien alien.c-types kernel math sequences strings
-io.backend.unix splitting ;
+io.backend.unix splitting io.encodings.utf8 io.encodings.string ;
IN: system-info.linux
: (uname) ( buf -- int )
: uname ( -- seq )
65536 "char" <c-array> [ (uname) io-error ] keep
- "\0" split harvest [ >string ] map
+ "\0" split harvest [ utf8 decode ] map
6 "" pad-tail ;
: sysname ( -- string ) uname first ;
io.backend byte-arrays ;
IN: tar
-: zero-checksum 256 ; inline
-: block-size 512 ; inline
+CONSTANT: zero-checksum 256
+CONSTANT: block-size 512
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
! Symlink
: typeflag-2 ( header -- )
- [ name>> ] [ linkname>> ] bi
- [ make-link ] 2curry ignore-errors ;
+ [ name>> ] [ linkname>> ] bi make-link ;
! character special
: typeflag-3 ( header -- ) unknown-typeflag ;
: futa-tax ( salary w4 -- x )
drop futa-base-rate min
- futa-tax-rate futa-tax-offset-credit -
- * ;
+ futa-tax-rate futa-tax-offset-credit - * ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs kernel math math.intervals
-namespaces sequences money math.order taxes.usa.w4 ;
+namespaces sequences money math.order taxes.usa.w4
+taxes.usa.futa math.finance ;
IN: taxes.usa
! Withhold: FICA, Medicare, Federal (FICA is social security)
--- /dev/null
+! Copyright (C) 2009 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs combinators hashtables http
+http.client json.reader kernel macros namespaces sequences
+urls.secure fry ;
+IN: twitter
+
+! Configuration
+SYMBOLS: twitter-username twitter-password twitter-source ;
+
+twitter-source [ "factor" ] initialize
+
+: set-twitter-credentials ( username password -- )
+ [ twitter-username set ] [ twitter-password set ] bi* ;
+
+<PRIVATE
+
+! Utilities
+MACRO: keys-boa ( keys class -- )
+ [ [ '[ _ swap at ] ] map ] dip '[ _ cleave _ boa ] ;
+
+! Twitter requests
+
+: twitter-url ( string -- url )
+ "https://twitter.com/statuses/" ".json" surround ;
+
+: set-request-twitter-auth ( request -- request )
+ twitter-username get twitter-password get set-basic-auth ;
+
+: twitter-request ( request -- data )
+ set-request-twitter-auth
+ http-request nip ; inline
+
+PRIVATE>
+
+! Data types
+
+TUPLE: twitter-status
+ created-at
+ id
+ text
+ source
+ truncated?
+ in-reply-to-status-id
+ in-reply-to-user-id
+ favorited?
+ user ;
+TUPLE: twitter-user
+ id
+ name
+ screen-name
+ description
+ location
+ profile-image-url
+ url
+ protected?
+ followers-count ;
+
+<PRIVATE
+
+: <twitter-user> ( assoc -- user )
+ {
+ "id"
+ "name"
+ "screen_name"
+ "description"
+ "location"
+ "profile_image_url"
+ "url"
+ "protected"
+ "followers_count"
+ } twitter-user keys-boa ;
+
+: <twitter-status> ( assoc -- tweet )
+ clone "user" over [ <twitter-user> ] change-at
+ {
+ "created_at"
+ "id"
+ "text"
+ "source"
+ "truncated"
+ "in_reply_to_status_id"
+ "in_reply_to_user_id"
+ "favorited"
+ "user"
+ } twitter-status keys-boa ;
+
+: json>twitter-statuses ( json-array -- tweets )
+ json> [ <twitter-status> ] map ;
+
+: json>twitter-status ( json-object -- tweet )
+ json> <twitter-status> ;
+
+PRIVATE>
+
+! Updates
+<PRIVATE
+
+: update-post-data ( update -- assoc )
+ [
+ "status" set
+ twitter-source get "source" set
+ ] H{ } make-assoc ;
+
+: (tweet) ( string -- json )
+ update-post-data "update" twitter-url
+ <post-request> twitter-request ;
+
+PRIVATE>
+
+: tweet* ( string -- tweet )
+ (tweet) json>twitter-status ;
+
+: tweet ( string -- ) (tweet) drop ;
+
+! Timelines
+<PRIVATE
+
+: timeline ( url -- tweets )
+ twitter-url <get-request>
+ twitter-request json>twitter-statuses ;
+
+PRIVATE>
+
+: public-timeline ( -- tweets )
+ "public_timeline" timeline ;
+
+: friends-timeline ( -- tweets )
+ "friends_timeline" timeline ;
+
+: user-timeline ( username -- tweets )
+ "user_timeline/" prepend timeline ;
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel quotations ui.gadgets
-graphics.bitmap strings ui.gadgets.worlds ;
+images.bitmap strings ui.gadgets.worlds ;
IN: ui.offscreen
HELP: <offscreen-world>
! (c) 2008 Joe Groff, see license for details
-USING: accessors continuations graphics.bitmap kernel math
+USING: accessors continuations images.bitmap kernel math
sequences ui.gadgets ui.gadgets.worlds ui ui.backend
destructors ;
IN: ui.offscreen
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors arrays kernel sequences math byte-arrays
-namespaces grouping fry cap graphics.bitmap
+namespaces grouping fry cap images.bitmap
ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids
ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons
-ui.render ui opengl opengl.gl ;
+ui.render ui opengl opengl.gl images images.loader ;
IN: ui.render.test
SINGLETON: line-test
: bitmap= ( bitmap1 bitmap2 -- ? )
[
- [ [ array>> ] [ stride 4 align ] bi group ] [ stride ] bi
+ [ [ buffer>> ] [ stride 4 align ] bi group ] [ stride ] bi
'[ _ head twiddle ] map
] bi@ = ;
screenshot
[ render-output set-global ]
[
- "resource:extra/ui/render/test/reference.bmp" load-bitmap
+ "resource:extra/ui/render/test/reference.bmp" load-image
bitmap= "is perfect" "needs work" ?
"Your UI rendering " prepend
message-window
: <todo-list> ( -- responder )
todo-list new-dispatcher
- <list-action> "" add-responder
+ <list-action> "list" add-responder
+ URL" /list" <redirect-responder> "" add-responder
<view-action> "view" add-responder
<new-action> "new" add-responder
<edit-action> "edit" add-responder
{ todo-list "todo" } >>template
<protected>
"view your todo list" >>description ;
+
+USING: furnace.auth.features.registration
+furnace.auth.features.edit-profile
+furnace.auth.features.deactivate-user
+db.sqlite
+furnace.alloy
+io.servers.connection
+io.sockets.secure ;
+
+: <login-config> ( responder -- responder' )
+ "Todo list" <login-realm>
+ "Todo list" >>name
+ allow-registration
+ allow-edit-profile
+ allow-deactivation ;
+
+: todo-db ( -- db ) "resource:todo.db" <sqlite-db> ;
+
+: init-todo-db ( -- )
+ todo-db [
+ init-furnace-tables
+ todo ensure-table
+ ] with-db ;
+
+: <todo-secure-config> ( -- config )
+ ! This is only suitable for testing!
+ <secure-config>
+ "resource:basis/openssl/test/dh1024.pem" >>dh-file
+ "resource:basis/openssl/test/server.pem" >>key-file
+ "password" >>password ;
+
+: <todo-app> ( -- responder )
+ init-todo-db
+ <todo-list>
+ <login-config>
+ todo-db <alloy> ;
+
+: <todo-website-server> ( -- threaded-server )
+ <http-server>
+ <todo-secure-config> >>secure-config
+ 8080 >>insecure
+ 8431 >>secure ;
+
+: run-todo ( -- )
+ <todo-app> main-responder set-global
+ todo-db start-expiring
+ <todo-website-server> start-server ;
+
+MAIN: run-todo
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
+<html>
+
<t:style t:include="resource:extra/webapps/todo/todo.css" />
+ <t:style t:include="resource:extra/websites/concatenative/page.css" />
+
+ <head><t:write-title/><t:write-style/></head>
+
+ <body>
<div class="navbar">
<t:a t:href="$todo-list/list">List Items</t:a>
<t:call-next-template />
+ </body>
+
+</html>
+
</t:chloe>
void ffi_dlopen(F_DLL *dll)
{
- dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY|RTLD_GLOBAL);
+ dll->dll = dlopen(alien_offset(dll->path), RTLD_LAZY);
}
void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol)