*.bak
.#*
*.swo
+checksums.txt
* Running Factor on Windows XP/Vista
+The Factor runtime is compiled into two binaries:
+
+ factor.com - a Windows console application
+ factor.exe - a Windows native application, without a console
+
If you did not download the binary package, you can bootstrap Factor in
-the command prompt:
+the command prompt using the console application:
- factor.exe -i=boot.<cpu>.image
+ factor.com -i=boot.<cpu>.image
-Once bootstrapped, double-clicking factor.exe starts the Factor UI.
+Once bootstrapped, double-clicking factor.exe or factor.com starts
+the Factor UI.
To run the listener in the command prompt:
- factor.exe -run=listener
+ factor.com -run=listener
* The Factor FAQ
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 ;
+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 ;
unclip [
[
dup word? [
- def>> { } swap with-datastack first
+ def>> call( -- object )
] when
] map
] dip prefix
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" } "." } ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax quotations effects words ;
+IN: call
+
+ABOUT: "call"
+
+ARTICLE: "call" "Calling code with known stack effects"
+"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
+{ $subsection POSTPONE: call( }
+{ $subsection POSTPONE: execute( }
+{ $subsection call-effect }
+{ $subsection execute-effect } ;
+
+HELP: call(
+{ $syntax "[ ] call( foo -- bar )" }
+{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
+
+HELP: call-effect
+{ $values { "quot" quotation } { "effect" effect } }
+{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
+
+HELP: execute(
+{ $syntax "word execute( foo -- bar )" }
+{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ;
+
+HELP: execute-effect
+{ $values { "word" word } { "effect" effect } }
+{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
+
+{ execute-effect call-effect } related-words
+{ POSTPONE: call( POSTPONE: execute( } related-words
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math tools.test call kernel ;
+IN: call.tests
+
+[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
+[ 1 2 [ + ] call( -- z ) ] must-fail
+[ 1 2 [ + ] call( x y -- z a ) ] must-fail
+[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test
+[ [ + ] call( x y -- z ) ] must-infer
+
+[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test
+[ 1 2 \ + execute( -- z ) ] must-fail
+[ 1 2 \ + execute( x y -- z a ) ] must-fail
+[ \ + execute( x y -- z ) ] must-infer
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel macros fry summary sequences generalizations accessors
+continuations effects.parser parser words ;
+IN: call
+
+ERROR: wrong-values values quot length-required ;
+
+M: wrong-values summary
+ drop "Wrong number of values returned from quotation" ;
+
+<PRIVATE
+
+: firstn-safe ( array quot n -- ... )
+ 3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
+
+PRIVATE>
+
+MACRO: call-effect ( effect -- quot )
+ [ in>> length ] [ out>> length ] bi
+ '[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
+
+: call(
+ ")" parse-effect parsed \ call-effect parsed ; parsing
+
+: execute-effect ( word effect -- )
+ [ [ execute ] curry ] dip call-effect ; inline
+
+: execute(
+ ")" parse-effect parsed \ execute-effect parsed ; parsing
SYMBOL: frameworks
-frameworks global [ V{ } clone or ] change-at
+frameworks [ V{ } clone ] initialize
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
namespaces make parser quotations sequences strings words
cocoa.runtime io macros memoize io.encodings.utf8
effects libc libc.private parser lexer init core-foundation fry
-generalizations specialized-arrays.direct.alien ;
+generalizations specialized-arrays.direct.alien call ;
IN: cocoa.messages
: make-sender ( method function -- quot )
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 ] [
- drop over class-init-hooks get at [ assert-depth ] when*
+ drop over class-init-hooks get at [ call( -- ) ] when*
2dup execute dup [ 2nip ] [
2drop "No such class: " prepend throw
] if
\ 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>>
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel arrays sequences math math.order
+USING: accessors kernel arrays sequences math math.order call
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
words namespaces continuations classes fry combinators.smart
"custom-inlining" word-prop ;
: inline-custom ( #call word -- ? )
- [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack
- first object swap eliminate-dispatch ;
+ [ dup ] [ "custom-inlining" word-prop ] bi*
+ call( #call -- word/quot/f )
+ object swap eliminate-dispatch ;
: inline-instance-check ( #call word -- ? )
over in-d>> second value-info literal>> dup class?
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 ;
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 )
\r
{ nsequence narray } related-words\r
\r
+HELP: nsum\r
+{ $values { "n" integer } }\r
+{ $description "Adds the top " { $snippet "n" } " stack values." } ;\r
+\r
HELP: firstn\r
{ $values { "n" integer } }\r
{ $description "A generalization of " { $link first } ", "\r
"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
}\r
} ;\r
\r
+HELP: nspread\r
+{ $values { "quots" "a sequence of quotations" } { "n" integer } }\r
+{ $description "A generalization of " { $link spread } " that can work for any quotation arity."\r
+} ;\r
+\r
HELP: mnswap\r
{ $values { "m" integer } { "n" integer } }\r
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }\r
}\r
} ;\r
\r
+HELP: nweave\r
+{ $values { "n" integer } }\r
+{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." }\r
+{ $examples\r
+ { $example\r
+ "USING: arrays kernel generalizations prettyprint ;"\r
+ "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ."\r
+ "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }"\r
+ }\r
+} ;\r
+\r
HELP: n*quot\r
{ $values\r
{ "n" integer } { "seq" sequence }\r
}\r
{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;\r
\r
-ARTICLE: "generalizations" "Generalized shuffle words and combinators"\r
-"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "\r
-"macros where the arity of the input quotations depends on an "\r
-"input parameter."\r
-$nl\r
-"Generalized sequence operations:"\r
+ARTICLE: "sequence-generalizations" "Generalized sequence operations"\r
{ $subsection narray }\r
{ $subsection nsequence }\r
{ $subsection firstn }\r
{ $subsection nappend }\r
-{ $subsection nappend-as }\r
-"Generated stack shuffle operations:"\r
+{ $subsection nappend-as } ;\r
+\r
+ARTICLE: "shuffle-generalizations" "Generalized shuffle words"\r
{ $subsection ndup }\r
{ $subsection npick }\r
{ $subsection nrot }\r
{ $subsection ndrop }\r
{ $subsection ntuck }\r
{ $subsection mnswap }\r
-"Generalized combinators:"\r
+{ $subsection nweave } ;\r
+\r
+ARTICLE: "combinator-generalizations" "Generalized combinators"\r
{ $subsection ndip }\r
{ $subsection nslip }\r
{ $subsection nkeep }\r
{ $subsection napply }\r
{ $subsection ncleave }\r
-"Generalized quotation construction:"\r
+{ $subsection nspread } ;\r
+\r
+ARTICLE: "other-generalizations" "Additional generalizations"\r
{ $subsection ncurry } \r
-{ $subsection nwith } ;\r
+{ $subsection nwith }\r
+{ $subsection nsum } ;\r
+\r
+ARTICLE: "generalizations" "Generalized shuffle words and combinators"\r
+"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "\r
+"macros where the arity of the input quotations depends on an "\r
+"input parameter."\r
+{ $subsection "sequence-generalizations" }\r
+{ $subsection "shuffle-generalizations" }\r
+{ $subsection "combinator-generalizations" }\r
+{ $subsection "other-generalizations" } ;\r
\r
ABOUT: "generalizations"\r
\r
[ 4 nappend ] must-infer\r
[ 4 { } nappend-as ] must-infer\r
+\r
+[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test\r
+{ 4 1 } [ 4 nsum ] must-infer-as\r
+\r
+[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test\r
+{ 3 5 } [ 2 nweave ] must-infer-as\r
+\r
+[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ]\r
+[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test
\ No newline at end of file
-! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo
+! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo
! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private math combinators
MACRO: narray ( n -- )
'[ _ { } nsequence ] ;
+MACRO: nsum ( n -- )
+ 1- [ + ] n*quot ;
+
MACRO: firstn ( n -- )
dup zero? [ drop [ drop ] ] [
[ [ '[ [ _ ] dip nth-unsafe ] ] map ]
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
compose ;
+MACRO: nspread ( quots n -- )
+ over empty? [ 2drop [ ] ] [
+ [ [ but-last ] dip ]
+ [ [ peek ] dip ] 2bi
+ swap
+ '[ [ _ _ nspread ] _ ndip @ ]
+ ] if ;
+
MACRO: napply ( quot n -- )
swap <repetition> spread>quot ;
MACRO: mnswap ( m n -- )
- 1+ '[ _ -nrot ] <repetition> spread>quot ;
+ 1+ '[ _ -nrot ] swap '[ _ _ napply ] ;
+
+MACRO: nweave ( n -- )
+ [ dup <reversed> [ '[ _ _ mnswap ] ] with map ] keep
+ '[ _ _ ncleave ] ;
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline
SYMBOL: help-hook
-help-hook global [ [ print-topic ] or ] change-at
+help-hook [ [ print-topic ] ] initialize
: help ( topic -- )
help-hook get call ;
hashtables sorting effects vocabs vocabs.loader assocs editors
continuations classes.predicate macros math sets eval
vocabs.parser words.symbol values grouping unicode.categories
-sequences.deep ;
+sequences.deep call ;
IN: help.lint
SYMBOL: vocabs-quot
: check-example ( element -- )
[
rest [
- but-last "\n" join 1vector
- [ (eval>string) ] with-datastack
- peek "\n" ?tail drop
+ but-last "\n" join
+ [ (eval>string) ] call( code -- output )
+ "\n" ?tail drop
] keep
peek assert=
] vocabs-quot get call ;
bi ;
: check-something ( obj quot -- )
- flush '[ _ assert-depth ] swap '[ _ <help-error> , ] recover ; inline
+ flush '[ _ call( -- ) ] swap '[ _ <help-error> , ] recover ; inline
: check-word ( word -- )
[ with-file-vocabs ] vocabs-quot set
! 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 } }
namespaces make classes.tuple assocs splitting words arrays io
io.files io.files.info io.encodings.utf8 io.streams.string
unicode.case mirrors math urls present multiline quotations xml
-logging continuations
+logging call
xml.data xml.writer xml.syntax strings
html.forms
html
COMPONENT: choice
COMPONENT: checkbox
COMPONENT: code
+COMPONENT: xml
SYMBOL: template-cache
template-cache get clear-assoc ;
M: chloe call-template*
- template-quot assert-depth ;
+ template-quot call( -- ) ;
INSTANCE: chloe template
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces make kernel sequences accessors
combinators strings splitting io io.streams.string present
-xml.writer xml.data xml.entities html.forms
-html.templates html.templates.chloe.syntax continuations ;
+xml.writer xml.data xml.entities html.forms call
+html.templates html.templates.chloe.syntax ;
IN: html.templates.chloe.compiler
: chloe-attrs-only ( assoc -- assoc' )
: compile-chloe-tag ( tag -- )
dup main>> dup tags get at
- [ curry assert-depth ]
+ [ call( tag -- ) ]
[ unknown-chloe-tag ]
?if ;
SYMBOL: tags
-tags global [ H{ } clone or ] change-at
+tags [ H{ } clone ] initialize
: define-chloe-tag ( name quot -- ) swap tags get set-at ;
! See http://factorcode.org/license.txt for BSD license.
USING: continuations sequences kernel namespaces debugger
combinators math quotations generic strings splitting accessors
-assocs fry vocabs.parser parser lexer io io.files
+assocs fry vocabs.parser parser lexer io io.files call
io.streams.string io.encodings.utf8 html.templates ;
IN: html.templates.fhtml
C: <fhtml> fhtml
M: fhtml call-template* ( filename -- )
- '[ _ path>> utf8 file-contents eval-template ] assert-depth ;
+ [ path>> utf8 file-contents eval-template ] call( filename -- ) ;
INSTANCE: fhtml template
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 ;
+IN: images
+
+SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+R16G16B16 R32G32B32 ;
+
+TUPLE: image dim component-order bitmap ;
+
+: <image> ( -- image ) image new ; inline
+
+GENERIC: load-image* ( path tuple -- image )
+
+: add-dummy-alpha ( seq -- seq' )
+ 3 <sliced-groups>
+ [ 255 suffix ] map concat ;
+
+: normalize-component-order ( image -- image )
+ dup component-order>>
+ {
+ { RGBA [ ] }
+ { R32G32B32 [
+ [
+ dup length 4 / <direct-uint-array>
+ [ bits>float 255.0 * >integer ] map
+ >byte-array add-dummy-alpha
+ ] change-bitmap
+ ] }
+ { R16G16B16 [
+ [
+ dup length 2 / <direct-ushort-array>
+ [ -8 shift ] map
+ >byte-array add-dummy-alpha
+ ] change-bitmap
+ ] }
+ { BGRA [
+ [
+ 4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
+ ] change-bitmap
+ ] }
+ { RGB [ [ add-dummy-alpha ] change-bitmap ] }
+ { BGR [
+ [
+ 3 <sliced-groups>
+ [ [ [ 0 3 ] dip <slice> reverse-here ] each ]
+ [ add-dummy-alpha ] bi
+ ] change-bitmap
+ ] }
+ } case
+ RGBA >>component-order ;
+
+GENERIC: normalize-scan-line-order ( image -- image )
+
+M: image normalize-scan-line-order ;
+
+: normalize-image ( image -- image )
+ [ >byte-array ] change-bitmap
+ normalize-component-order
+ normalize-scan-line-order ;
--- /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 ;
+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 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 ;
+
+: 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 ] }
+ { 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 ] }
+ { 296 [ lookup-resolution-unit resolution-unit ] }
+ { 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 ;
+
+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 } [ R32G32B32 ] }
+ { { 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
+ 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 ;
2bi
] if ;
-M: unix (stream-seek) ( n seek-type stream -- )
+M: unix seek-handle ( n seek-type handle -- )
swap {
{ io:seek-absolute [ SEEK_SET ] }
{ io:seek-relative [ SEEK_CUR ] }
{ io:seek-end [ SEEK_END ] }
[ io:bad-seek-type ]
} case
- [ handle>> fd>> swap ] dip lseek io-error ;
+ [ fd>> swap ] dip lseek io-error ;
SYMBOL: +retry+ ! just try the operation again without blocking
SYMBOL: +input+
: handle>file-size ( handle -- n )
0 <ulonglong> [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ;
-M: winnt (stream-seek) ( n seek-type stream -- )
+ERROR: seek-before-start n ;
+
+: set-seek-ptr ( n handle -- )
+ [ dup 0 < [ seek-before-start ] when ] dip (>>ptr) ;
+
+M: winnt seek-handle ( n seek-type handle -- )
swap {
- { seek-absolute [ handle>> (>>ptr) ] }
- { seek-relative [ handle>> [ + ] change-ptr drop ] }
- { seek-end [ handle>> [ handle>> handle>file-size + ] keep (>>ptr) ] }
+ { seek-absolute [ set-seek-ptr ] }
+ { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] }
+ { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] }
[ bad-seek-type ]
} case ;
: buffer-reset ( n buffer -- )
swap >>fill 0 >>pos drop ;
-: buffer-reset-hard ( buffer -- )
- 0 >>fill 0 >>pos drop ;
-
: buffer-capacity ( buffer -- n )
[ size>> ] [ fill>> ] bi - ; inline
"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
+
+
HOOK: (wait-to-write) io-backend ( port -- )
-HOOK: (stream-seek) os ( n seek-type stream -- )
+HOOK: seek-handle os ( n seek-type handle -- )
-M: port stream-seek ( n seek-type stream -- )
- dup check-disposed
- [ buffer>> buffer-reset-hard 2drop ] [ (stream-seek) ] 3bi ;
+M: input-port stream-seek ( n seek-type stream -- )
+ [ check-disposed ]
+ [ buffer>> 0 swap buffer-reset ]
+ [ handle>> seek-handle ] tri ;
+M: output-port stream-seek ( n seek-type stream -- )
+ [ check-disposed ]
+ [ stream-flush ]
+ [ handle>> seek-handle ] tri ;
GENERIC: shutdown ( handle -- )
--- /dev/null
+James Cash
--- /dev/null
+Chris Double
+Samuel Tardieu
+Matthew Willis
--- /dev/null
+Chris Double
--- /dev/null
+USING: lists.lazy.examples lists.lazy tools.test ;
+IN: lists.lazy.examples.tests
+
+[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
+[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
--- /dev/null
+! Rewritten by Matthew Willis, July 2006
+! Copyright (C) 2004 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: lists.lazy math kernel sequences quotations ;
+IN: lists.lazy.examples
+
+: naturals ( -- list ) 0 lfrom ;
+: positives ( -- list ) 1 lfrom ;
+: evens ( -- list ) 0 [ 2 + ] lfrom-by ;
+: odds ( -- list ) 1 lfrom [ 2 mod 1 = ] lfilter ;
+: powers-of-2 ( -- list ) 1 [ 2 * ] lfrom-by ;
+: ones ( -- list ) 1 [ ] lfrom-by ;
+: squares ( -- list ) naturals [ dup * ] lazy-map ;
+: first-five-squares ( -- list ) 5 squares ltake list>array ;
--- /dev/null
+! 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 "( -- 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? } ;
+
+{ 1lazy-list 2lazy-list 3lazy-list } related-words
+
+HELP: 1lazy-list
+{ $values { "a" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
+
+HELP: 2lazy-list
+{ $values { "a" { $quotation "( -- X )" } } { "b" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
+
+HELP: 3lazy-list
+{ $values { "a" { $quotation "( -- X )" } } { "b" { $quotation "( -- X )" } } { "c" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
+{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
+
+HELP: <memoized-cons>
+{ $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
+{ $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 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: 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." } ;
+
+HELP: lfilter
+{ $values { "list" "a cons object" } { "quot" { $quotation "( -- X )" } } { "result" "resulting cons object" } }
+{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " 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: lwhile
+{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: luntil
+{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } }
+{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
+
+HELP: list>vector
+{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
+{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
+{ $see-also list>array } ;
+
+HELP: list>array
+{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
+{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
+{ $see-also list>vector } ;
+
+HELP: lappend
+{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
+{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
+
+HELP: lfrom-by
+{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "list" "a lazy list of integers" } }
+{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
+
+HELP: lfrom
+{ $values { "n" "an integer" } { "list" "a lazy list of integers" } }
+{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
+
+HELP: seq>list
+{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
+{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
+{ $see-also >list } ;
+
+HELP: >list
+{ $values { "object" "an object" } { "list" "a list" } }
+{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." }
+{ $see-also seq>list } ;
+
+{ 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" } }
+{ $description "Concatenates a list of lists together into one list." } ;
+
+HELP: lcartesian-product
+{ $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
+{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
+
+HELP: lcartesian-product*
+{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
+{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
+
+HELP: lcomp
+{ $values { "list" "a list of lists" } { "quot" { $quotation "( seq -- X )" } } { "result" "the resulting list" } }
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
+
+HELP: lcomp*
+{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation "( seq -- X )" } } { "list" "the resulting list" } { "result" "a list" } }
+{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
+{ $examples
+ { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
+} ;
+
+HELP: lmerge
+{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
+{ $description "Return the result of merging the two lists in a lazy manner." }
+{ $examples
+ { $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
+} ;
+
+HELP: lcontents
+{ $values { "stream" "a stream" } { "result" string } }
+{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." }
+{ $see-also llines } ;
+
+HELP: llines
+{ $values { "stream" "a stream" } { "result" "a list" } }
+{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." }
+{ $see-also lcontents } ;
--- /dev/null
+! Copyright (C) 2006 Matthew Willis and Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: lists lists.lazy tools.test kernel math io sequences ;
+IN: lists.lazy.tests
+
+[ { 1 2 3 4 } ] [
+ { 1 2 3 4 } >list list>array
+] unit-test
+
+[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list lcartesian-product* list>array
+] unit-test
+
+[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
+ { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array
+] unit-test
+
+[ { 5 6 6 7 7 8 } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
+] unit-test
+
+[ { 5 6 7 8 } ] [
+ { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
+] unit-test
+
+[ { 4 5 6 } ] [
+ 3 { 1 2 3 } >list [ + ] with lazy-map list>array
+] unit-test
+
+[ [ ] lmap ] must-infer
+[ [ ] lmap>array ] must-infer
+[ [ drop ] foldr ] must-infer
+[ [ drop ] foldl ] must-infer
+[ [ drop ] leach ] must-infer
+[ lnth ] must-infer
--- /dev/null
+! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel sequences math vectors arrays namespaces make
+quotations promises combinators io lists accessors call ;
+IN: lists.lazy
+
+M: promise car ( promise -- car )
+ force car ;
+
+M: promise cdr ( promise -- cdr )
+ force cdr ;
+
+M: promise nil? ( cons -- bool )
+ force nil? ;
+
+! Both 'car' and 'cdr' are promises
+TUPLE: lazy-cons car cdr ;
+
+: lazy-cons ( car cdr -- promise )
+ [ promise ] bi@ \ lazy-cons boa
+ T{ promise f f t f } clone
+ swap >>value ;
+
+M: lazy-cons car ( lazy-cons -- car )
+ car>> force ;
+
+M: lazy-cons cdr ( lazy-cons -- cdr )
+ cdr>> force ;
+
+M: lazy-cons nil? ( lazy-cons -- bool )
+ nil eq? ;
+
+: 1lazy-list ( a -- lazy-cons )
+ [ nil ] lazy-cons ;
+
+: 2lazy-list ( a b -- lazy-cons )
+ 1lazy-list 1quotation lazy-cons ;
+
+: 3lazy-list ( a b c -- lazy-cons )
+ 2lazy-list 1quotation lazy-cons ;
+
+TUPLE: memoized-cons original car cdr nil? ;
+
+: not-memoized ( -- obj )
+ { } ;
+
+: not-memoized? ( obj -- bool )
+ not-memoized eq? ;
+
+: <memoized-cons> ( cons -- memoized-cons )
+ not-memoized not-memoized not-memoized
+ memoized-cons boa ;
+
+M: memoized-cons car ( memoized-cons -- car )
+ dup car>> not-memoized? [
+ dup original>> car [ >>car drop ] keep
+ ] [
+ car>>
+ ] if ;
+
+M: memoized-cons cdr ( memoized-cons -- cdr )
+ dup cdr>> not-memoized? [
+ dup original>> cdr [ >>cdr drop ] keep
+ ] [
+ cdr>>
+ ] if ;
+
+M: memoized-cons nil? ( memoized-cons -- bool )
+ dup nil?>> not-memoized? [
+ dup original>> nil? [ >>nil? drop ] keep
+ ] [
+ nil?>>
+ ] if ;
+
+TUPLE: lazy-map cons quot ;
+
+C: <lazy-map> lazy-map
+
+: lazy-map ( list quot -- result )
+ over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
+
+M: lazy-map car ( lazy-map -- car )
+ [ cons>> car ] keep
+ quot>> call( old -- new ) ;
+
+M: lazy-map cdr ( lazy-map -- cdr )
+ [ cons>> cdr ] keep
+ quot>> lazy-map ;
+
+M: lazy-map nil? ( lazy-map -- bool )
+ cons>> nil? ;
+
+TUPLE: lazy-take n cons ;
+
+C: <lazy-take> lazy-take
+
+: ltake ( n list -- result )
+ over zero? [ 2drop nil ] [ <lazy-take> ] if ;
+
+M: lazy-take car ( lazy-take -- car )
+ cons>> car ;
+
+M: lazy-take cdr ( lazy-take -- cdr )
+ [ n>> 1- ] keep
+ cons>> cdr ltake ;
+
+M: lazy-take nil? ( lazy-take -- bool )
+ dup n>> zero? [
+ drop t
+ ] [
+ cons>> nil?
+ ] if ;
+
+TUPLE: lazy-until cons quot ;
+
+C: <lazy-until> lazy-until
+
+: luntil ( list quot -- result )
+ over nil? [ drop ] [ <lazy-until> ] if ;
+
+M: lazy-until car ( lazy-until -- car )
+ cons>> car ;
+
+M: lazy-until cdr ( lazy-until -- cdr )
+ [ cons>> unswons ] keep quot>> tuck call( elt -- ? )
+ [ 2drop nil ] [ luntil ] if ;
+
+M: lazy-until nil? ( lazy-until -- bool )
+ drop f ;
+
+TUPLE: lazy-while cons quot ;
+
+C: <lazy-while> lazy-while
+
+: lwhile ( list quot -- result )
+ over nil? [ drop ] [ <lazy-while> ] if ;
+
+M: lazy-while car ( lazy-while -- car )
+ cons>> car ;
+
+M: lazy-while cdr ( lazy-while -- cdr )
+ [ cons>> cdr ] keep quot>> lwhile ;
+
+M: lazy-while nil? ( lazy-while -- bool )
+ [ car ] keep quot>> call( elt -- ? ) not ;
+
+TUPLE: lazy-filter cons quot ;
+
+C: <lazy-filter> lazy-filter
+
+: lfilter ( list quot -- result )
+ over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
+
+: car-filter? ( lazy-filter -- ? )
+ [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ;
+
+: skip ( lazy-filter -- )
+ dup cons>> cdr >>cons drop ;
+
+M: lazy-filter car ( lazy-filter -- car )
+ dup car-filter? [ cons>> ] [ dup skip ] if car ;
+
+M: lazy-filter cdr ( lazy-filter -- cdr )
+ dup car-filter? [
+ [ cons>> cdr ] [ quot>> ] bi lfilter
+ ] [
+ dup skip cdr
+ ] if ;
+
+M: lazy-filter nil? ( lazy-filter -- bool )
+ dup cons>> nil? [
+ drop t
+ ] [
+ dup car-filter? [
+ drop f
+ ] [
+ dup skip nil?
+ ] if
+ ] if ;
+
+: list>vector ( list -- vector )
+ [ [ , ] leach ] V{ } make ;
+
+: list>array ( list -- array )
+ [ [ , ] leach ] { } make ;
+
+TUPLE: lazy-append list1 list2 ;
+
+C: <lazy-append> lazy-append
+
+: lappend ( list1 list2 -- result )
+ over nil? [ nip ] [ <lazy-append> ] if ;
+
+M: lazy-append car ( lazy-append -- car )
+ list1>> car ;
+
+M: lazy-append cdr ( lazy-append -- cdr )
+ [ list1>> cdr ] keep
+ list2>> lappend ;
+
+M: lazy-append nil? ( lazy-append -- bool )
+ drop f ;
+
+TUPLE: lazy-from-by n quot ;
+
+C: lfrom-by lazy-from-by ( n quot -- list )
+
+: lfrom ( n -- list )
+ [ 1+ ] lfrom-by ;
+
+M: lazy-from-by car ( lazy-from-by -- car )
+ n>> ;
+
+M: lazy-from-by cdr ( lazy-from-by -- cdr )
+ [ n>> ] keep
+ quot>> [ call( old -- new ) ] keep lfrom-by ;
+
+M: lazy-from-by nil? ( lazy-from-by -- bool )
+ drop f ;
+
+TUPLE: lazy-zip list1 list2 ;
+
+C: <lazy-zip> lazy-zip
+
+: lzip ( list1 list2 -- lazy-zip )
+ over nil? over nil? or
+ [ 2drop nil ] [ <lazy-zip> ] if ;
+
+M: lazy-zip car ( lazy-zip -- car )
+ [ list1>> car ] keep list2>> car 2array ;
+
+M: lazy-zip cdr ( lazy-zip -- cdr )
+ [ list1>> cdr ] keep list2>> cdr lzip ;
+
+M: lazy-zip nil? ( lazy-zip -- bool )
+ drop f ;
+
+TUPLE: sequence-cons index seq ;
+
+C: <sequence-cons> sequence-cons
+
+: seq>list ( index seq -- list )
+ 2dup length >= [
+ 2drop nil
+ ] [
+ <sequence-cons>
+ ] if ;
+
+M: sequence-cons car ( sequence-cons -- car )
+ [ index>> ] keep
+ seq>> nth ;
+
+M: sequence-cons cdr ( sequence-cons -- cdr )
+ [ index>> 1+ ] keep
+ seq>> seq>list ;
+
+M: sequence-cons nil? ( sequence-cons -- bool )
+ drop f ;
+
+: >list ( object -- list )
+ {
+ { [ dup sequence? ] [ 0 swap seq>list ] }
+ { [ dup list? ] [ ] }
+ [ "Could not convert object to a list" throw ]
+ } cond ;
+
+TUPLE: lazy-concat car cdr ;
+
+C: <lazy-concat> lazy-concat
+
+DEFER: lconcat
+
+: (lconcat) ( car cdr -- list )
+ over nil? [
+ nip lconcat
+ ] [
+ <lazy-concat>
+ ] if ;
+
+: lconcat ( list -- result )
+ dup nil? [
+ drop nil
+ ] [
+ uncons (lconcat)
+ ] if ;
+
+M: lazy-concat car ( lazy-concat -- car )
+ car>> car ;
+
+M: lazy-concat cdr ( lazy-concat -- cdr )
+ [ car>> cdr ] keep cdr>> (lconcat) ;
+
+M: lazy-concat nil? ( lazy-concat -- bool )
+ dup car>> nil? [
+ cdr>> nil?
+ ] [
+ drop f
+ ] if ;
+
+: lcartesian-product ( list1 list2 -- result )
+ 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 ] with lazy-map ] with lazy-map lconcat
+ ] reduce
+ ] if ;
+
+: lcomp ( list quot -- result )
+ [ lcartesian-product* ] dip lazy-map ;
+
+: lcomp* ( list guards quot -- result )
+ [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
+
+DEFER: lmerge
+
+: (lmerge) ( list1 list2 -- result )
+ over [ car ] curry -rot
+ [
+ dup [ car ] curry -rot
+ [
+ [ cdr ] bi@ lmerge
+ ] 2curry lazy-cons
+ ] 2curry lazy-cons ;
+
+: lmerge ( list1 list2 -- result )
+ {
+ { [ over nil? ] [ nip ] }
+ { [ dup nil? ] [ drop ] }
+ { [ t ] [ (lmerge) ] }
+ } cond ;
+
+TUPLE: lazy-io stream car cdr quot ;
+
+C: <lazy-io> lazy-io
+
+: lcontents ( stream -- result )
+ f f [ stream-read1 ] <lazy-io> ;
+
+: llines ( stream -- result )
+ f f [ stream-readln ] <lazy-io> ;
+
+M: lazy-io car ( lazy-io -- car )
+ dup car>> dup [
+ nip
+ ] [
+ drop dup stream>> over quot>>
+ call( stream -- value )
+ >>car
+ ] if ;
+
+M: lazy-io cdr ( lazy-io -- cdr )
+ dup cdr>> dup [
+ nip
+ ] [
+ drop dup
+ [ stream>> ] keep
+ [ quot>> ] keep
+ car [
+ [ f f ] dip <lazy-io> [ >>cdr drop ] keep
+ ] [
+ 3drop nil
+ ] if
+ ] if ;
+
+M: lazy-io nil? ( lazy-io -- bool )
+ car not ;
+
+INSTANCE: sequence-cons list
+INSTANCE: memoized-cons list
+INSTANCE: promise list
+INSTANCE: lazy-io list
+INSTANCE: lazy-concat list
+INSTANCE: lazy-cons list
+INSTANCE: lazy-map list
+INSTANCE: lazy-take list
+INSTANCE: lazy-append list
+INSTANCE: lazy-from-by list
+INSTANCE: lazy-zip list
+INSTANCE: lazy-while list
+INSTANCE: lazy-until list
+INSTANCE: lazy-filter list
--- /dev/null
+<html>
+ <head>
+ <title>Lazy Evaluation</title>
+ <link rel="stylesheet" type="text/css" href="style.css">
+ </head>
+ <body>
+ <h1>Lazy Evaluation</h1>
+<p>The 'lazy' vocabulary adds lazy lists to Factor. This provides the
+ ability to describe infinite structures, and to delay execution of
+ expressions until they are actually used.</p>
+<p>Lazy lists, like normal lists, are composed of a head and tail. In
+ a lazy list the head and tail are something called a 'promise'.
+ To convert a
+ 'promise' into its actual value a word called 'force' is used. To
+ convert a value into a 'promise' the word to use is 'delay'.</p>
+<table border="1">
+<tr><td><a href="#delay">delay</a></td></tr>
+<tr><td><a href="#force">force</a></td></tr>
+</table>
+
+<p>Many of the lazy list words are named similar to the standard list
+ words but with an 'l' suffixed to it. Here are the commonly used
+ words and their equivalent list operation:</p>
+<table border="1">
+<tr><th>Lazy List</th><th>Normal List</th></tr>
+<tr><td><a href="#lnil">lnil</a></td><td>[ ]</td></tr>
+<tr><td><a href="#lnilp">lnil?</a></td><td>Test for nil value</td></tr>
+<tr><td><a href="#lcons">lcons</a></td><td>cons</td></tr>
+<tr><td><a href="#lunit">lunit</a></td><td>unit</td></tr>
+<tr><td><a href="#lcar">lcar</a></td><td>car</td></tr>
+<tr><td><a href="#lcdr">lcdr</a></td><td>cdr</td></tr>
+<tr><td><a href="#lnth">lnth</a></td><td>nth</td></tr>
+<tr><td><a href="#luncons">luncons</a></td><td>uncons</td></tr>
+<tr><td><a href="#lmap">lmap</a></td><td>map</td></tr>
+<tr><td><a href="#lsubset">lsubset</a></td><td>subset</td></tr>
+<tr><td><a href="#leach">leach</a></td><td>each</td></tr>
+<tr><td><a href="#lappend">lappend</a></td><td>append</td></tr>
+</table>
+<p>A few additional words specific to lazy lists are:</p>
+<table border="1">
+<tr><td><a href="#ltake">ltake</a></td><td>Returns a normal list containing a specified
+number of items from the lazy list.</td></tr>
+<tr><td><a href="#lappendstar">lappend*</a></td><td>Given a lazy list of lazy lists,
+concatenate them together in a lazy manner, returning a single lazy
+list.</td></tr>
+<tr><td><a href="#list>llist">list>llist</a></td><td>Given a normal list, return a lazy list
+that contains the same elements as the normal list.</td></tr>
+</table>
+<h2>Reference</h2>
+<!-- delay description -->
+<a name="delay">
+<h3>delay ( quot -- <promise> )</h3>
+<p>'delay' is used to convert a value or expression into a promise.
+ The word 'force' is used to convert that promise back to its
+ value, or to force evaluation of the expression to return a value.
+</p>
+<p>The value on the stack that 'delay' expects must be quoted. This is
+ a requirement to prevent it from being evaluated.
+</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ 42 ] [ ] [ ] >>
+ ( 2 ) <a href="#force">force</a> .
+ => 42
+</pre>
+
+<!-- force description -->
+<a name="force">
+<h3>force ( <promise> -- value )</h3>
+<p>'force' will evaluate a promises original expression
+ and leave the value of that expression on the stack.
+</p>
+<p>A promise can be forced multiple times but the expression
+ is only evaluated once. Future calls of 'force' on the promise
+ will returned the cached value of the original force. If the
+ expression contains side effects, such as i/o, then that i/o
+ will only occur on the first 'force'. See below for an example
+ (steps 3-5).
+</p>
+<p>If a promise is itself delayed, a force will evaluate all promises
+ until a value is returned. Due to this behaviour it is generally not
+ possible to delay a promise. The example below shows what happens
+ in this case.
+</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ 42 ] [ ] [ ] >>
+ ( 2 ) <a href="#force">force</a> .
+ => 42
+
+ #! Multiple forces on a promise returns cached value
+ ( 3 ) [ "hello" print 42 ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ "hello" print 42 ] [ ] [ ] >>
+ ( 4 ) dup <a href="#force">force</a> .
+ => hello
+ 42
+ ( 5 ) <a href="#force">force</a> .
+ => 42
+
+ #! Forcing a delayed promise cascades up to return
+ #! original value, rather than the promise.
+ ( 6 ) [ [ 42 ] <a href="#delay">delay</a> ] <a href="#delay">delay</a> dup .
+ => << promise [ ] [ [ 42 ] delay ] [ ] [ ] >>
+ ( 7 ) <a href="#force">force</a> .
+ => 42
+</pre>
+
+<!-- lnil description -->
+<a name="lnil">
+<h3>lnil ( -- lcons )</h3>
+<p>Returns a value representing the empty lazy list.</p>
+<pre class="code">
+ ( 1 ) <a href="#lnil">lnil</a> .
+ => << promise [ ] [ [ ] ] t [ ] >>
+</pre>
+
+<!-- lnil description -->
+<a name="lnilp">
+<h3>lnil? ( lcons -- bool )</h3>
+<p>Returns true if the given lazy cons is the value representing
+ the empty lazy list.</p>
+<pre class="code">
+ ( 1 ) <a href="#lnil">lnil</a> <a href="#lnilp">lnil?</a> .
+ => t
+ ( 2 ) [ 1 ] <a href="#list2llist">list>llist</a> dup <a href="#lnilp">lnil?</a> .
+ => [ ]
+ ( 3 ) <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
+ => t
+</pre>
+
+<!-- lcons description -->
+<a name="lcons">
+<h3>lcons ( car-promise cdr-promise -- lcons )</h3>
+<p>Provides the same effect as 'cons' does for normal lists.
+ Both values provided must be promises (ie. expressions that have
+ had <a href="#delay">delay</a> called on them).
+</p>
+<p>As the car and cdr passed on the stack are promises, they are not
+ evaluated until <a href="#lcar">lcar</a> or <a href="#lcdr">lcdr</a>
+ are called on the lazy cons.</p>
+<pre class="code">
+ ( 1 ) [ "car" ] <a href="#delay">delay</a> [ "cdr" ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) dup <a href="#lcar">lcar</a> .
+ => "car"
+ ( 3 ) dup <a href="#lcdr">lcdr</a> .
+ => "cdr"
+</pre>
+
+<!-- lunit description -->
+<a name="lunit">
+<h3>lunit ( value-promise -- llist )</h3>
+<p>Provides the same effect as 'unit' does for normal lists. It
+creates a lazy list where the first element is the value given.</p>
+<p>Like <a href="#lcons">lcons</a>, the value on the stack must be
+ a promise and is not evaluated until the <a href="#lcar">lcar</a>
+ of the list is requested.</a>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
+ => << promise ... >>
+ ( 2 ) dup <a href="#lcar">lcar</a> .
+ => 42
+ ( 3 ) dup <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
+ => t
+ ( 4 ) [ . ] <a href="#leach">leach</a>
+ => 42
+</pre>
+
+<!-- lcar description -->
+<a name="lcar">
+<h3>lcar ( lcons -- value )</h3>
+<p>Provides the same effect as 'car' does for normal lists. It
+returns the first element in a lazy cons cell. This will force
+the evaluation of that element.</p>
+<pre class="code">
+ ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcar">lcar</a> .
+ => 42
+</pre>
+
+<!-- lcdr description -->
+<a name="lcdr">
+<h3>lcdr ( lcons -- value )</h3>
+<p>Provides the same effect as 'cdr' does for normal lists. It
+returns the second element in a lazy cons cell and forces it. This
+causes that element to be evaluated immediately.</p>
+<pre class="code">
+ ( 1 ) [ 1 ] <a href="#delay">delay</a> [ 5 6 + ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcdr">lcdr</a> .
+ => 11
+</pre>
+
+<pre class="code">
+ ( 1 ) 5 <a href="#lfrom">lfrom</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 6
+ ( 3 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 7
+ ( 4 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
+ => 8
+</pre>
+
+<!-- lnth description -->
+<a name="lnth">
+<h3>lnth ( n llist -- value )</h3>
+<p>Provides the same effect as 'nth' does for normal lists. It
+returns the nth value in the lazy list. It causes all the values up to
+'n' to be evaluated.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a> dup .
+ => << promise ... >>
+ ( 2 ) 5 swap <a href="#lnth">lnth</a> .
+ => 6
+</pre>
+
+<!-- luncons description -->
+<a name="luncons">
+<h3>luncons ( lcons -- car cdr )</h3>
+<p>Provides the same effect as 'uncons' does for normal lists. It
+returns the car and cdr of the lazy list.</p>
+<pre class="code">
+ ( 1 ) [ 5 ] <a href="#delay">delay</a> [ 6 ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
+ => << promise ... >>
+ ( 2 ) <a href="#luncons">luncons</a> . .
+ => 6
+ 5
+</pre>
+
+<!-- lmap description -->
+<a name="lmap">
+<h3>lmap ( llist quot -- llist )</h3>
+<p>Lazily maps over a lazy list applying the quotation to each element.
+A new lazy list is returned which contains the results of the
+quotation.</p>
+<p>When intially called nothing in the original lazy list is
+evaluated. Only when <a href="#lcar">lcar</a> is called will the item
+in the list be evaluated and applied to the quotation. Ditto with <a
+href="#lcdr">lcdr</a>, thus allowing infinite lists to be mapped over.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ 2 * ] <a href="#lmap">lmap</a>
+ => < infinite list of numbers incrementing by 2 >
+ ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 2 4 6 8 10 ]
+</pre>
+
+<!-- lsubset description -->
+<a name="lsubset">
+<h3>lsubset ( llist pred -- llist )</h3>
+<p>Provides the same effect as 'subset' does for normal lists. It
+lazily iterates over a lazy list applying the predicate quotation to each
+element. If that quotation returns true, the element will be included
+in the resulting lazy list. If it is false, the element will be skipped.
+A new lazy list is returned which contains all elements where the
+predicate returned true.</p>
+<p>Like <a href="#lmap">lmap</a>, when initially called no evaluation
+will occur. A lazy list is returned that when values are retrieved
+from in then items are evaluated and checked against the predicate.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ <a href="#primep">prime?</a> ] <a href="#lsubset">lsubset</a>
+ => < infinite list of prime numbers >
+ ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 2 3 5 7 11 ]
+</pre>
+
+<!-- leach description -->
+<a name="leach">
+<h3>leach ( llist quot -- )</h3>
+<p>Provides the same effect as 'each' does for normal lists. It
+lazily iterates over a lazy list applying the quotation to each
+element. If this operation is applied to an infinite list it will
+never return unless the quotation escapes out by calling a continuation.</p>
+<pre class="code">
+ ( 1 ) 1 <a href="#lfrom">lfrom</a>
+ => < infinite list of incrementing numbers >
+ ( 2 ) [ 2 mod 1 = ] <a href="#lsubset">lsubset</a>
+ => < infinite list of odd numbers >
+ ( 3 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 3
+ 5
+ 7
+ ... for ever ...
+</pre>
+
+<!-- ltake description -->
+<a name="ltake">
+<h3>ltake ( n llist -- llist )</h3>
+<p>Iterates over the lazy list 'n' times, appending each element to a
+lazy list. This provides a convenient way of getting elements out of
+an infinite lazy list.</p>
+<pre class="code">
+ ( 1 ) : ones [ 1 ] delay [ ones ] delay <a href="#lcons">lcons</a> ;
+ ( 2 ) 5 ones <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
+ => [ 1 1 1 1 1 ]
+</pre>
+
+<!-- lappend description -->
+<a name="lappend">
+<h3>lappend ( llist1 llist2 -- llist )</h3>
+<p>Lazily appends two lists together. The actual appending is done
+lazily on iteration rather than immediately so it works very fast no
+matter how large the list.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a> [ 4 5 6 ] <a href="#list2llist">list>llist</a> <a href="#lappend">lappend</a>
+ ( 2 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+ 4
+ 5
+ 6
+</pre>
+
+<!-- lappend* description -->
+<a name="lappendstar">
+<h3>lappend* ( llists -- llist )</h3>
+<p>Given a lazy list of lazy lists, concatenate them together in a
+lazy fashion. The actual appending is done lazily on iteration rather
+than immediately so it works very fast no matter how large the lists.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2>llist">list>llist</a>
+ ( 2 ) [ 4 5 6 ] <a href="#list2llist">list>llist</a>
+ ( 3 ) [ 7 8 9 ] <a href="#list2llist">list>llist</a>
+ ( 4 ) 3list <a href="#list2llist">list>llist</a> <a href="#lappendstar">lappend*</a>
+ ( 5 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+ 4
+ 5
+ 6
+ 7
+ 8
+ 9
+</pre>
+
+<!-- list>llist description -->
+<a name="list2llist">
+<h3>list>llist ( list -- llist )</h3>
+<p>Converts a normal list into a lazy list. This is done lazily so the
+initial list is not iterated through immediately.</p>
+<pre class="code">
+ ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a>
+ ( 2 ) [ . ] <a href="#leach">leach</a>
+ => 1
+ 2
+ 3
+</pre>
+
+<p class="footer">
+News and updates to this software can be obtained from the authors
+weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
+<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
+</body> </html>
--- /dev/null
+Lazy lists
--- /dev/null
+extensions
+collections
--- /dev/null
+! Copyright (C) 2006 Chris Double.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel help.markup help.syntax arrays sequences math quotations ;
+IN: lists
+
+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 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" } ;
+
+HELP: nil?
+{ $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." } ;
+
+{ 1list 2list 3list } related-words
+
+HELP: 1list
+{ $values { "obj" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 1 element." } ;
+
+HELP: 2list
+{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
+{ $description "Create a list with 2 elements." } ;
+
+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 llength cons car cdr } ;
+
+HELP: llength
+{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
+{ $description "Outputs the length of the list. This should not be called on an infinite list." }
+{ $see-also lnth cons car cdr } ;
+
+HELP: uncons
+{ $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: leach
+{ $values { "list" "a cons object" } { "quot" { $quotation "( obj -- )" } } }
+{ $description "Call the quotation for each item in the list." } ;
+
+HELP: foldl
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
+{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
+
+HELP: foldr
+{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
+{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
+
+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" 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: sequence>cons
+{ $values { "sequence" sequence } { "list" cons } }
+{ $description "Turns the given array into a cons object, maintaing order." } ;
+
+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: 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." } ;
+
+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." } ;
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test lists math kernel ;
+IN: lists.tests
+
+{ { 3 4 5 6 7 } } [
+ { 1 2 3 4 5 } sequence>cons [ 2 + ] lmap list>array
+] unit-test
+
+{ { 3 4 5 6 } } [
+ T{ cons f 1
+ T{ cons f 2
+ T{ cons f 3
+ T{ cons f 4
+ +nil+ } } } } [ 2 + ] lmap>array
+] unit-test
+
+{ 10 } [
+ T{ cons f 1
+ T{ cons f 2
+ T{ cons f 3
+ T{ cons f 4
+ +nil+ } } } } 0 [ + ] foldl
+] unit-test
+
+{ T{ cons f
+ 1
+ T{ cons f
+ 2
+ T{ cons f
+ T{ cons f
+ 3
+ T{ cons f
+ 4
+ T{ cons f
+ T{ cons f 5 +nil+ }
+ +nil+ } } }
+ +nil+ } } }
+} [
+ { 1 2 { 3 4 { 5 } } } deep-sequence>cons
+] unit-test
+
+{ { 1 2 { 3 4 { 5 } } } } [
+ { 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 } sequence>cons [ 1+ ] lmap
+] unit-test
+
+{ 15 } [
+ { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr
+] unit-test
+
+{ { 5 4 3 2 1 } } [
+ { 1 2 3 4 5 } sequence>cons lreverse list>array
+] unit-test
+
+{ 5 } [
+ { 1 2 3 4 5 } sequence>cons llength
+] unit-test
+
+{ { 3 4 { 5 6 { 7 } } } } [
+ { 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 } 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
--- /dev/null
+! Copyright (C) 2008 James Cash
+! See http://factorcode.org/license.txt for BSD license.
+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 -- ? )
+
+TUPLE: cons { car read-only } { cdr read-only } ;
+
+C: cons cons
+
+M: cons car ( cons -- car )
+ car>> ;
+
+M: cons cdr ( cons -- cdr )
+ cdr>> ;
+
+SINGLETON: +nil+
+M: +nil+ nil? drop t ;
+M: object nil? drop f ;
+
+: atom? ( obj -- ? )
+ list? not ;
+
+: nil ( -- symbol ) +nil+ ;
+
+: 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 ( list -- elt )
+ cdr car ;
+
+: 2car ( list -- car caar )
+ [ car ] [ cdr car ] bi ;
+
+: 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
+
+: lmap ( list quot: ( elt -- ) -- result )
+ over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive
+
+: foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result )
+ swapd leach ; inline
+
+:: 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 ;
+
+: 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@ = ;
+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 )
+ list [| elt |
+ elt dup pred call [ quot call ] when
+ dup list? [ pred quot traverse ] when
+ ] lmap ; inline recursive
+
+INSTANCE: cons list
+INSTANCE: +nil+ list
--- /dev/null
+Implementation of lisp-style linked lists
--- /dev/null
+collections
+++ /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 ;
-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
-TUPLE: cons { car read-only } { cdr read-only } ;
-C: <cons> cons
-
-: 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>> <cons> ] [ back>> ] bi deque boa ; inline
+ [ front>> cons ] [ back>> ] bi deque boa ; inline
PRIVATE>
: push-front ( deque item -- newdeque )
<PRIVATE
: remove ( deque -- item newdeque )
- [ front>> car>> ] [ [ front>> cdr>> ] [ back>> ] bi deque boa ] bi ; inline
+ [ 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? [
models models.delay namespaces parser lexer prettyprint
quotations sequences strings threads listener classes.tuple
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
-ui.gadgets.presentations ui.gadgets.worlds ui.gestures
+ui.gadgets.presentations ui.gadgets.worlds ui.gestures call
definitions calendar concurrency.flags concurrency.mailboxes
ui.tools.workspace accessors sets destructors fry vocabs.parser ;
IN: ui.tools.interactor
mailbox>> mailbox-put ;
: clear-input ( interactor -- )
- #! The with-datastack is a kludge to make it infer. Stupid.
- model>> 1array [ clear-doc ] with-datastack drop ;
+ model>> [ clear-doc ] call( model -- ) ;
: interactor-finish ( interactor -- )
[ editor-string ] keep
dlists deques sequences threads sequences words ui.gadgets
ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend
ui.render continuations init combinators hashtables
-concurrency.flags sets accessors calendar ;
+concurrency.flags sets accessors calendar call ;
IN: ui
! Assoc mapping aliens to gadgets
layout-queued
redraw-worlds
send-queued-gestures
- ] assert-depth
+ ] call( -- )
] [ ui-error ] recover ;
SYMBOL: ui-thread
{ $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"
}
} ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup strings math ;
+IN: wrap.strings
+
+ABOUT: "wrap.strings"
+
+ARTICLE: "wrap.strings" "String word wrapping"
+"The " { $vocab-link "wrap.strings" } " vocabulary implements word wrapping for simple strings, assumed to be in monospace font."
+{ $subsection wrap-lines }
+{ $subsection wrap-string }
+{ $subsection wrap-indented-string } ;
+
+HELP: wrap-lines
+{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } }
+{ $description "Given a string, divides it into a sequence of lines where each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
+
+HELP: wrap-string
+{ $values { "string" string } { "width" integer } { "newstring" string } }
+{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
+
+HELP: wrap-indented-string
+{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } }
+{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ;
+
--- /dev/null
+! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: wrap.strings tools.test multiline ;
+IN: wrap.strings.tests
+
+[
+ <" This is a
+long piece
+of text
+that we
+wish to
+word wrap.">
+] [
+ <" This is a long piece of text that we wish to word wrap."> 10
+ wrap-string
+] unit-test
+
+[
+ <" This is a
+ long piece
+ of text
+ that we
+ wish to
+ word wrap.">
+] [
+ <" This is a long piece of text that we wish to word wrap."> 12
+ " " wrap-indented-string
+] unit-test
+
+[ "this text\nhas lots of\nspaces" ]
+[ "this text has lots of spaces" 12 wrap-string ] unit-test
+
+[ "hello\nhow\nare\nyou\ntoday?" ]
+[ "hello how are you today?" 3 wrap-string ] unit-test
+
+[ "aaa\nbb cc\nddddd" ] [ "aaa bb cc ddddd" 6 wrap-string ] unit-test
+[ "aaa\nbb ccc\ndddddd" ] [ "aaa bb ccc dddddd" 6 wrap-string ] unit-test
+[ "aaa bb\ncccc\nddddd" ] [ "aaa bb cccc ddddd" 6 wrap-string ] unit-test
+[ "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
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: wrap kernel sequences fry splitting math ;
+IN: wrap.strings
+
+<PRIVATE
+
+: split-lines ( string -- elements-lines )
+ string-lines [
+ " \t" split harvest
+ [ dup length 1 <element> ] map
+ ] map ;
+
+: join-elements ( wrapped-lines -- lines )
+ [ " " join ] map ;
+
+: join-lines ( strings -- string )
+ "\n" join ;
+
+PRIVATE>
+
+: wrap-lines ( lines width -- newlines )
+ [ split-lines ] dip '[ _ dup wrap join-elements ] map concat ;
+
+: wrap-string ( string width -- newstring )
+ wrap-lines join-lines ;
+
+: wrap-indented-string ( string width indent -- newstring )
+ [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.syntax help.markup math kernel ;
+IN: wrap.words
+
+ABOUT: "wrap.words"
+
+ARTICLE: "wrap.words" "Word object wrapping"
+"The " { $vocab-link "wrap.words" } " vocabulary implements word wrapping on abstract word objects, which have certain properties making it a more suitable input representation than strings."
+{ $subsection wrap-words }
+{ $subsection word }
+{ $subsection <word> } ;
+
+HELP: wrap-words
+{ $values { "words" { "a sequence of " { $instance word } "s" } } { "line-max" integer } { "line-ideal" integer } { "lines" "a sequence of sequences of words" } }
+{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given maximum. The returned set of lines is optimized to minimize the square of the deviation of each line from the ideal width. It is not guaranteed to be the minimal number of lines. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ;
+
+HELP: word
+{ $class-description "A word is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link <word> } "." }
+{ $see-also wrap-words } ;
+
+HELP: <word>
+{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } }
+{ $description "Creates a " { $link word } " object with the given parameters." }
+{ $see-also wrap-words } ;
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test wrap.words sequences ;
+IN: wrap.words.tests
+
+[
+ {
+ {
+ T{ word f 1 10 f }
+ T{ word f 2 10 f }
+ T{ word f 3 2 t }
+ }
+ {
+ T{ word f 4 10 f }
+ T{ word f 5 10 f }
+ }
+ }
+] [
+ {
+ T{ word f 1 10 f }
+ T{ word f 2 10 f }
+ T{ word f 3 2 t }
+ T{ word f 4 10 f }
+ T{ word f 5 10 f }
+ } 35 35 wrap-words [ { } like ] map
+] unit-test
+
+[
+ {
+ {
+ T{ word f 1 10 f }
+ T{ word f 2 10 f }
+ T{ word f 3 9 t }
+ T{ word f 3 9 t }
+ T{ word f 3 9 t }
+ }
+ {
+ T{ word f 4 10 f }
+ T{ word f 5 10 f }
+ }
+ }
+] [
+ {
+ T{ word f 1 10 f }
+ T{ word f 2 10 f }
+ T{ word f 3 9 t }
+ T{ word f 3 9 t }
+ T{ word f 3 9 t }
+ T{ word f 4 10 f }
+ T{ word f 5 10 f }
+ } 35 35 wrap-words [ { } like ] map
+] unit-test
+
+[
+ {
+ {
+ T{ word f 1 10 t }
+ T{ word f 1 10 f }
+ T{ word f 3 9 t }
+ }
+ {
+ T{ word f 2 10 f }
+ T{ word f 3 9 t }
+ }
+ {
+ T{ word f 4 10 f }
+ T{ word f 5 10 f }
+ }
+ }
+] [
+ {
+ T{ word f 1 10 t }
+ T{ word f 1 10 f }
+ T{ word f 3 9 t }
+ T{ word f 2 10 f }
+ T{ word f 3 9 t }
+ T{ word f 4 10 f }
+ T{ word f 5 10 f }
+ } 35 35 wrap-words [ { } like ] map
+] unit-test
+
+\ wrap-words must-infer
--- /dev/null
+! Copyright (C) 2009 Daniel Ehrenberg
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel splitting.monotonic accessors grouping wrap ;
+IN: wrap.words
+
+TUPLE: word key width break? ;
+C: <word> word
+
+<PRIVATE
+
+: words-length ( words -- length )
+ [ width>> ] map sum ;
+
+: make-element ( whites blacks -- element )
+ [ append ] [ [ words-length ] bi@ ] 2bi <element> ;
+
+: ?first2 ( seq -- first/f second/f )
+ [ 0 swap ?nth ]
+ [ 1 swap ?nth ] bi ;
+
+: split-words ( seq -- half-elements )
+ [ [ break?>> ] bi@ = ] monotonic-split ;
+
+: ?first-break ( seq -- newseq f/element )
+ dup first first break?>>
+ [ unclip-slice f swap make-element ]
+ [ f ] if ;
+
+: make-elements ( seq f/element -- elements )
+ [ 2 <groups> [ ?first2 make-element ] map ] dip
+ [ prefix ] when* ;
+
+: words>elements ( seq -- newseq )
+ split-words ?first-break make-elements ;
+
+PRIVATE>
+
+: wrap-words ( words line-max line-ideal -- lines )
+ [ words>elements ] 2dip wrap [ concat ] map ;
+
ABOUT: "wrap"
ARTICLE: "wrap" "Word wrapping"
-"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. There is support for simple string wrapping, with the following words:"
-{ $subsection wrap-lines }
-{ $subsection wrap-string }
-{ $subsection wrap-indented-string }
-"Additionally, the vocabulary provides capabilities to wrap arbitrary groups of things, in units called words."
-{ $subsection wrap }
-{ $subsection word }
-{ $subsection <word> } ;
-
-HELP: wrap-lines
-{ $values { "lines" string } { "width" integer } { "newlines" "sequence of strings" } }
-{ $description "Given a string, divides it into a sequence of lines where each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
-
-HELP: wrap-string
-{ $values { "string" string } { "width" integer } { "newstring" string } }
-{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space." } ;
-
-HELP: wrap-indented-string
-{ $values { "string" string } { "width" integer } { "indent" string } { "newstring" string } }
-{ $description "Given a string, alters the whitespace in the string so that each line has no more than " { $snippet "width" } " characters, unless there is a word longer than " { $snippet "width" } ". Linear whitespace between words is converted to a single space. Before each line, the indent string is added." } ;
-
-HELP: wrap
-{ $values { "words" { "a sequence of " { $instance word } "s" } } { "width" integer } { "lines" "a sequence of sequences of words" } }
-{ $description "Divides the words into lines, where the sum of the lengths of the words on a line (not counting breaks at the end of the line) is at most the given width. Every line except for the first one starts with a non-break, and every one but the last ends with a break." } ;
-
-HELP: word
-{ $class-description "A word, for the purposes of " { $vocab-link "wrap" } ", is a Factor object annotated with a length (in the " { $snippet "width" } " slot) and knowledge about whether it is an allowable position for an optional line break (in the " { $snippet "break?" } " slot). Words can be created with " { $link <word> } "." }
-{ $see-also wrap } ;
-
-HELP: <word>
-{ $values { "key" object } { "width" integer } { "break?" { { $link t } " or " { $link POSTPONE: f } } } { "word" word } }
-{ $description "Creates a " { $link word } " object with the given parameters." }
-{ $see-also wrap } ;
+"The " { $vocab-link "wrap" } " vocabulary implements word wrapping. Wrapping can take place based on simple strings, assumed to be monospace, or abstract word objects."
+{ $vocab-subsection "String word wrapping" "wrap.strings" }
+{ $vocab-subsection "Word object wrapping" "wrap.words" } ;
+++ /dev/null
-! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test wrap multiline sequences ;
-IN: wrap.tests
-
-[
- {
- {
- T{ word f 1 10 f }
- T{ word f 2 10 f }
- T{ word f 3 2 t }
- }
- {
- T{ word f 4 10 f }
- T{ word f 5 10 f }
- }
- }
-] [
- {
- T{ word f 1 10 f }
- T{ word f 2 10 f }
- T{ word f 3 2 t }
- T{ word f 4 10 f }
- T{ word f 5 10 f }
- } 35 wrap [ { } like ] map
-] unit-test
-
-[
- {
- {
- T{ word f 1 10 f }
- T{ word f 2 10 f }
- T{ word f 3 9 t }
- T{ word f 3 9 t }
- T{ word f 3 9 t }
- }
- {
- T{ word f 4 10 f }
- T{ word f 5 10 f }
- }
- }
-] [
- {
- T{ word f 1 10 f }
- T{ word f 2 10 f }
- T{ word f 3 9 t }
- T{ word f 3 9 t }
- T{ word f 3 9 t }
- T{ word f 4 10 f }
- T{ word f 5 10 f }
- } 35 wrap [ { } like ] map
-] unit-test
-
-[
- <" This is a
-long piece
-of text
-that we
-wish to
-word wrap.">
-] [
- <" This is a long piece of text that we wish to word wrap."> 10
- wrap-string
-] unit-test
-
-[
- <" This is a
- long piece
- of text
- that we
- wish to
- word wrap.">
-] [
- <" This is a long piece of text that we wish to word wrap."> 12
- " " wrap-indented-string
-] unit-test
-
-[ "this text\nhas lots of\nspaces" ]
-[ "this text has lots of spaces" 12 wrap-string ] unit-test
-
-[ "hello\nhow\nare\nyou\ntoday?" ]
-[ "hello how are you today?" 3 wrap-string ] unit-test
-! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov
+! Copyright (C) 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: sequences kernel namespaces make splitting
-math math.order fry assocs accessors ;
+USING: kernel sequences math arrays locals fry accessors
+lists splitting call make combinators.short-circuit namespaces
+grouping splitting.monotonic ;
IN: wrap
-! Word wrapping/line breaking -- not Unicode-aware
+! black is the text length, white is the whitespace length
+TUPLE: element contents black white ;
+C: <element> element
-TUPLE: word key width break? ;
+: element-length ( element -- n )
+ [ black>> ] [ white>> ] bi + ;
-C: <word> word
+TUPLE: paragraph lines head-width tail-cost ;
+C: <paragraph> paragraph
-<PRIVATE
+SYMBOL: line-max
+SYMBOL: line-ideal
-SYMBOL: width
+: deviation ( length -- n )
+ line-ideal get - sq ;
-: break-here? ( column word -- ? )
- break?>> not [ width get > ] [ drop f ] if ;
+: top-fits? ( paragraph -- ? )
+ [ head-width>> ]
+ [ lines>> 1list? line-ideal line-max ? get ] bi <= ;
-: walk ( n words -- n )
- ! If on a break, take the rest of the breaks
- ! If not on a break, go back until you hit a break
- 2dup bounds-check? [
- 2dup nth break?>>
- [ [ break?>> not ] find-from drop ]
- [ [ break?>> ] find-last-from drop 1+ ] if
- ] [ drop ] if ;
+: fits? ( paragraph -- ? )
+ ! Make this not count spaces at end
+ { [ lines>> car 1list? ] [ top-fits? ] } 1|| ;
-: find-optimal-break ( words -- n )
- [ 0 ] keep
- [ [ width>> + dup ] keep break-here? ] find drop nip
- [ 1 max swap walk ] [ drop f ] if* ;
+:: min-by ( seq quot -- elt )
+ f 1.0/0.0 seq [| key value new |
+ new quot call :> newvalue
+ newvalue value < [ new newvalue ] [ key value ] if
+ ] each drop ; inline
-: (wrap) ( words -- )
- [
- dup find-optimal-break
- [ cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if*
- ] unless-empty ;
-
-: intersperse ( seq elt -- seq' )
- [ '[ _ , ] [ , ] interleave ] { } make ;
+: paragraph-cost ( paragraph -- cost )
+ dup lines>> 1list? [ drop 0 ] [
+ [ head-width>> deviation ]
+ [ tail-cost>> ] bi +
+ ] if ;
-: split-lines ( string -- words-lines )
- string-lines [
- " \t" split harvest
- [ dup length f <word> ] map
- " " 1 t <word> intersperse
- ] map ;
+: min-cost ( paragraphs -- paragraph )
+ [ paragraph-cost ] min-by ;
-: join-words ( wrapped-lines -- lines )
- [
- [ break?>> ] trim-slice
- [ key>> ] map concat
- ] map ;
+: new-line ( paragraph element -- paragraph )
+ [ [ lines>> ] [ 1list ] bi* swons ]
+ [ nip black>> ]
+ [ drop paragraph-cost ] 2tri
+ <paragraph> ;
-: join-lines ( strings -- string )
- "\n" join ;
+: glue ( paragraph element -- paragraph )
+ [ [ lines>> unswons ] dip swons swons ]
+ [ [ head-width>> ] [ element-length ] bi* + ]
+ [ drop tail-cost>> ] 2tri
+ <paragraph> ;
-PRIVATE>
+: wrap-step ( paragraphs element -- paragraphs )
+ [ '[ _ glue ] map ]
+ [ [ min-cost ] dip new-line ]
+ 2bi prefix
+ [ fits? ] filter ;
-: wrap ( words width -- lines )
- width [
- [ (wrap) ] { } make
- ] with-variable ;
+: 1paragraph ( element -- paragraph )
+ [ 1list 1list ]
+ [ black>> ] bi
+ 0 <paragraph> ;
-: wrap-lines ( lines width -- newlines )
- [ split-lines ] dip '[ _ wrap join-words ] map concat ;
+: post-process ( paragraph -- array )
+ lines>> deep-list>array
+ [ [ contents>> ] map ] map ;
-: wrap-string ( string width -- newstring )
- wrap-lines join-lines ;
+: initialize ( elements -- elements paragraph )
+ <reversed> unclip-slice 1paragraph 1array ;
-: wrap-indented-string ( string width indent -- newstring )
- [ length - wrap-lines ] keep '[ _ prepend ] map join-lines ;
+: wrap ( elements line-max line-ideal -- paragraph )
+ [
+ line-ideal set
+ line-max set
+ initialize
+ [ wrap-step ] reduce
+ min-cost
+ post-process
+ ] with-scope ;
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
! See http://factorcode.org/license.txt for BSD license.\r
USING: hashtables kernel math namespaces sequences strings\r
assocs combinators io io.streams.string accessors\r
-xml.data wrap xml.entities unicode.categories fry ;\r
+xml.data wrap.strings xml.entities unicode.categories fry ;\r
IN: xml.writer\r
\r
SYMBOL: sensitive-tags\r
! 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 ( -- )
-USING: tools.test io.files io.files.private io.files.temp
-io.directories io.encodings.8-bit arrays make system
-io.encodings.binary io threads kernel continuations
-io.encodings.ascii sequences strings accessors
-io.encodings.utf8 math destructors namespaces ;
+USING: arrays debugger.threads destructors io io.directories
+io.encodings.8-bit io.encodings.ascii io.encodings.binary
+io.files io.files.private io.files.temp io.files.unique kernel
+make math sequences system threads tools.test ;
IN: io.files.tests
\ exists? must-infer
[ t ] [ "quux-test.txt" temp-file exists? ] unit-test
[ ] [ "quux-test.txt" temp-file delete-file ] unit-test
+
+! File seeking tests
+[ B{ 3 2 3 4 5 } ]
+[
+ "seek-test1" unique-file binary
+ [
+ [
+ B{ 1 2 3 4 5 } write 0 seek-absolute seek-output
+ B{ 3 } write
+ ] with-file-writer
+ ] [
+ file-contents
+ ] 2bi
+] unit-test
+
+[ B{ 1 2 3 4 3 } ]
+[
+ "seek-test2" unique-file binary
+ [
+ [
+ B{ 1 2 3 4 5 } write -1 seek-relative seek-output
+ B{ 3 } write
+ ] with-file-writer
+ ] [
+ file-contents
+ ] 2bi
+] unit-test
+
+[ B{ 1 2 3 4 5 0 3 } ]
+[
+ "seek-test3" unique-file binary
+ [
+ [
+ B{ 1 2 3 4 5 } write 1 seek-relative seek-output
+ B{ 3 } write
+ ] with-file-writer
+ ] [
+ file-contents
+ ] 2bi
+] unit-test
+
+[ B{ 3 } ]
+[
+ B{ 1 2 3 4 5 } "seek-test4" unique-file binary [
+ set-file-contents
+ ] [
+ [
+ -3 seek-end seek-input 1 read
+ ] with-file-reader
+ ] 2bi
+] unit-test
+
+[ B{ 2 } ]
+[
+ B{ 1 2 3 4 5 } "seek-test5" unique-file binary [
+ set-file-contents
+ ] [
+ [
+ 3 seek-absolute seek-input
+ -2 seek-relative seek-input
+ 1 read
+ ] with-file-reader
+ ] 2bi
+] unit-test
+
+[
+ "seek-test6" unique-file binary [
+ -10 seek-absolute seek-input
+ ] with-file-reader
+] must-fail
{ $description "Copies the contents of one stream into another, closing both streams when done." }
$io-error ;
+
+HELP: stream-seek
+{ $values
+ { "n" integer } { "seek-type" "a seek singleton" } { "stream" "a stream" }
+}
+{ $description "Moves the pointer associated with a stream's handle to an offset " { $snippet "n" } " bytes from the seek type so that further reading or writing happens at the new location. For output streams, the buffer is flushed before seeking. Seeking past the end of an output stream will pad the difference with zeros once the stream is written to again." $nl
+ "Three methods of seeking are supported:"
+ { $list { $link seek-absolute } { $link seek-relative } { $link seek-end } }
+}
+{ $notes "Stream seeking is not supported on streams that do not have a known length, e.g. TCP/IP streams." } ;
+
+HELP: seek-absolute
+{ $values
+
+ { "value" "a seek singleton" }
+}
+{ $description "Seeks to an offset from the beginning of the stream." } ;
+
+HELP: seek-end
+{ $values
+
+ { "value" "a seek singleton" }
+}
+{ $description "Seeks to an offset from the end of the stream. If the offset puts the stream pointer past the end of the data on an output stream, writing to it will pad the difference with zeros." } ;
+
+HELP: seek-relative
+{ $values
+
+ { "value" "a seek singleton" }
+}
+{ $description "Seeks to an offset from the current position of the stream pointer." } ;
+
+
+HELP: seek-input
+{ $values
+ { "n" integer } { "seek-type" "a seek singleton" }
+}
+{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link input-stream } "." } ;
+
+HELP: seek-output
+{ $values
+ { "n" integer } { "seek-type" "a seek singleton" }
+}
+{ $description "Calls " { $link stream-seek } " on the stream stored in " { $link output-stream } "." } ;
+
HELP: input-stream
{ $var-description "Holds an input stream for various implicit stream operations. Rebound using " { $link with-input-stream } " and " { $link with-input-stream* } "." } ;
{ $subsection stream-write }
"This word is only required for string output streams:"
{ $subsection stream-nl }
+"This word is for streams that allow seeking:"
+{ $subsection stream-seek }
"For a discussion of the distinction between binary and string streams, see " { $link "stream-elements" } "."
{ $see-also "io.timeouts" } ;
{ $subsection read-partial }
"If the default input stream is a string stream (" { $link "stream-elements" } "), lines of text can be read:"
{ $subsection readln }
+"Seeking on the default input stream:"
+{ $subsection seek-input }
"A pair of combinators for rebinding the " { $link input-stream } " variable:"
{ $subsection with-input-stream }
{ $subsection with-input-stream* }
{ $subsection output-stream }
"Unless rebound in a child namespace, this variable will be set to a console stream for showing output to the user."
$nl
-"Words writing to the default input stream:"
+"Words writing to the default output stream:"
{ $subsection flush }
{ $subsection write1 }
{ $subsection write }
{ $subsection print }
{ $subsection nl }
{ $subsection bl }
+"Seeking on the default output stream:"
+{ $subsection seek-output }
"A pair of combinators for rebinding the " { $link output-stream } " variable:"
{ $subsection with-output-stream }
{ $subsection with-output-stream* }
-USING: arrays io io.files kernel math parser strings system
-tools.test words namespaces make io.encodings.8-bit
-io.encodings.binary sequences io.files.unique ;
+USING: io parser tools.test words ;
IN: io.tests
[ f ] [
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
-
-[ B{ 3 2 3 4 5 } ]
-[
- "seek-test1" unique-file binary
- [
- [
- B{ 1 2 3 4 5 } write flush 0 seek-absolute seek-output
- B{ 3 } write
- ] with-file-writer
- ] [
- file-contents
- ] 2bi
-] unit-test
-
-[ B{ 1 2 3 4 3 } ]
-[
- "seek-test2" unique-file binary
- [
- [
- B{ 1 2 3 4 5 } write flush -1 seek-relative seek-output
- B{ 3 } write
- ] with-file-writer
- ] [
- file-contents
- ] 2bi
-] unit-test
-
-[ B{ 1 2 3 4 5 0 3 } ]
-[
- "seek-test3" unique-file binary
- [
- [
- B{ 1 2 3 4 5 } write flush 1 seek-relative seek-output
- B{ 3 } write
- ] with-file-writer
- ] [
- file-contents
- ] 2bi
-] unit-test
-
-[ B{ 3 } ]
-[
- B{ 1 2 3 4 5 } "seek-test4" unique-file binary [
- set-file-contents
- ] [
- [
- -3 seek-end seek-input 1 read
- ] with-file-reader
- ] 2bi
-] unit-test
-
-[ B{ 2 } ]
-[
- B{ 1 2 3 4 5 } "seek-test5" unique-file binary [
- set-file-contents
- ] [
- [
- 3 seek-absolute seek-input
- -2 seek-relative seek-input
- 1 read
- ] with-file-reader
- ] 2bi
-] unit-test
"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 [
{ $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ;
HELP: GENERIC:
-{ $syntax "GENERIC: word" }
+{ $syntax "GENERIC: word" "GENERIC: word ( stack -- effect )" }
{ $values { "word" "a new word to define" } }
{ $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ;
HELP: GENERIC#
-{ $syntax "GENERIC# word n" }
+{ $syntax "GENERIC# word n" "GENERIC# word n ( stack -- effect )" }
{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } }
{ $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
{ $notes
{ $description "Defines a new generic word which uses the " { $link math-combination } " method combination." } ;
HELP: HOOK:
-{ $syntax "HOOK: word variable" }
+{ $syntax "HOOK: word variable" "HOOK: word variable ( stack -- effect ) " }
{ $values { "word" "a new word to define" } { "variable" word } }
{ $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." }
{ $examples
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 ;
-IN: graphics.tiff
-
-TUPLE: tiff
-endianness
-the-answer
-ifd-offset
-ifds
-processed-ifds ;
-
-CONSTRUCTOR: tiff ( -- tiff )
- V{ } clone >>ifds ;
-
-TUPLE: ifd count ifd-entries next ;
-
-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 ;
-
-! 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 -- processed-ifd )
- ifd-entries>> [ process-ifd-entry ] map ;
-
-: (load-tiff) ( path -- tiff )
- binary [
- <tiff>
- read-header
- read-ifds
- dup ifds>> [ process-ifd ] map
- >>processed-ifds
- ] with-file-reader ;
-
-: load-tiff ( path -- tiff )
- (load-tiff) ;
+++ /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
+++ /dev/null
-James Cash
+++ /dev/null
-Chris Double
-Samuel Tardieu
-Matthew Willis
+++ /dev/null
-Chris Double
+++ /dev/null
-USING: lists.lazy.examples lists.lazy tools.test ;
-IN: lists.lazy.examples.tests
-
-[ { 1 3 5 7 } ] [ 4 odds ltake list>array ] unit-test
-[ { 0 1 4 9 16 } ] [ first-five-squares ] unit-test
+++ /dev/null
-! Rewritten by Matthew Willis, July 2006
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-
-USING: lists.lazy math kernel sequences quotations ;
-IN: lists.lazy.examples
-
-: naturals ( -- list ) 0 lfrom ;
-: positives ( -- list ) 1 lfrom ;
-: evens ( -- list ) 0 [ 2 + ] lfrom-by ;
-: odds ( -- list ) 1 lfrom [ 2 mod 1 = ] lfilter ;
-: powers-of-2 ( -- list ) 1 [ 2 * ] lfrom-by ;
-: ones ( -- list ) 1 [ ] lfrom-by ;
-: squares ( -- list ) naturals [ dup * ] lazy-map ;
-: first-five-squares ( -- list ) 5 squares ltake list>array ;
+++ /dev/null
-! 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
-
-HELP: lazy-cons
-{ $values { "car" { $quotation "( -- X )" } } { "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? } ;
-
-{ 1lazy-list 2lazy-list 3lazy-list } related-words
-
-HELP: 1lazy-list
-{ $values { "a" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 1 element. The element is the result of calling the quotation. The quotation is only called when the list element is requested." } ;
-
-HELP: 2lazy-list
-{ $values { "a" { $quotation "( -- X )" } } { "b" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 2 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-
-HELP: 3lazy-list
-{ $values { "a" { $quotation "( -- X )" } } { "b" { $quotation "( -- X )" } } { "c" { $quotation "( -- X )" } } { "lazy-cons" "a lazy-cons object" } }
-{ $description "Create a lazy list with 3 elements. The elements are the result of calling the quotations. The quotations are only called when the list elements are requested." } ;
-
-HELP: <memoized-cons>
-{ $values { "cons" "a cons object" } { "memoized-cons" "the resulting memoized-cons object" } }
-{ $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
-
-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." } ;
-
-HELP: lfilter
-{ $values { "list" "a cons object" } { "quot" { $quotation "( -- X )" } } { "result" "resulting cons object" } }
-{ $description "Perform a similar functionality to that of the " { $link filter } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-filter> } " 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: lwhile
-{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list as long as " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: luntil
-{ $values { "list" "a cons object" } { "quot" { $quotation "( X -- ? )" } } { "result" "resulting cons object" } }
-{ $description "Outputs a lazy list containing the first items in the list until after " { $snippet "quot" } " evaluates to t. No evaluation of the list elements occurs initially but a " { $link <lazy-while> } " object is returned with conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ;
-
-HELP: list>vector
-{ $values { "list" "a cons object" } { "vector" "the list converted to a vector" } }
-{ $description "Convert a list to a vector. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>array } ;
-
-HELP: list>array
-{ $values { "list" "a cons object" } { "array" "the list converted to an array" } }
-{ $description "Convert a list to an array. If the list is a lazy infinite list then this will enter an infinite loop." }
-{ $see-also list>vector } ;
-
-HELP: lappend
-{ $values { "list1" "a cons object" } { "list2" "a cons object" } { "result" "a lazy list of list2 appended to list1" } }
-{ $description "Perform a similar functionality to that of the " { $link append } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link <lazy-append> } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required. Successive calls to " { $link cdr } " will iterate through list1, followed by list2." } ;
-
-HELP: lfrom-by
-{ $values { "n" "an integer" } { "quot" { $quotation "( -- int )" } } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of values starting from n, with each successive value being the result of applying quot to n." } ;
-
-HELP: lfrom
-{ $values { "n" "an integer" } { "list" "a lazy list of integers" } }
-{ $description "Return an infinite lazy list of incrementing integers starting from n." } ;
-
-HELP: seq>list
-{ $values { "index" "an integer 0 or greater" } { "seq" "a sequence" } { "list" "a list" } }
-{ $description "Convert the sequence into a list, starting from the 'index' offset into the sequence." }
-{ $see-also >list } ;
-
-HELP: >list
-{ $values { "object" "an object" } { "list" "a list" } }
-{ $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." }
-{ $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
-
-HELP: lconcat
-{ $values { "list" "a list of lists" } { "result" "a list" } }
-{ $description "Concatenates a list of lists together into one list." } ;
-
-HELP: lcartesian-product
-{ $values { "list1" "a list" } { "list2" "a list" } { "result" "list of cartesian products" } }
-{ $description "Given two lists, return a list containing the cartesian product of those lists." } ;
-
-HELP: lcartesian-product*
-{ $values { "lists" "a list of lists" } { "result" "list of cartesian products" } }
-{ $description "Given a list of lists, return a list containing the cartesian product of those lists." } ;
-
-HELP: lcomp
-{ $values { "list" "a list of lists" } { "quot" { $quotation "( seq -- X )" } } { "result" "the resulting list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } " and call " { $snippet "quot" } " call with each element from the cartesian product on the stack, the result of which is returned in the final " { $snippet "list" } "." } ;
-
-HELP: lcomp*
-{ $values { "list" "a list of lists" } { "guards" "a sequence of quotations with stack effect ( seq -- bool )" } { "quot" { $quotation "( seq -- X )" } } { "list" "the resulting list" } { "result" "a list" } }
-{ $description "Get the cartesian product of the lists in " { $snippet "list" } ", filter it by applying each guard quotation to it and call " { $snippet "quot" } " call with each element from the remaining cartesian product items on the stack, the result of which is returned in the final " { $snippet "list" } "." }
-{ $examples
- { $code "{ 1 2 3 } >list { 4 5 6 } >list 2list { [ first odd? ] } [ first2 + ] lcomp*" }
-} ;
-
-HELP: lmerge
-{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
-{ $description "Return the result of merging the two lists in a lazy manner." }
-{ $examples
- { $example "USING: lists.lazy prettyprint ;" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
-} ;
-
-HELP: lcontents
-{ $values { "stream" "a stream" } { "result" string } }
-{ $description "Returns a lazy list of all characters in the file. " { $link car } " returns the next character in the file, " { $link cdr } " returns the remaining characters as a lazy list. " { $link nil? } " indicates end of file." }
-{ $see-also llines } ;
-
-HELP: llines
-{ $values { "stream" "a stream" } { "result" "a list" } }
-{ $description "Returns a lazy list of all lines in the file. " { $link car } " returns the next lines in the file, " { $link cdr } " returns the remaining lines as a lazy list. " { $link nil? } " indicates end of file." }
-{ $see-also lcontents } ;
+++ /dev/null
-! Copyright (C) 2006 Matthew Willis and Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-USING: lists lists.lazy tools.test kernel math io sequences ;
-IN: lists.lazy.tests
-
-[ { 1 2 3 4 } ] [
- { 1 2 3 4 } >list list>array
-] unit-test
-
-[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
- { 1 2 3 } >list { 4 5 } >list 2list lcartesian-product* list>array
-] unit-test
-
-[ { { 1 4 } { 1 5 } { 2 4 } { 2 5 } { 3 4 } { 3 5 } } ] [
- { 1 2 3 } >list { 4 5 } >list lcartesian-product list>array
-] unit-test
-
-[ { 5 6 6 7 7 8 } ] [
- { 1 2 3 } >list { 4 5 } >list 2list [ first2 + ] lcomp list>array
-] unit-test
-
-[ { 5 6 7 8 } ] [
- { 1 2 3 } >list { 4 5 } >list 2list { [ first odd? ] } [ first2 + ] lcomp* list>array
-] unit-test
-
-[ { 4 5 6 } ] [
- 3 { 1 2 3 } >list [ + ] lazy-map-with list>array
-] unit-test
+++ /dev/null
-! Copyright (C) 2004 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! Updated by Matthew Willis, July 2006
-! Updated by Chris Double, September 2006
-! Updated by James Cash, June 2008
-!
-USING: kernel sequences math vectors arrays namespaces make
-quotations promises combinators io lists accessors ;
-IN: lists.lazy
-
-M: promise car ( promise -- car )
- force car ;
-
-M: promise cdr ( promise -- cdr )
- force cdr ;
-
-M: promise nil? ( cons -- bool )
- force nil? ;
-
-! Both 'car' and 'cdr' are promises
-TUPLE: lazy-cons car cdr ;
-
-: lazy-cons ( car cdr -- promise )
- [ promise ] bi@ \ lazy-cons boa
- T{ promise f f t f } clone
- swap >>value ;
-
-M: lazy-cons car ( lazy-cons -- car )
- car>> force ;
-
-M: lazy-cons cdr ( lazy-cons -- cdr )
- cdr>> force ;
-
-M: lazy-cons nil? ( lazy-cons -- bool )
- nil eq? ;
-
-: 1lazy-list ( a -- lazy-cons )
- [ nil ] lazy-cons ;
-
-: 2lazy-list ( a b -- lazy-cons )
- 1lazy-list 1quotation lazy-cons ;
-
-: 3lazy-list ( a b c -- lazy-cons )
- 2lazy-list 1quotation lazy-cons ;
-
-TUPLE: memoized-cons original car cdr nil? ;
-
-: not-memoized ( -- obj )
- { } ;
-
-: not-memoized? ( obj -- bool )
- not-memoized eq? ;
-
-: <memoized-cons> ( cons -- memoized-cons )
- not-memoized not-memoized not-memoized
- memoized-cons boa ;
-
-M: memoized-cons car ( memoized-cons -- car )
- dup car>> not-memoized? [
- dup original>> car [ >>car drop ] keep
- ] [
- car>>
- ] if ;
-
-M: memoized-cons cdr ( memoized-cons -- cdr )
- dup cdr>> not-memoized? [
- dup original>> cdr [ >>cdr drop ] keep
- ] [
- cdr>>
- ] if ;
-
-M: memoized-cons nil? ( memoized-cons -- bool )
- dup nil?>> not-memoized? [
- dup original>> nil? [ >>nil? drop ] keep
- ] [
- nil?>>
- ] if ;
-
-TUPLE: lazy-map cons quot ;
-
-C: <lazy-map> lazy-map
-
-: lazy-map ( list quot -- result )
- over nil? [ 2drop nil ] [ <lazy-map> <memoized-cons> ] if ;
-
-M: lazy-map car ( lazy-map -- car )
- [ cons>> car ] keep
- quot>> call ;
-
-M: lazy-map cdr ( lazy-map -- cdr )
- [ cons>> cdr ] keep
- quot>> lazy-map ;
-
-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
-
-: ltake ( n list -- result )
- over zero? [ 2drop nil ] [ <lazy-take> ] if ;
-
-M: lazy-take car ( lazy-take -- car )
- cons>> car ;
-
-M: lazy-take cdr ( lazy-take -- cdr )
- [ n>> 1- ] keep
- cons>> cdr ltake ;
-
-M: lazy-take nil? ( lazy-take -- bool )
- dup n>> zero? [
- drop t
- ] [
- cons>> nil?
- ] if ;
-
-TUPLE: lazy-until cons quot ;
-
-C: <lazy-until> lazy-until
-
-: luntil ( list quot -- result )
- over nil? [ drop ] [ <lazy-until> ] if ;
-
-M: lazy-until car ( lazy-until -- car )
- cons>> car ;
-
-M: lazy-until cdr ( lazy-until -- cdr )
- [ cons>> uncons ] keep quot>> tuck call
- [ 2drop nil ] [ luntil ] if ;
-
-M: lazy-until nil? ( lazy-until -- bool )
- drop f ;
-
-TUPLE: lazy-while cons quot ;
-
-C: <lazy-while> lazy-while
-
-: lwhile ( list quot -- result )
- over nil? [ drop ] [ <lazy-while> ] if ;
-
-M: lazy-while car ( lazy-while -- car )
- cons>> car ;
-
-M: lazy-while cdr ( lazy-while -- cdr )
- [ cons>> cdr ] keep quot>> lwhile ;
-
-M: lazy-while nil? ( lazy-while -- bool )
- [ car ] keep quot>> call not ;
-
-TUPLE: lazy-filter cons quot ;
-
-C: <lazy-filter> lazy-filter
-
-: lfilter ( list quot -- result )
- over nil? [ 2drop nil ] [ <lazy-filter> <memoized-cons> ] if ;
-
-: car-filter? ( lazy-filter -- ? )
- [ cons>> car ] [ quot>> ] bi call ;
-
-: skip ( lazy-filter -- )
- dup cons>> cdr >>cons drop ;
-
-M: lazy-filter car ( lazy-filter -- car )
- dup car-filter? [ cons>> ] [ dup skip ] if car ;
-
-M: lazy-filter cdr ( lazy-filter -- cdr )
- dup car-filter? [
- [ cons>> cdr ] [ quot>> ] bi lfilter
- ] [
- dup skip cdr
- ] if ;
-
-M: lazy-filter nil? ( lazy-filter -- bool )
- dup cons>> nil? [
- drop t
- ] [
- dup car-filter? [
- drop f
- ] [
- dup skip nil?
- ] if
- ] if ;
-
-: list>vector ( list -- vector )
- [ [ , ] leach ] V{ } make ;
-
-: list>array ( list -- array )
- [ [ , ] leach ] { } make ;
-
-TUPLE: lazy-append list1 list2 ;
-
-C: <lazy-append> lazy-append
-
-: lappend ( list1 list2 -- result )
- over nil? [ nip ] [ <lazy-append> ] if ;
-
-M: lazy-append car ( lazy-append -- car )
- list1>> car ;
-
-M: lazy-append cdr ( lazy-append -- cdr )
- [ list1>> cdr ] keep
- list2>> lappend ;
-
-M: lazy-append nil? ( lazy-append -- bool )
- drop f ;
-
-TUPLE: lazy-from-by n quot ;
-
-C: lfrom-by lazy-from-by ( n quot -- list )
-
-: lfrom ( n -- list )
- [ 1+ ] lfrom-by ;
-
-M: lazy-from-by car ( lazy-from-by -- car )
- n>> ;
-
-M: lazy-from-by cdr ( lazy-from-by -- cdr )
- [ n>> ] keep
- quot>> dup slip lfrom-by ;
-
-M: lazy-from-by nil? ( lazy-from-by -- bool )
- drop f ;
-
-TUPLE: lazy-zip list1 list2 ;
-
-C: <lazy-zip> lazy-zip
-
-: lzip ( list1 list2 -- lazy-zip )
- over nil? over nil? or
- [ 2drop nil ] [ <lazy-zip> ] if ;
-
-M: lazy-zip car ( lazy-zip -- car )
- [ list1>> car ] keep list2>> car 2array ;
-
-M: lazy-zip cdr ( lazy-zip -- cdr )
- [ list1>> cdr ] keep list2>> cdr lzip ;
-
-M: lazy-zip nil? ( lazy-zip -- bool )
- drop f ;
-
-TUPLE: sequence-cons index seq ;
-
-C: <sequence-cons> sequence-cons
-
-: seq>list ( index seq -- list )
- 2dup length >= [
- 2drop nil
- ] [
- <sequence-cons>
- ] if ;
-
-M: sequence-cons car ( sequence-cons -- car )
- [ index>> ] keep
- seq>> nth ;
-
-M: sequence-cons cdr ( sequence-cons -- cdr )
- [ index>> 1+ ] keep
- seq>> seq>list ;
-
-M: sequence-cons nil? ( sequence-cons -- bool )
- drop f ;
-
-: >list ( object -- list )
- {
- { [ dup sequence? ] [ 0 swap seq>list ] }
- { [ dup list? ] [ ] }
- [ "Could not convert object to a list" throw ]
- } cond ;
-
-TUPLE: lazy-concat car cdr ;
-
-C: <lazy-concat> lazy-concat
-
-DEFER: lconcat
-
-: (lconcat) ( car cdr -- list )
- over nil? [
- nip lconcat
- ] [
- <lazy-concat>
- ] if ;
-
-: lconcat ( list -- result )
- dup nil? [
- drop nil
- ] [
- uncons swap (lconcat)
- ] if ;
-
-M: lazy-concat car ( lazy-concat -- car )
- car>> car ;
-
-M: lazy-concat cdr ( lazy-concat -- cdr )
- [ car>> cdr ] keep cdr>> (lconcat) ;
-
-M: lazy-concat nil? ( lazy-concat -- bool )
- dup car>> nil? [
- cdr>> nil?
- ] [
- drop f
- ] if ;
-
-: lcartesian-product ( list1 list2 -- result )
- swap [ swap [ 2array ] lazy-map-with ] lazy-map-with 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
- ] reduce
- ] if ;
-
-: lcomp ( list quot -- result )
- [ lcartesian-product* ] dip lazy-map ;
-
-: lcomp* ( list guards quot -- result )
- [ [ lcartesian-product* ] dip [ lfilter ] each ] dip lazy-map ;
-
-DEFER: lmerge
-
-: (lmerge) ( list1 list2 -- result )
- over [ car ] curry -rot
- [
- dup [ car ] curry -rot
- [
- [ cdr ] bi@ lmerge
- ] 2curry lazy-cons
- ] 2curry lazy-cons ;
-
-: lmerge ( list1 list2 -- result )
- {
- { [ over nil? ] [ nip ] }
- { [ dup nil? ] [ drop ] }
- { [ t ] [ (lmerge) ] }
- } cond ;
-
-TUPLE: lazy-io stream car cdr quot ;
-
-C: <lazy-io> lazy-io
-
-: lcontents ( stream -- result )
- f f [ stream-read1 ] <lazy-io> ;
-
-: llines ( stream -- result )
- f f [ stream-readln ] <lazy-io> ;
-
-M: lazy-io car ( lazy-io -- car )
- dup car>> dup [
- nip
- ] [
- drop dup stream>> over quot>> call
- >>car
- ] if ;
-
-M: lazy-io cdr ( lazy-io -- cdr )
- dup cdr>> dup [
- nip
- ] [
- drop dup
- [ stream>> ] keep
- [ quot>> ] keep
- car [
- [ f f ] dip <lazy-io> [ >>cdr drop ] keep
- ] [
- 3drop nil
- ] if
- ] if ;
-
-M: lazy-io nil? ( lazy-io -- bool )
- car not ;
-
-INSTANCE: sequence-cons list
-INSTANCE: memoized-cons list
-INSTANCE: promise list
-INSTANCE: lazy-io list
-INSTANCE: lazy-concat list
-INSTANCE: lazy-cons list
-INSTANCE: lazy-map list
-INSTANCE: lazy-take list
-INSTANCE: lazy-append list
-INSTANCE: lazy-from-by list
-INSTANCE: lazy-zip list
-INSTANCE: lazy-while list
-INSTANCE: lazy-until list
-INSTANCE: lazy-filter list
+++ /dev/null
-<html>
- <head>
- <title>Lazy Evaluation</title>
- <link rel="stylesheet" type="text/css" href="style.css">
- </head>
- <body>
- <h1>Lazy Evaluation</h1>
-<p>The 'lazy' vocabulary adds lazy lists to Factor. This provides the
- ability to describe infinite structures, and to delay execution of
- expressions until they are actually used.</p>
-<p>Lazy lists, like normal lists, are composed of a head and tail. In
- a lazy list the head and tail are something called a 'promise'.
- To convert a
- 'promise' into its actual value a word called 'force' is used. To
- convert a value into a 'promise' the word to use is 'delay'.</p>
-<table border="1">
-<tr><td><a href="#delay">delay</a></td></tr>
-<tr><td><a href="#force">force</a></td></tr>
-</table>
-
-<p>Many of the lazy list words are named similar to the standard list
- words but with an 'l' suffixed to it. Here are the commonly used
- words and their equivalent list operation:</p>
-<table border="1">
-<tr><th>Lazy List</th><th>Normal List</th></tr>
-<tr><td><a href="#lnil">lnil</a></td><td>[ ]</td></tr>
-<tr><td><a href="#lnilp">lnil?</a></td><td>Test for nil value</td></tr>
-<tr><td><a href="#lcons">lcons</a></td><td>cons</td></tr>
-<tr><td><a href="#lunit">lunit</a></td><td>unit</td></tr>
-<tr><td><a href="#lcar">lcar</a></td><td>car</td></tr>
-<tr><td><a href="#lcdr">lcdr</a></td><td>cdr</td></tr>
-<tr><td><a href="#lnth">lnth</a></td><td>nth</td></tr>
-<tr><td><a href="#luncons">luncons</a></td><td>uncons</td></tr>
-<tr><td><a href="#lmap">lmap</a></td><td>map</td></tr>
-<tr><td><a href="#lsubset">lsubset</a></td><td>subset</td></tr>
-<tr><td><a href="#leach">leach</a></td><td>each</td></tr>
-<tr><td><a href="#lappend">lappend</a></td><td>append</td></tr>
-</table>
-<p>A few additional words specific to lazy lists are:</p>
-<table border="1">
-<tr><td><a href="#ltake">ltake</a></td><td>Returns a normal list containing a specified
-number of items from the lazy list.</td></tr>
-<tr><td><a href="#lappendstar">lappend*</a></td><td>Given a lazy list of lazy lists,
-concatenate them together in a lazy manner, returning a single lazy
-list.</td></tr>
-<tr><td><a href="#list>llist">list>llist</a></td><td>Given a normal list, return a lazy list
-that contains the same elements as the normal list.</td></tr>
-</table>
-<h2>Reference</h2>
-<!-- delay description -->
-<a name="delay">
-<h3>delay ( quot -- <promise> )</h3>
-<p>'delay' is used to convert a value or expression into a promise.
- The word 'force' is used to convert that promise back to its
- value, or to force evaluation of the expression to return a value.
-</p>
-<p>The value on the stack that 'delay' expects must be quoted. This is
- a requirement to prevent it from being evaluated.
-</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ 42 ] [ ] [ ] >>
- ( 2 ) <a href="#force">force</a> .
- => 42
-</pre>
-
-<!-- force description -->
-<a name="force">
-<h3>force ( <promise> -- value )</h3>
-<p>'force' will evaluate a promises original expression
- and leave the value of that expression on the stack.
-</p>
-<p>A promise can be forced multiple times but the expression
- is only evaluated once. Future calls of 'force' on the promise
- will returned the cached value of the original force. If the
- expression contains side effects, such as i/o, then that i/o
- will only occur on the first 'force'. See below for an example
- (steps 3-5).
-</p>
-<p>If a promise is itself delayed, a force will evaluate all promises
- until a value is returned. Due to this behaviour it is generally not
- possible to delay a promise. The example below shows what happens
- in this case.
-</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ 42 ] [ ] [ ] >>
- ( 2 ) <a href="#force">force</a> .
- => 42
-
- #! Multiple forces on a promise returns cached value
- ( 3 ) [ "hello" print 42 ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ "hello" print 42 ] [ ] [ ] >>
- ( 4 ) dup <a href="#force">force</a> .
- => hello
- 42
- ( 5 ) <a href="#force">force</a> .
- => 42
-
- #! Forcing a delayed promise cascades up to return
- #! original value, rather than the promise.
- ( 6 ) [ [ 42 ] <a href="#delay">delay</a> ] <a href="#delay">delay</a> dup .
- => << promise [ ] [ [ 42 ] delay ] [ ] [ ] >>
- ( 7 ) <a href="#force">force</a> .
- => 42
-</pre>
-
-<!-- lnil description -->
-<a name="lnil">
-<h3>lnil ( -- lcons )</h3>
-<p>Returns a value representing the empty lazy list.</p>
-<pre class="code">
- ( 1 ) <a href="#lnil">lnil</a> .
- => << promise [ ] [ [ ] ] t [ ] >>
-</pre>
-
-<!-- lnil description -->
-<a name="lnilp">
-<h3>lnil? ( lcons -- bool )</h3>
-<p>Returns true if the given lazy cons is the value representing
- the empty lazy list.</p>
-<pre class="code">
- ( 1 ) <a href="#lnil">lnil</a> <a href="#lnilp">lnil?</a> .
- => t
- ( 2 ) [ 1 ] <a href="#list2llist">list>llist</a> dup <a href="#lnilp">lnil?</a> .
- => [ ]
- ( 3 ) <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
- => t
-</pre>
-
-<!-- lcons description -->
-<a name="lcons">
-<h3>lcons ( car-promise cdr-promise -- lcons )</h3>
-<p>Provides the same effect as 'cons' does for normal lists.
- Both values provided must be promises (ie. expressions that have
- had <a href="#delay">delay</a> called on them).
-</p>
-<p>As the car and cdr passed on the stack are promises, they are not
- evaluated until <a href="#lcar">lcar</a> or <a href="#lcdr">lcdr</a>
- are called on the lazy cons.</p>
-<pre class="code">
- ( 1 ) [ "car" ] <a href="#delay">delay</a> [ "cdr" ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) dup <a href="#lcar">lcar</a> .
- => "car"
- ( 3 ) dup <a href="#lcdr">lcdr</a> .
- => "cdr"
-</pre>
-
-<!-- lunit description -->
-<a name="lunit">
-<h3>lunit ( value-promise -- llist )</h3>
-<p>Provides the same effect as 'unit' does for normal lists. It
-creates a lazy list where the first element is the value given.</p>
-<p>Like <a href="#lcons">lcons</a>, the value on the stack must be
- a promise and is not evaluated until the <a href="#lcar">lcar</a>
- of the list is requested.</a>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
- => << promise ... >>
- ( 2 ) dup <a href="#lcar">lcar</a> .
- => 42
- ( 3 ) dup <a href="#lcdr">lcdr</a> <a href="#lnilp">lnil?</a> .
- => t
- ( 4 ) [ . ] <a href="#leach">leach</a>
- => 42
-</pre>
-
-<!-- lcar description -->
-<a name="lcar">
-<h3>lcar ( lcons -- value )</h3>
-<p>Provides the same effect as 'car' does for normal lists. It
-returns the first element in a lazy cons cell. This will force
-the evaluation of that element.</p>
-<pre class="code">
- ( 1 ) [ 42 ] <a href="#delay">delay</a> <a href="#lunit">lunit</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcar">lcar</a> .
- => 42
-</pre>
-
-<!-- lcdr description -->
-<a name="lcdr">
-<h3>lcdr ( lcons -- value )</h3>
-<p>Provides the same effect as 'cdr' does for normal lists. It
-returns the second element in a lazy cons cell and forces it. This
-causes that element to be evaluated immediately.</p>
-<pre class="code">
- ( 1 ) [ 1 ] <a href="#delay">delay</a> [ 5 6 + ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcdr">lcdr</a> .
- => 11
-</pre>
-
-<pre class="code">
- ( 1 ) 5 <a href="#lfrom">lfrom</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 6
- ( 3 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 7
- ( 4 ) <a href="#lcdr">lcdr</a> dup <a href="#lcar">lcar</a> .
- => 8
-</pre>
-
-<!-- lnth description -->
-<a name="lnth">
-<h3>lnth ( n llist -- value )</h3>
-<p>Provides the same effect as 'nth' does for normal lists. It
-returns the nth value in the lazy list. It causes all the values up to
-'n' to be evaluated.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a> dup .
- => << promise ... >>
- ( 2 ) 5 swap <a href="#lnth">lnth</a> .
- => 6
-</pre>
-
-<!-- luncons description -->
-<a name="luncons">
-<h3>luncons ( lcons -- car cdr )</h3>
-<p>Provides the same effect as 'uncons' does for normal lists. It
-returns the car and cdr of the lazy list.</p>
-<pre class="code">
- ( 1 ) [ 5 ] <a href="#delay">delay</a> [ 6 ] <a href="#delay">delay</a> <a href="#lcons">lcons</a> dup .
- => << promise ... >>
- ( 2 ) <a href="#luncons">luncons</a> . .
- => 6
- 5
-</pre>
-
-<!-- lmap description -->
-<a name="lmap">
-<h3>lmap ( llist quot -- llist )</h3>
-<p>Lazily maps over a lazy list applying the quotation to each element.
-A new lazy list is returned which contains the results of the
-quotation.</p>
-<p>When intially called nothing in the original lazy list is
-evaluated. Only when <a href="#lcar">lcar</a> is called will the item
-in the list be evaluated and applied to the quotation. Ditto with <a
-href="#lcdr">lcdr</a>, thus allowing infinite lists to be mapped over.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ 2 * ] <a href="#lmap">lmap</a>
- => < infinite list of numbers incrementing by 2 >
- ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 2 4 6 8 10 ]
-</pre>
-
-<!-- lsubset description -->
-<a name="lsubset">
-<h3>lsubset ( llist pred -- llist )</h3>
-<p>Provides the same effect as 'subset' does for normal lists. It
-lazily iterates over a lazy list applying the predicate quotation to each
-element. If that quotation returns true, the element will be included
-in the resulting lazy list. If it is false, the element will be skipped.
-A new lazy list is returned which contains all elements where the
-predicate returned true.</p>
-<p>Like <a href="#lmap">lmap</a>, when initially called no evaluation
-will occur. A lazy list is returned that when values are retrieved
-from in then items are evaluated and checked against the predicate.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ <a href="#primep">prime?</a> ] <a href="#lsubset">lsubset</a>
- => < infinite list of prime numbers >
- ( 3 ) 5 swap <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 2 3 5 7 11 ]
-</pre>
-
-<!-- leach description -->
-<a name="leach">
-<h3>leach ( llist quot -- )</h3>
-<p>Provides the same effect as 'each' does for normal lists. It
-lazily iterates over a lazy list applying the quotation to each
-element. If this operation is applied to an infinite list it will
-never return unless the quotation escapes out by calling a continuation.</p>
-<pre class="code">
- ( 1 ) 1 <a href="#lfrom">lfrom</a>
- => < infinite list of incrementing numbers >
- ( 2 ) [ 2 mod 1 = ] <a href="#lsubset">lsubset</a>
- => < infinite list of odd numbers >
- ( 3 ) [ . ] <a href="#leach">leach</a>
- => 1
- 3
- 5
- 7
- ... for ever ...
-</pre>
-
-<!-- ltake description -->
-<a name="ltake">
-<h3>ltake ( n llist -- llist )</h3>
-<p>Iterates over the lazy list 'n' times, appending each element to a
-lazy list. This provides a convenient way of getting elements out of
-an infinite lazy list.</p>
-<pre class="code">
- ( 1 ) : ones [ 1 ] delay [ ones ] delay <a href="#lcons">lcons</a> ;
- ( 2 ) 5 ones <a href="#ltake">ltake</a> <a href="#llist2list">llist>list</a> .
- => [ 1 1 1 1 1 ]
-</pre>
-
-<!-- lappend description -->
-<a name="lappend">
-<h3>lappend ( llist1 llist2 -- llist )</h3>
-<p>Lazily appends two lists together. The actual appending is done
-lazily on iteration rather than immediately so it works very fast no
-matter how large the list.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a> [ 4 5 6 ] <a href="#list2llist">list>llist</a> <a href="#lappend">lappend</a>
- ( 2 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
- 4
- 5
- 6
-</pre>
-
-<!-- lappend* description -->
-<a name="lappendstar">
-<h3>lappend* ( llists -- llist )</h3>
-<p>Given a lazy list of lazy lists, concatenate them together in a
-lazy fashion. The actual appending is done lazily on iteration rather
-than immediately so it works very fast no matter how large the lists.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2>llist">list>llist</a>
- ( 2 ) [ 4 5 6 ] <a href="#list2llist">list>llist</a>
- ( 3 ) [ 7 8 9 ] <a href="#list2llist">list>llist</a>
- ( 4 ) 3list <a href="#list2llist">list>llist</a> <a href="#lappendstar">lappend*</a>
- ( 5 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
- 4
- 5
- 6
- 7
- 8
- 9
-</pre>
-
-<!-- list>llist description -->
-<a name="list2llist">
-<h3>list>llist ( list -- llist )</h3>
-<p>Converts a normal list into a lazy list. This is done lazily so the
-initial list is not iterated through immediately.</p>
-<pre class="code">
- ( 1 ) [ 1 2 3 ] <a href="#list2llist">list>llist</a>
- ( 2 ) [ . ] <a href="#leach">leach</a>
- => 1
- 2
- 3
-</pre>
-
-<p class="footer">
-News and updates to this software can be obtained from the authors
-weblog: <a href="http://radio.weblogs.com/0102385">Chris Double</a>.</p>
-<p id="copyright">Copyright (c) 2004, Chris Double. All Rights Reserved.</p>
-</body> </html>
+++ /dev/null
-Lazy lists
+++ /dev/null
-extensions
-collections
+++ /dev/null
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel help.markup help.syntax ;
-
-IN: lists
-
-{ car cons cdr nil nil? list? uncons } related-words
-
-HELP: cons
-{ $values { "car" "the head of the lazy list" } { "cdr" "the tail of the lazy list" } { "cons" "a cons object" } }
-{ $description "Constructs a cons cell." } ;
-
-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." } ;
-
-HELP: nil
-{ $values { "symbol" "The empty cons (+nil+)" } }
-{ $description "Returns a symbol representing the empty list" } ;
-
-HELP: nil?
-{ $values { "object" object } { "?" "a boolean" } }
-{ $description "Return true if the cons object is the nil cons." } ;
-
-HELP: list? ( object -- ? )
-{ $values { "object" "an object" } { "?" "a boolean" } }
-{ $description "Returns true if the object conforms to the list protocol." } ;
-
-{ 1list 2list 3list } related-words
-
-HELP: 1list
-{ $values { "obj" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 1 element." } ;
-
-HELP: 2list
-{ $values { "a" "an object" } { "b" "an object" } { "cons" "a cons object" } }
-{ $description "Create a list with 2 elements." } ;
-
-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 llength cons car cdr } ;
-
-HELP: llength
-{ $values { "list" "a cons object" } { "n" "a non-negative integer" } }
-{ $description "Outputs the length of the list. This should not be called on an infinite 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" } }
-{ $description "Put the head and tail of the list on the stack." } ;
-
-{ leach foldl lmap>array } related-words
-
-HELP: leach
-{ $values { "list" "a cons object" } { "quot" { $quotation "( obj -- )" } } }
-{ $description "Call the quotation for each item in the list." } ;
-
-HELP: foldl
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
-{ $description "Combines successive elements of the list (in a left-assocative order) using a binary operation and outputs the final result." } ;
-
-HELP: foldr
-{ $values { "list" "a cons object" } { "identity" "an object" } { "quot" { $quotation "( prev elt -- next )" } } { "result" "the final result" } }
-{ $description "Combines successive elements of the list (in a right-assocative order) using a binary operation, and outputs the final result." } ;
-
-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" } }
-{ $description "Turns the given cons object into an array, maintaing order." } ;
-
-HELP: seq>list
-{ $values { "seq" "a sequence" } { "list" "a cons object" } }
-{ $description "Turns the given array into a cons object, maintaing order." } ;
-
-HELP: cons>seq
-{ $values { "cons" "a cons object" } { "array" "an array object" } }
-{ $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" } }
-{ $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." } ;
-
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test lists math ;
-
-IN: lists.tests
-
-{ { 3 4 5 6 7 } } [
- { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq
-] unit-test
-
-{ { 3 4 5 6 } } [
- T{ cons f 1
- T{ cons f 2
- T{ cons f 3
- T{ cons f 4
- +nil+ } } } } [ 2 + ] lmap>array
-] unit-test
-
-{ 10 } [
- T{ cons f 1
- T{ cons f 2
- T{ cons f 3
- T{ cons f 4
- +nil+ } } } } 0 [ + ] foldl
-] unit-test
-
-{ T{ cons f
- 1
- T{ cons f
- 2
- T{ cons f
- T{ cons f
- 3
- T{ cons f
- 4
- T{ cons f
- T{ cons f 5 +nil+ }
- +nil+ } } }
- +nil+ } } }
-} [
- { 1 2 { 3 4 { 5 } } } seq>cons
-] unit-test
-
-{ { 1 2 { 3 4 { 5 } } } } [
- { 1 2 { 3 4 { 5 } } } seq>cons cons>seq
-] 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
-] unit-test
-
-{ 15 } [
- { 1 2 3 4 5 } seq>list 0 [ + ] foldr
-] unit-test
-
-{ { 5 4 3 2 1 } } [
- { 1 2 3 4 5 } seq>list lreverse list>seq
-] unit-test
-
-{ 5 } [
- { 1 2 3 4 5 } seq>list llength
-] unit-test
-
-{ { 3 4 { 5 6 { 7 } } } } [
- { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq
-] 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
+++ /dev/null
-! Copyright (C) 2008 James Cash
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences accessors math arrays vectors classes words locals ;
-
-IN: lists
-
-! List Protocol
-MIXIN: list
-GENERIC: car ( cons -- car )
-GENERIC: cdr ( cons -- cdr )
-GENERIC: nil? ( object -- ? )
-
-TUPLE: cons car cdr ;
-
-C: cons cons
-
-M: cons car ( cons -- car )
- car>> ;
-
-M: cons cdr ( cons -- cdr )
- cdr>> ;
-
-SYMBOL: +nil+
-M: word nil? +nil+ eq? ;
-M: object nil? drop f ;
-
-: atom? ( obj -- ? ) [ list? ] [ nil? ] bi or not ;
-
-: nil ( -- symbol ) +nil+ ;
-
-: uncons ( cons -- cdr car )
- [ cdr ] [ car ] bi ;
-
-: 1list ( obj -- cons )
- nil cons ;
-
-: 2list ( a b -- cons )
- nil cons cons ;
-
-: 3list ( a b c -- cons )
- nil cons cons cons ;
-
-: cadr ( cons -- elt )
- cdr car ;
-
-: 2car ( cons -- car caar )
- [ car ] [ cdr car ] bi ;
-
-: 3car ( cons -- car caar caaar )
- [ car ] [ cdr car ] [ cdr cdr car ] tri ;
-
-: lnth ( n list -- elt )
- swap [ cdr ] times car ;
-
-: (leach) ( list quot -- cdr quot )
- [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline
-
-: leach ( list quot: ( elt -- ) -- )
- over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
-
-: lmap ( list quot: ( elt -- ) -- result )
- over nil? [ drop ] [ (leach) lmap cons ] 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
- ] 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 )
- <reversed> nil [ swap cons ] reduce ;
-
-: 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 )
- [ ] 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
-
-INSTANCE: cons list
\ No newline at end of file
+++ /dev/null
-Implementation of lisp-style linked lists
+++ /dev/null
-collections
! 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
-! Copyright (C) 2004 Chris Double.
+! Copyright (C) 2004, 2006 Chris Double, Matthew Willis.
! See http://factorcode.org/license.txt for BSD license.
-!
-! Updated by Matthew Willis, July 2006
-! Updated by Chris Double, September 2006
-
-USING: arrays kernel sequences math vectors arrays namespaces
+USING: arrays kernel sequences math vectors arrays namespaces call
make quotations parser effects stack-checker words accessors ;
IN: promises
#! promises quotation on the stack. Re-forcing the promise
#! will return the same value and not recall the quotation.
dup forced?>> [
- dup quot>> call >>value
+ dup quot>> call( -- value ) >>value
t >>forced?
] unless
value>> ;
{ 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
+USING: accessors assocs combinators hashtables http
+http.client json.reader kernel macros namespaces sequences
+urls.secure urls.encoding ;
+IN: twitter
+
+SYMBOLS: twitter-username twitter-password twitter-source ;
+
+twitter-source [ "factor" ] initialize
+
+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 ;
+
+MACRO: keys-boa ( keys class -- )
+ [ [ \ swap \ at [ ] 3sequence ] map \ cleave ] dip \ boa [ ] 4sequence ;
+
+: <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> ;
+
+: set-twitter-credentials ( username password -- )
+ [ twitter-username set ] [ twitter-password set ] bi* ;
+
+: set-request-twitter-auth ( request -- request )
+ twitter-username twitter-password [ get ] bi@ set-basic-auth ;
+
+: update-post-data ( update -- assoc )
+ "status" associate
+ [ twitter-source get "source" ] dip [ set-at ] keep ;
+
+: (tweet) ( string -- json )
+ update-post-data "https://twitter.com/statuses/update.json" <post-request>
+ set-request-twitter-auth
+ http-request nip ;
+
+: tweet* ( string -- tweet )
+ (tweet) json>twitter-status ;
+
+: tweet ( string -- ) (tweet) drop ;
+
+: public-timeline ( -- tweets )
+ "https://twitter.com/statuses/public_timeline.json" <get-request>
+ set-request-twitter-auth
+ http-request nip json>twitter-statuses ;
+
+: friends-timeline ( -- tweets )
+ "https://twitter.com/statuses/friends_timeline.json" <get-request>
+ set-request-twitter-auth
+ http-request nip json>twitter-statuses ;
+
+: user-timeline ( username -- tweets )
+ "https://twitter.com/statuses/user_timeline/" ".json" surround <get-request>
+ set-request-twitter-auth
+ http-request nip json>twitter-statuses ;
! 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>
"concatenative.org" 25 <inet> smtp-server set-global
"noreply@concatenative.org" lost-password-from set-global
"website@concatenative.org" insomniac-sender set-global
- "slava@factorcode.org" insomniac-recipients set-global
+ { "slava@factorcode.org" } insomniac-recipients set-global
init-factor-db ;
: init-testing ( -- )
(require 'fuel-eval)
(require 'fuel-log)
+\f
+;;; Aux:
+
+(defvar fuel-completion--minibuffer-map
+ (let ((map (make-keymap)))
+ (set-keymap-parent map minibuffer-local-completion-map)
+ (define-key map "?" 'self-insert-command)
+ map))
+
\f
;;; Vocabs dictionary:
fuel-completion--vocabs)
(defun fuel-completion--read-vocab (&optional reload init-input history)
- (let ((vocabs (fuel-completion--vocabs reload)))
+ (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)
+ (vocabs (fuel-completion--vocabs reload)))
(completing-read "Vocab name: " vocabs nil nil init-input history)))
(defsubst fuel-completion--vocab-list (prefix)
(cons completions partial)))
(defun fuel-completion--read-word (prompt &optional default history all)
- (completing-read prompt
- (if all fuel-completion--all-words-list-func
- fuel-completion--word-list-func)
- nil nil nil
- history
- (or default (fuel-syntax-symbol-at-point))))
+ (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map))
+ (completing-read prompt
+ (if all fuel-completion--all-words-list-func
+ fuel-completion--word-list-func)
+ nil nil nil
+ history
+ (or default (fuel-syntax-symbol-at-point)))))
+
+(defvar fuel-completion--vocab-history nil)
+
+(defun fuel-completion--read-vocab (refresh)
+ (let ((minibuffer-local-completion-map fuel-completion--minibuffer-map)
+ (vocabs (fuel-completion--vocabs refresh))
+ (prompt "Vocabulary name: "))
+ (if vocabs
+ (completing-read prompt vocabs nil nil nil fuel-completion--vocab-history)
+ (read-string prompt nil fuel-completion--vocab-history))))
(defun fuel-completion--complete-symbol ()
"Complete the symbol at point.
(add-hook 'comint-redirect-hook
'fuel-con--comint-redirect-hook nil t))
-(defadvice comint-redirect-setup (after fuel-con--advice activate)
- (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex))
+(defadvice comint-redirect-setup
+ (after fuel-con--advice (output-buffer comint-buffer finished-regexp &optional echo))
+ (with-current-buffer comint-buffer
+ (when fuel-con--connection
+ (setq comint-redirect-finished-regexp fuel-con--comint-finished-regex))))
+(ad-activate 'comint-redirect-setup)
(defun fuel-con--comint-preoutput-filter (str)
(when (string-match fuel-con--comint-finished-regex str)
(fuel-edit--visit-file (car loc) fuel-edit-word-method)
(goto-line (if (numberp (cadr loc)) (cadr loc) 1))))
-(defun fuel-edit--read-vocabulary-name (refresh)
- (let* ((vocabs (fuel-completion--vocabs refresh))
- (prompt "Vocabulary name: "))
- (if vocabs
- (completing-read prompt vocabs nil nil nil fuel-edit--vocab-history)
- (read-string prompt nil fuel-edit--vocab-history))))
-
(defun fuel-edit--edit-article (name)
(let ((cmd `(:fuel* (,name fuel-get-article-location) "fuel" t)))
(fuel-edit--try-edit (fuel-eval--send/wait cmd))))
;;; Editing commands:
(defvar fuel-edit--word-history nil)
-(defvar fuel-edit--vocab-history nil)
(defvar fuel-edit--previous-location nil)
(defun fuel-edit-vocabulary (&optional refresh vocab)
When called interactively, asks for vocabulary with completion.
With prefix argument, refreshes cached vocabulary list."
(interactive "P")
- (let* ((vocab (or vocab (fuel-edit--read-vocabulary-name refresh)))
+ (let* ((vocab (or vocab (fuel-completion--read-vocab refresh)))
(cmd `(:fuel* (,vocab fuel-get-vocab-location) "fuel" t)))
(fuel-edit--try-edit (fuel-eval--send/wait cmd))))
(defun fuel-help-vocab (vocab)
"Ask for a vocabulary name and show its help page."
- (interactive (list (fuel-edit--read-vocabulary-name nil)))
+ (interactive (list (fuel-completion--read-vocab nil)))
(fuel-help--get-vocab vocab))
(defun fuel-help-next (&optional forget-current)
(defcustom fuel-listener-factor-binary
(expand-file-name (cond ((eq system-type 'windows-nt)
- "factor.exe")
+ "factor.com")
((eq system-type 'darwin)
"Factor.app/Contents/MacOS/factor")
(t "factor"))
(fuel-markup--insert-newline)
(dolist (s (cdr e))
(fuel-markup--snippet (list '$snippet s))
- (newline)))
+ (newline))
+ (newline))
(defun fuel-markup--markup-example (e)
(fuel-markup--insert-newline)
`user-full-name') for the name to be inserted in the generated file."
(interactive "P")
(let* ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
- (fuel-edit--read-vocabulary-name nil)))
+ (fuel-completion--read-vocab nil)))
(cmd `(:fuel* (,vocab ,fuel-scaffold-developer-name fuel-scaffold-help)
"fuel"))
(ret (fuel-eval--send/wait cmd))
With prefix argument, ask for the vocab."
(interactive "P")
(let ((vocab (or (and (not arg) (fuel-syntax--current-vocab))
- (fuel-edit--read-vocabulary-name))))
+ (fuel-completion--read-vocab nil))))
(when vocab
(fuel-xref--show-vocab-words vocab
(fuel-syntax--file-has-private)))))
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)
projects / factor.git / commitdiff
