diff --git a/README.txt b/README.txt index 98616539d2..d60bf03130 100755 --- a/README.txt +++ b/README.txt @@ -116,16 +116,22 @@ Now if $DISPLAY is set, running ./factor will start the UI. * Running Factor on Windows XP/Vista +The Factor runtime is compiled into two binaries: + + factor.com - a Windows console application + factor.exe - a Windows native application, without a console + If you did not download the binary package, you can bootstrap Factor in -the command prompt: +the command prompt using the console application: - factor.exe -i=boot..image + factor.com -i=boot..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 diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor old mode 100644 new mode 100755 index 727492edb1..6a182f8dbf --- a/basis/alien/arrays/arrays.factor +++ b/basis/alien/arrays/arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien arrays alien.c-types alien.structs -sequences math kernel namespaces make libc cpu.architecture ; +sequences math kernel namespaces fry libc cpu.architecture ; IN: alien.arrays UNION: value-type array struct-type ; @@ -10,7 +10,7 @@ M: array c-type ; M: array c-type-class drop object ; -M: array heap-size unclip heap-size [ * ] reduce ; +M: array heap-size unclip [ product ] [ heap-size ] bi* * ; M: array c-type-align first c-type-align ; @@ -26,16 +26,15 @@ M: array box-return drop "void*" box-return ; M: array stack-size drop "void*" stack-size ; +M: array c-type-boxer-quot drop [ ] ; + +M: array c-type-unboxer-quot drop [ >c-ptr ] ; + M: value-type c-type-reg-class drop int-regs ; -M: value-type c-type-boxer-quot drop f ; - -M: value-type c-type-unboxer-quot drop f ; - M: value-type c-type-getter drop [ swap ] ; M: value-type c-type-setter ( type -- quot ) - [ - dup c-type-getter % \ swap , heap-size , \ memcpy , - ] [ ] make ; + [ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri + '[ @ swap @ _ memcpy ] ; diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index a2b555b057..dc29ea9bb3 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/basis/alien/c-types/c-types-docs.factor @@ -178,6 +178,8 @@ $nl { { $snippet "ulonglong" } { } } { { $snippet "float" } { } } { { $snippet "double" } { "same format as " { $link float } " objects" } } + { { $snippet "complex-float" } { "C99 " { $snippet "complex float" } " type, converted to and from " { $link complex } " values" } } + { { $snippet "complex-double" } { "C99 " { $snippet "complex double" } " type, converted to and from " { $link complex } " values" } } } "When making alien calls, Factor numbers are converted to and from the above types in a canonical way. Converting a Factor number to a C value may result in a loss of precision." $nl diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor old mode 100644 new mode 100755 index d1354cb04e..a44b5cf2b6 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math namespaces make parser sequences strings words assocs splitting math.parser cpu.architecture alien alien.accessors quotations layouts system compiler.units io.files io.encodings.binary -accessors combinators effects continuations fry ; +accessors combinators effects continuations fry call classes ; IN: alien.c-types DEFER: @@ -13,18 +13,20 @@ DEFER: *char : little-endian? ( -- ? ) 1 *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? ; : ( -- type ) - \ c-type new-c-type ; + \ c-type new ; SYMBOL: c-types @@ -178,11 +180,16 @@ GENERIC: byte-length ( seq -- n ) flushable M: byte-array byte-length length ; +M: f byte-length drop 0 ; + : c-getter ( name -- quot ) c-type-getter [ [ "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 ] @@ -201,13 +208,13 @@ M: byte-array byte-length length ; 1 swap malloc-array ; inline : malloc-byte-array ( byte-array -- alien ) - dup length [ nip malloc dup ] 2keep memcpy ; + dup byte-length [ nip malloc dup ] 2keep memcpy ; : memory>byte-array ( alien len -- byte-array ) [ nip (byte-array) dup ] 2keep memcpy ; : byte-array>memory ( byte-array base -- ) - swap dup length memcpy ; + swap dup byte-length memcpy ; : array-accessor ( type quot -- def ) [ @@ -219,7 +226,7 @@ M: byte-array byte-length length ; TUPLE: long-long-type < c-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 ; @@ -256,14 +263,14 @@ M: long-long-type box-return ( type -- ) unclip [ [ dup word? [ - def>> { } swap with-datastack first + def>> call( -- object ) ] when ] map ] dip prefix ] when ; : malloc-file-contents ( path -- alien len ) - binary file-contents dup malloc-byte-array swap length ; + binary file-contents [ malloc-byte-array ] [ length ] bi ; : if-void ( type true false -- ) pick "void" = [ drop nip call ] [ nip call ] if ; inline @@ -283,9 +290,10 @@ M: long-long-type box-return ( type -- ) c-ptr >>class [ alien-cell ] >>getter - [ set-alien-cell ] >>setter + [ [ >c-ptr ] 2dip set-alien-cell ] >>setter bootstrap-cell >>size bootstrap-cell >>align + [ >c-ptr ] >>unboxer-quot "box_alien" >>boxer "alien_offset" >>unboxer "void*" define-primitive-type diff --git a/basis/alien/complex/authors.txt b/basis/alien/complex/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/alien/complex/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor new file mode 100644 index 0000000000..0bff73b898 --- /dev/null +++ b/basis/alien/complex/complex-tests.factor @@ -0,0 +1,18 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.complex kernel alien.c-types alien.syntax +namespaces ; +IN: alien.complex.tests + +C-STRUCT: complex-holder + { "complex-float" "z" } ; + +: ( z -- alien ) + "complex-holder" + [ set-complex-holder-z ] keep ; + +[ ] [ + C{ 1.0 2.0 } "h" set +] unit-test + +[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test diff --git a/basis/alien/complex/complex.factor b/basis/alien/complex/complex.factor new file mode 100644 index 0000000000..60a84b9394 --- /dev/null +++ b/basis/alien/complex/complex.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.complex.functor sequences kernel ; +IN: alien.complex + +<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >> \ No newline at end of file diff --git a/basis/alien/complex/functor/authors.txt b/basis/alien/complex/functor/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/alien/complex/functor/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/alien/complex/functor/functor-tests.factor b/basis/alien/complex/functor/functor-tests.factor new file mode 100644 index 0000000000..c2df22be1d --- /dev/null +++ b/basis/alien/complex/functor/functor-tests.factor @@ -0,0 +1,4 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test alien.complex.functor ; +IN: alien.complex.functor.tests diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor new file mode 100644 index 0000000000..31af0291b4 --- /dev/null +++ b/basis/alien/complex/functor/functor.factor @@ -0,0 +1,35 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.structs alien.c-types math math.functions sequences +arrays kernel functors vocabs.parser namespaces accessors +quotations ; +IN: alien.complex.functor + +FUNCTOR: define-complex-type ( N T -- ) + +T-real DEFINES ${T}-real +T-imaginary DEFINES ${T}-imaginary +set-T-real DEFINES set-${T}-real +set-T-imaginary DEFINES set-${T}-imaginary + + DEFINES <${T}> +*T DEFINES *${T} + +WHERE + +: ( z -- alien ) + >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline + +: *T ( alien -- z ) + [ T-real ] [ T-imaginary ] bi rect> ; inline + +T in get +{ { N "real" } { N "imaginary" } } +define-struct + +T c-type + 1quotation >>unboxer-quot +*T 1quotation >>boxer-quot +drop + +;FUNCTOR diff --git a/basis/alien/complex/summary.txt b/basis/alien/complex/summary.txt new file mode 100644 index 0000000000..76c00c1d65 --- /dev/null +++ b/basis/alien/complex/summary.txt @@ -0,0 +1 @@ +Implementation details for C99 complex float and complex double types diff --git a/basis/math/blas/cblas/authors.txt b/basis/alien/fortran/authors.txt similarity index 100% rename from basis/math/blas/cblas/authors.txt rename to basis/alien/fortran/authors.txt diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor new file mode 100644 index 0000000000..c5d124e198 --- /dev/null +++ b/basis/alien/fortran/fortran-docs.factor @@ -0,0 +1,73 @@ +! Copyright (C) 2009 Joe Groff +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax kernel quotations sequences strings words.symbol ; +QUALIFIED-WITH: alien.syntax c +IN: alien.fortran + +ARTICLE: "alien.fortran-abis" "Fortran ABIs" +"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:" +{ $list + { { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." } + { { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." } + { { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." } + { { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." } +} +"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ; + +ARTICLE: "alien.fortran-types" "Fortran types" +"The Fortran FFI recognizes the following Fortran types:" +{ $list + { { $snippet "INTEGER" } " specifies a four-byte integer value. Sized integers can be specified with " { $snippet "INTEGER*1" } ", " { $snippet "INTEGER*2" } ", " { $snippet "INTEGER*4" } ", and " { $snippet "INTEGER*8" } "." } + { { $snippet "LOGICAL" } " specifies a four-byte boolean value. Sized booleans can be specified with " { $snippet "LOGICAL*1" } ", " { $snippet "LOGICAL*2" } ", " { $snippet "LOGICAL*4" } ", and " { $snippet "LOGICAL*8" } "." } + { { $snippet "REAL" } " specifies a single-precision floating-point real value." } + { { $snippet "DOUBLE-PRECISION" } " specifies a double-precision floating-point real value. The alias " { $snippet "REAL*8" } " is also recognized." } + { { $snippet "COMPLEX" } " specifies a single-precision floating-point complex value." } + { { $snippet "DOUBLE-COMPLEX" } " specifies a double-precision floating-point complex value. The alias " { $snippet "COMPLEX*16" } " is also recognized." } + { { $snippet "CHARACTER(n)" } " specifies a character string of length " { $snippet "n" } ". The Fortran 77 syntax " { $snippet "CHARACTER*n" } " is also recognized." } + { "Fortran arrays can be specified by suffixing a comma-separated set of dimensions in parentheses, e.g. " { $snippet "REAL(2,3,4)" } ". Arrays of unspecified length can be specified using " { $snippet "*" } " as a dimension. Arrays are passed in as flat " { $link "specialized-arrays" } "." } + { "Fortran records defined by " { $link POSTPONE: RECORD: } " and C structs defined by " { $link POSTPONE: c:C-STRUCT: } " are also supported as parameter and return types." } +} +"When declaring the parameters of Fortran functions, an output argument can be specified by prefixing an exclamation point to the type name. This will cause the function word to leave the final value of the parameter on the stack." ; + +HELP: FUNCTION: +{ $syntax "FUNCTION: RETURN-TYPE NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" } +{ $description "Declares a Fortran function binding with the given return type and arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ; + +HELP: SUBROUTINE: +{ $syntax "SUBROUTINE: NAME ( [!]ARGUMENT-TYPE NAME, ... ) ;" } +{ $description "Declares a Fortran subroutine binding with the given arguments. See " { $link "alien.fortran-types" } " for a list of supported types." } ; + +HELP: LIBRARY: +{ $syntax "LIBRARY: name" } +{ $values { "name" "a logical library name" } } +{ $description "Sets the logical library for subsequent " { $link POSTPONE: FUNCTION: } " and " { $link POSTPONE: SUBROUTINE: } " definitions. The given library name must have been opened with a previous call to " { $link add-fortran-library } "." } ; + +HELP: RECORD: +{ $syntax "RECORD: NAME { \"TYPE\" \"SLOT\" } ... ;" } +{ $description "Defines a Fortran record type with the given slots. The record is defined as the corresponding C struct and can be used as a type for subsequent Fortran or C function declarations." } ; + +HELP: add-fortran-library +{ $values { "name" string } { "soname" string } { "fortran-abi" symbol } } +{ $description "Opens the shared library in the file specified by " { $snippet "soname" } " under the logical name " { $snippet "name" } " so that it may be used in subsequent " { $link POSTPONE: LIBRARY: } " and " { $link fortran-invoke } " calls. Functions and subroutines from the library will be defined using the specified " { $snippet "fortran-abi" } ", which must be one of the supported " { $link "alien.fortran-abis" } "." } +; + +HELP: fortran-invoke +{ $values + { "return" string } { "library" string } { "procedure" string } { "parameters" sequence } +} +{ $description "Invokes the Fortran subroutine or function " { $snippet "procedure" } " in " { $snippet "library" } " with parameters specified by the " { $link "alien.fortran-types" } " specified in the " { $snippet "parameters" } " sequence. If the " { $snippet "return" } " value is " { $link f } ", no return value is expected, otherwise a return value of the specified Fortran type is expected. Input values are taken off the top of the datastack, and output values are left for the return value (if any) and any parameters specified as out parameters by prepending " { $snippet "\"!\"" } "." } +; + +ARTICLE: "alien.fortran" "Fortran FFI" +"The " { $vocab-link "alien.fortran" } " vocabulary provides an interface to code in shared libraries written in Fortran." +{ $subsection "alien.fortran-types" } +{ $subsection "alien.fortran-abis" } +{ $subsection add-fortran-library } +{ $subsection POSTPONE: LIBRARY: } +{ $subsection POSTPONE: FUNCTION: } +{ $subsection POSTPONE: SUBROUTINE: } +{ $subsection POSTPONE: RECORD: } +{ $subsection fortran-invoke } +; + +ABOUT: "alien.fortran" diff --git a/basis/alien/fortran/fortran-tests.factor b/basis/alien/fortran/fortran-tests.factor new file mode 100644 index 0000000000..177d1077c2 --- /dev/null +++ b/basis/alien/fortran/fortran-tests.factor @@ -0,0 +1,381 @@ +! (c) 2009 Joe Groff, see BSD license +USING: accessors alien alien.c-types alien.complex +alien.fortran alien.fortran.private alien.strings alien.structs +arrays assocs byte-arrays combinators fry +generalizations io.encodings.ascii kernel macros +macros.expander namespaces sequences shuffle tools.test ; +IN: alien.fortran.tests + +<< intel-unix-abi "(alien.fortran-tests)" (add-fortran-library) >> +LIBRARY: (alien.fortran-tests) +RECORD: FORTRAN_TEST_RECORD + { "INTEGER" "FOO" } + { "REAL(2)" "BAR" } + { "CHARACTER*4" "BAS" } ; + +intel-unix-abi fortran-abi [ + + ! fortran-name>symbol-name + + [ "fun_" ] [ "FUN" fortran-name>symbol-name ] unit-test + [ "fun_times_" ] [ "Fun_Times" fortran-name>symbol-name ] unit-test + [ "funtimes__" ] [ "FunTimes_" fortran-name>symbol-name ] unit-test + + ! fortran-type>c-type + + [ "short" ] + [ "integer*2" fortran-type>c-type ] unit-test + + [ "int" ] + [ "integer*4" fortran-type>c-type ] unit-test + + [ "int" ] + [ "INTEGER" fortran-type>c-type ] unit-test + + [ "longlong" ] + [ "iNteger*8" fortran-type>c-type ] unit-test + + [ "int[0]" ] + [ "integer(*)" fortran-type>c-type ] unit-test + + [ "int[0]" ] + [ "integer(3,*)" fortran-type>c-type ] unit-test + + [ "int[3]" ] + [ "integer(3)" fortran-type>c-type ] unit-test + + [ "int[6]" ] + [ "integer(3,2)" fortran-type>c-type ] unit-test + + [ "int[24]" ] + [ "integer(4,3,2)" fortran-type>c-type ] unit-test + + [ "char" ] + [ "character" fortran-type>c-type ] unit-test + + [ "char" ] + [ "character*1" fortran-type>c-type ] unit-test + + [ "char[17]" ] + [ "character*17" fortran-type>c-type ] unit-test + + [ "char[17]" ] + [ "character(17)" fortran-type>c-type ] unit-test + + [ "int" ] + [ "logical" fortran-type>c-type ] unit-test + + [ "float" ] + [ "real" fortran-type>c-type ] unit-test + + [ "double" ] + [ "double-precision" fortran-type>c-type ] unit-test + + [ "float" ] + [ "real*4" fortran-type>c-type ] unit-test + + [ "double" ] + [ "real*8" fortran-type>c-type ] unit-test + + [ "complex-float" ] + [ "complex" fortran-type>c-type ] unit-test + + [ "complex-double" ] + [ "double-complex" fortran-type>c-type ] unit-test + + [ "complex-float" ] + [ "complex*8" fortran-type>c-type ] unit-test + + [ "complex-double" ] + [ "complex*16" fortran-type>c-type ] unit-test + + [ "fortran_test_record" ] + [ "fortran_test_record" fortran-type>c-type ] unit-test + + ! fortran-arg-type>c-type + + [ "int*" { } ] + [ "integer" fortran-arg-type>c-type ] unit-test + + [ "int*" { } ] + [ "integer(3)" fortran-arg-type>c-type ] unit-test + + [ "int*" { } ] + [ "integer(*)" fortran-arg-type>c-type ] unit-test + + [ "fortran_test_record*" { } ] + [ "fortran_test_record" fortran-arg-type>c-type ] unit-test + + [ "char*" { } ] + [ "character" fortran-arg-type>c-type ] unit-test + + [ "char*" { } ] + [ "character(1)" fortran-arg-type>c-type ] unit-test + + [ "char*" { "long" } ] + [ "character(17)" fortran-arg-type>c-type ] unit-test + + ! fortran-ret-type>c-type + + [ "char" { } ] + [ "character(1)" fortran-ret-type>c-type ] unit-test + + [ "void" { "char*" "long" } ] + [ "character(17)" fortran-ret-type>c-type ] unit-test + + [ "int" { } ] + [ "integer" fortran-ret-type>c-type ] unit-test + + [ "int" { } ] + [ "logical" fortran-ret-type>c-type ] unit-test + + [ "float" { } ] + [ "real" fortran-ret-type>c-type ] unit-test + + [ "void" { "float*" } ] + [ "real(*)" fortran-ret-type>c-type ] unit-test + + [ "double" { } ] + [ "double-precision" fortran-ret-type>c-type ] unit-test + + [ "void" { "complex-float*" } ] + [ "complex" fortran-ret-type>c-type ] unit-test + + [ "void" { "complex-double*" } ] + [ "double-complex" fortran-ret-type>c-type ] unit-test + + [ "void" { "int*" } ] + [ "integer(*)" fortran-ret-type>c-type ] unit-test + + [ "void" { "fortran_test_record*" } ] + [ "fortran_test_record" fortran-ret-type>c-type ] unit-test + + ! fortran-sig>c-sig + + [ "float" { "int*" "char*" "float*" "double*" "long" } ] + [ "real" { "integer" "character*17" "real" "real*8" } fortran-sig>c-sig ] + unit-test + + [ "char" { "char*" "char*" "int*" "long" } ] + [ "character(1)" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test + + [ "void" { "char*" "long" "char*" "char*" "int*" "long" } ] + [ "character*18" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test + + [ "void" { "complex-float*" "char*" "char*" "int*" "long" } ] + [ "complex" { "character*17" "character" "integer" } fortran-sig>c-sig ] + unit-test + + ! fortran-record>c-struct + + [ { + { "double" "ex" } + { "float" "wye" } + { "int" "zee" } + { "char[20]" "woo" } + } ] [ + { + { "DOUBLE-PRECISION" "EX" } + { "REAL" "WYE" } + { "INTEGER" "ZEE" } + { "CHARACTER(20)" "WOO" } + } fortran-record>c-struct + ] unit-test + + ! RECORD: + + [ 16 ] [ "fortran_test_record" heap-size ] unit-test + [ 0 ] [ "foo" "fortran_test_record" offset-of ] unit-test + [ 4 ] [ "bar" "fortran_test_record" offset-of ] unit-test + [ 12 ] [ "bas" "fortran_test_record" offset-of ] unit-test + + ! (fortran-invoke) + + [ [ + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ ] + [ ] + [ 1 0 ? ] + } 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 + + [ [ + ! [] + [ "complex-float" ] 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 + + [ [ + ! [] + [ 20 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 + + [ [ + ! [] + [ 10 10 ] 3 ndip + ! [fortran-args>c-args] + { + [ { + [ ascii string>alien ] + [ ] + [ 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 diff --git a/basis/alien/fortran/fortran.factor b/basis/alien/fortran/fortran.factor new file mode 100644 index 0000000000..a2ffc55c02 --- /dev/null +++ b/basis/alien/fortran/fortran.factor @@ -0,0 +1,453 @@ +! (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 + +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 [ [ ] [ drop ] ] } + { 1 [ [ ] [ drop ] ] } + { 2 [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ 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 [ [ ] [ drop ] ] } + { 4 [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; + +M: real-complex-type (fortran-arg>c-args) + [ + size>> { + { f [ [ ] [ drop ] ] } + { 8 [ [ ] [ drop ] ] } + { 16 [ [ ] [ drop ] ] } + [ invalid-fortran-type ] + } case + ] args?dims ; + +M: double-precision-type (fortran-arg>c-args) + [ drop [ ] [ drop ] ] args?dims ; + +M: double-complex-type (fortran-arg>c-args) + [ drop [ ] [ drop ] ] args?dims ; + +M: character-type (fortran-arg>c-args) + fix-character-type single-char? + [ [ first ] [ 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: () ( type -- quot ) + +M: fortran-type () + (fortran-type>c-type) \ [ ] 2sequence ; + +M: character-type () + fix-character-type dims>> product dup + [ \ ] dip [ ] 3sequence ; + +: [] ( return parameters -- quot ) + [ parse-fortran-type ] dip + over returns-by-value? + [ 2drop [ ] ] + [ [ () ] [ 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 + \ 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 1 ] 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 ) + { + [ 2drop nip set-fortran-abi ] + [ 2nip [] ] + [ nip nip nip [fortran-args>c-args] ] + [ [fortran-invoke] ] + [ 2nip [fortran-results>] ] + } 4 ncleave 4 nappend ; + +MACRO: fortran-invoke ( return library function parameters -- ) + (fortran-invoke) ; + +:: 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 + diff --git a/basis/alien/fortran/summary.txt b/basis/alien/fortran/summary.txt new file mode 100644 index 0000000000..8ed8b0ca00 --- /dev/null +++ b/basis/alien/fortran/summary.txt @@ -0,0 +1 @@ +GNU Fortran/G77/F2C alien interface diff --git a/basis/alien/fortran/tags.txt b/basis/alien/fortran/tags.txt new file mode 100644 index 0000000000..2a9b5def7a --- /dev/null +++ b/basis/alien/fortran/tags.txt @@ -0,0 +1,2 @@ +fortran +ffi diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor index f5537fa239..0477683442 100644 --- a/basis/alien/structs/fields/fields.factor +++ b/basis/alien/structs/fields/fields.factor @@ -58,10 +58,7 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ; : define-getter ( type spec -- ) [ set-reader-props ] keep [ reader>> ] - [ - type>> - [ c-getter ] [ c-type-boxer-quot ] bi append - ] + [ type>> c-type-getter-boxer ] [ ] tri (( c-ptr -- value )) define-struct-slot-word ; diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor old mode 100644 new mode 100755 index ec0c01c2e7..8bc570c448 --- a/basis/alien/structs/structs-tests.factor +++ b/basis/alien/structs/structs-tests.factor @@ -42,3 +42,18 @@ C-UNION: barx [ ] [ \ foox-x "help" get execute ] unit-test [ ] [ \ set-foox-x "help" get execute ] unit-test ] when + +C-STRUCT: nested + { "int" "x" } ; + +C-STRUCT: nested-2 + { "nested" "y" } ; + +[ 4 ] [ + "nested-2" + "nested" + 4 over set-nested-x + over set-nested-2-y + nested-2-y + nested-x +] unit-test diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor old mode 100644 new mode 100755 index 42923fb28b..8ec694198d --- a/basis/alien/structs/structs.factor +++ b/basis/alien/structs/structs.factor @@ -1,11 +1,19 @@ ! 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 ; IN: alien.structs -TUPLE: struct-type size align fields ; +TUPLE: struct-type +size +align +fields +{ boxer-quot callable } +{ unboxer-quot callable } +{ getter callable } +{ setter callable } ; M: struct-type heap-size size>> ; @@ -15,6 +23,10 @@ M: struct-type c-type-align align>> ; M: struct-type c-type-stack-align? drop f ; +M: struct-type c-type-boxer-quot boxer-quot>> ; + +M: struct-type c-type-unboxer-quot unboxer-quot>> ; + : if-value-struct ( ctype true false -- ) [ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline @@ -40,7 +52,10 @@ M: struct-type stack-size : (define-struct) ( name size align fields -- ) [ [ align ] keep ] dip - struct-type boa + struct-type new + swap >>fields + swap >>align + swap >>size swap typedef ; : make-fields ( name vocab fields -- fields ) @@ -61,3 +76,8 @@ M: struct-type stack-size [ expand-constants ] map [ [ heap-size ] [ max ] map-reduce ] keep compute-struct-align f (define-struct) ; + +: offset-of ( field struct -- offset ) + c-types get at fields>> + [ name>> = ] with find nip offset>> ; + diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor index f1ba71ce1e..3da22e09d6 100644 --- a/basis/bit-arrays/bit-arrays.factor +++ b/basis/bit-arrays/bit-arrays.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types accessors math alien.accessors kernel -kernel.private locals sequences sequences.private byte-arrays +kernel.private sequences sequences.private byte-arrays parser prettyprint.custom fry ; IN: bit-arrays @@ -70,16 +70,15 @@ M: bit-array byte-length length 7 + -3 shift ; : ?{ \ } [ >bit-array ] parse-literal ; parsing -:: integer>bit-array ( n -- bit-array ) - n zero? [ 0 ] [ - [let | out [ n log2 1+ ] 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 = [ + + ] [ + [ log2 1+ 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 ) diff --git a/basis/call/call-docs.factor b/basis/call/call-docs.factor new file mode 100644 index 0000000000..463bfdac09 --- /dev/null +++ b/basis/call/call-docs.factor @@ -0,0 +1,32 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax quotations effects words ; +IN: call + +ABOUT: "call" + +ARTICLE: "call" "Calling code with known stack effects" +"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate." +{ $subsection POSTPONE: call( } +{ $subsection POSTPONE: execute( } +{ $subsection call-effect } +{ $subsection execute-effect } ; + +HELP: call( +{ $syntax "[ ] call( foo -- bar )" } +{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ; + +HELP: call-effect +{ $values { "quot" quotation } { "effect" effect } } +{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ; + +HELP: execute( +{ $syntax "word execute( foo -- bar )" } +{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ; + +HELP: execute-effect +{ $values { "word" word } { "effect" effect } } +{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ; + +{ execute-effect call-effect } related-words +{ POSTPONE: call( POSTPONE: execute( } related-words diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor new file mode 100644 index 0000000000..a2bd11b06a --- /dev/null +++ b/basis/call/call-tests.factor @@ -0,0 +1,15 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: math tools.test call kernel ; +IN: call.tests + +[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test +[ 1 2 [ + ] call( -- z ) ] must-fail +[ 1 2 [ + ] call( x y -- z a ) ] must-fail +[ 1 2 3 { 4 } ] [ 1 2 3 4 [ datastack nip ] call( x -- y ) ] unit-test +[ [ + ] call( x y -- z ) ] must-infer + +[ 3 ] [ 1 2 \ + execute( x y -- z ) ] unit-test +[ 1 2 \ + execute( -- z ) ] must-fail +[ 1 2 \ + execute( x y -- z a ) ] must-fail +[ \ + execute( x y -- z ) ] must-infer diff --git a/basis/call/call.factor b/basis/call/call.factor new file mode 100644 index 0000000000..9b49acf64a --- /dev/null +++ b/basis/call/call.factor @@ -0,0 +1,30 @@ +! Copyright (C) 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel macros fry summary sequences generalizations accessors +continuations effects.parser parser words ; +IN: call + +ERROR: wrong-values values quot length-required ; + +M: wrong-values summary + drop "Wrong number of values returned from quotation" ; + + + +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 diff --git a/basis/cocoa/cocoa.factor b/basis/cocoa/cocoa.factor index 44252a3b19..01f134e283 100644 --- a/basis/cocoa/cocoa.factor +++ b/basis/cocoa/cocoa.factor @@ -29,7 +29,7 @@ SYMBOL: super-sent-messages SYMBOL: frameworks -frameworks global [ V{ } clone or ] change-at +frameworks [ V{ } clone ] initialize [ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index ebe98a2df1..ce66467203 100644 --- a/basis/cocoa/messages/messages.factor +++ b/basis/cocoa/messages/messages.factor @@ -5,7 +5,7 @@ continuations combinators compiler compiler.alien kernel math namespaces make parser quotations sequences strings words cocoa.runtime io macros memoize io.encodings.utf8 effects libc libc.private parser lexer init core-foundation fry -generalizations specialized-arrays.direct.alien ; +generalizations specialized-arrays.direct.alien call ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -19,8 +19,8 @@ IN: cocoa.messages SYMBOL: message-senders SYMBOL: super-message-senders -message-senders global [ H{ } assoc-like ] change-at -super-message-senders global [ H{ } assoc-like ] change-at +message-senders [ H{ } clone ] initialize +super-message-senders [ H{ } clone ] initialize : cache-stub ( method function hash -- ) [ @@ -53,7 +53,7 @@ MEMO: ( name -- sel ) f \ selector boa ; SYMBOL: objc-methods -objc-methods global [ H{ } assoc-like ] change-at +objc-methods [ H{ } clone ] initialize : lookup-method ( selector -- method ) dup objc-methods get at @@ -79,11 +79,11 @@ MACRO: (send) ( selector super? -- quot ) ! Runtime introspection SYMBOL: class-init-hooks -class-init-hooks global [ H{ } clone or ] change-at +class-init-hooks [ H{ } clone ] initialize : (objc-class) ( name word -- class ) 2dup execute dup [ 2nip ] [ - drop over class-init-hooks get at [ assert-depth ] when* + drop over class-init-hooks get at [ call( -- ) ] when* 2dup execute dup [ 2nip ] [ 2drop "No such class: " prepend throw ] if @@ -202,7 +202,7 @@ assoc-union alien>objc-types set-global [ 0 [ class_copyMethodList ] keep *uint ] dip over 0 = [ 3drop ] [ [ ] dip - [ each ] [ drop underlying>> (free) ] 2bi + [ each ] [ drop (free) ] 2bi ] if ; inline : register-objc-methods ( class -- ) diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index 03cafd0a0a..e74e912202 100644 --- a/basis/cocoa/views/views.factor +++ b/basis/cocoa/views/views.factor @@ -68,7 +68,7 @@ PRIVATE> NSOpenGLPFASamples , 8 , ] when 0 , - ] int-array{ } make underlying>> + ] int-array{ } make -> initWithAttributes: -> autorelease ; diff --git a/basis/colors/constants/authors.txt b/basis/colors/constants/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/basis/colors/constants/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/basis/colors/constants/constants-tests.factor b/basis/colors/constants/constants-tests.factor new file mode 100644 index 0000000000..08b05a34e7 --- /dev/null +++ b/basis/colors/constants/constants-tests.factor @@ -0,0 +1,6 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test colors.constants colors ; +IN: colors.constants.tests + +[ t ] [ COLOR: light-green rgba? ] unit-test \ No newline at end of file diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor new file mode 100644 index 0000000000..e298b3b61e --- /dev/null +++ b/basis/colors/constants/constants.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel assocs math math.parser memoize +io.encodings.ascii io.files lexer parser +colors sequences splitting combinators.smart ascii ; +IN: colors.constants + +number 255 /f ] tri@ 1.0 ] dip + [ blank? ] trim-head { { CHAR: \s CHAR: - } } substitute swap + ] inputassoc ; + +MEMO: rgb.txt ( -- assoc ) + "resource:basis/colors/constants/rgb.txt" ascii file-lines parse-rgb.txt ; + +PRIVATE> + +ERROR: no-such-color name ; + +: named-color ( name -- rgb ) + dup rgb.txt at [ ] [ no-such-color ] ?if ; + +: COLOR: scan named-color parsed ; parsing \ No newline at end of file diff --git a/basis/colors/constants/rgb.txt b/basis/colors/constants/rgb.txt new file mode 100644 index 0000000000..62eb8961ec --- /dev/null +++ b/basis/colors/constants/rgb.txt @@ -0,0 +1,753 @@ +! $Xorg: rgb.txt,v 1.3 2000/08/17 19:54:00 cpqbld Exp $ +255 250 250 snow +248 248 255 ghost white +248 248 255 GhostWhite +245 245 245 white smoke +245 245 245 WhiteSmoke +220 220 220 gainsboro +255 250 240 floral white +255 250 240 FloralWhite +253 245 230 old lace +253 245 230 OldLace +250 240 230 linen +250 235 215 antique white +250 235 215 AntiqueWhite +255 239 213 papaya whip +255 239 213 PapayaWhip +255 235 205 blanched almond +255 235 205 BlanchedAlmond +255 228 196 bisque +255 218 185 peach puff +255 218 185 PeachPuff +255 222 173 navajo white +255 222 173 NavajoWhite +255 228 181 moccasin +255 248 220 cornsilk +255 255 240 ivory +255 250 205 lemon chiffon +255 250 205 LemonChiffon +255 245 238 seashell +240 255 240 honeydew +245 255 250 mint cream +245 255 250 MintCream +240 255 255 azure +240 248 255 alice blue +240 248 255 AliceBlue +230 230 250 lavender +255 240 245 lavender blush +255 240 245 LavenderBlush +255 228 225 misty rose +255 228 225 MistyRose +255 255 255 white + 0 0 0 black + 47 79 79 dark slate gray + 47 79 79 DarkSlateGray + 47 79 79 dark slate grey + 47 79 79 DarkSlateGrey +105 105 105 dim gray +105 105 105 DimGray +105 105 105 dim grey +105 105 105 DimGrey +112 128 144 slate gray +112 128 144 SlateGray +112 128 144 slate grey +112 128 144 SlateGrey +119 136 153 light slate gray +119 136 153 LightSlateGray +119 136 153 light slate grey +119 136 153 LightSlateGrey +190 190 190 gray +190 190 190 grey +211 211 211 light grey +211 211 211 LightGrey +211 211 211 light gray +211 211 211 LightGray + 25 25 112 midnight blue + 25 25 112 MidnightBlue + 0 0 128 navy + 0 0 128 navy blue + 0 0 128 NavyBlue +100 149 237 cornflower blue +100 149 237 CornflowerBlue + 72 61 139 dark slate blue + 72 61 139 DarkSlateBlue +106 90 205 slate blue +106 90 205 SlateBlue +123 104 238 medium slate blue +123 104 238 MediumSlateBlue +132 112 255 light slate blue +132 112 255 LightSlateBlue + 0 0 205 medium blue + 0 0 205 MediumBlue + 65 105 225 royal blue + 65 105 225 RoyalBlue + 0 0 255 blue + 30 144 255 dodger blue + 30 144 255 DodgerBlue + 0 191 255 deep sky blue + 0 191 255 DeepSkyBlue +135 206 235 sky blue +135 206 235 SkyBlue +135 206 250 light sky blue +135 206 250 LightSkyBlue + 70 130 180 steel blue + 70 130 180 SteelBlue +176 196 222 light steel blue +176 196 222 LightSteelBlue +173 216 230 light blue +173 216 230 LightBlue +176 224 230 powder blue +176 224 230 PowderBlue +175 238 238 pale turquoise +175 238 238 PaleTurquoise + 0 206 209 dark turquoise + 0 206 209 DarkTurquoise + 72 209 204 medium turquoise + 72 209 204 MediumTurquoise + 64 224 208 turquoise + 0 255 255 cyan +224 255 255 light cyan +224 255 255 LightCyan + 95 158 160 cadet blue + 95 158 160 CadetBlue +102 205 170 medium aquamarine +102 205 170 MediumAquamarine +127 255 212 aquamarine + 0 100 0 dark green + 0 100 0 DarkGreen + 85 107 47 dark olive green + 85 107 47 DarkOliveGreen +143 188 143 dark sea green +143 188 143 DarkSeaGreen + 46 139 87 sea green + 46 139 87 SeaGreen + 60 179 113 medium sea green + 60 179 113 MediumSeaGreen + 32 178 170 light sea green + 32 178 170 LightSeaGreen +152 251 152 pale green +152 251 152 PaleGreen + 0 255 127 spring green + 0 255 127 SpringGreen +124 252 0 lawn green +124 252 0 LawnGreen + 0 255 0 green +127 255 0 chartreuse + 0 250 154 medium spring green + 0 250 154 MediumSpringGreen +173 255 47 green yellow +173 255 47 GreenYellow + 50 205 50 lime green + 50 205 50 LimeGreen +154 205 50 yellow green +154 205 50 YellowGreen + 34 139 34 forest green + 34 139 34 ForestGreen +107 142 35 olive drab +107 142 35 OliveDrab +189 183 107 dark khaki +189 183 107 DarkKhaki +240 230 140 khaki +238 232 170 pale goldenrod +238 232 170 PaleGoldenrod +250 250 210 light goldenrod yellow +250 250 210 LightGoldenrodYellow +255 255 224 light yellow +255 255 224 LightYellow +255 255 0 yellow +255 215 0 gold +238 221 130 light goldenrod +238 221 130 LightGoldenrod +218 165 32 goldenrod +184 134 11 dark goldenrod +184 134 11 DarkGoldenrod +188 143 143 rosy brown +188 143 143 RosyBrown +205 92 92 indian red +205 92 92 IndianRed +139 69 19 saddle brown +139 69 19 SaddleBrown +160 82 45 sienna +205 133 63 peru +222 184 135 burlywood +245 245 220 beige +245 222 179 wheat +244 164 96 sandy brown +244 164 96 SandyBrown +210 180 140 tan +210 105 30 chocolate +178 34 34 firebrick +165 42 42 brown +233 150 122 dark salmon +233 150 122 DarkSalmon +250 128 114 salmon +255 160 122 light salmon +255 160 122 LightSalmon +255 165 0 orange +255 140 0 dark orange +255 140 0 DarkOrange +255 127 80 coral +240 128 128 light coral +240 128 128 LightCoral +255 99 71 tomato +255 69 0 orange red +255 69 0 OrangeRed +255 0 0 red +255 105 180 hot pink +255 105 180 HotPink +255 20 147 deep pink +255 20 147 DeepPink +255 192 203 pink +255 182 193 light pink +255 182 193 LightPink +219 112 147 pale violet red +219 112 147 PaleVioletRed +176 48 96 maroon +199 21 133 medium violet red +199 21 133 MediumVioletRed +208 32 144 violet red +208 32 144 VioletRed +255 0 255 magenta +238 130 238 violet +221 160 221 plum +218 112 214 orchid +186 85 211 medium orchid +186 85 211 MediumOrchid +153 50 204 dark orchid +153 50 204 DarkOrchid +148 0 211 dark violet +148 0 211 DarkViolet +138 43 226 blue violet +138 43 226 BlueViolet +160 32 240 purple +147 112 219 medium purple +147 112 219 MediumPurple +216 191 216 thistle +255 250 250 snow1 +238 233 233 snow2 +205 201 201 snow3 +139 137 137 snow4 +255 245 238 seashell1 +238 229 222 seashell2 +205 197 191 seashell3 +139 134 130 seashell4 +255 239 219 AntiqueWhite1 +238 223 204 AntiqueWhite2 +205 192 176 AntiqueWhite3 +139 131 120 AntiqueWhite4 +255 228 196 bisque1 +238 213 183 bisque2 +205 183 158 bisque3 +139 125 107 bisque4 +255 218 185 PeachPuff1 +238 203 173 PeachPuff2 +205 175 149 PeachPuff3 +139 119 101 PeachPuff4 +255 222 173 NavajoWhite1 +238 207 161 NavajoWhite2 +205 179 139 NavajoWhite3 +139 121 94 NavajoWhite4 +255 250 205 LemonChiffon1 +238 233 191 LemonChiffon2 +205 201 165 LemonChiffon3 +139 137 112 LemonChiffon4 +255 248 220 cornsilk1 +238 232 205 cornsilk2 +205 200 177 cornsilk3 +139 136 120 cornsilk4 +255 255 240 ivory1 +238 238 224 ivory2 +205 205 193 ivory3 +139 139 131 ivory4 +240 255 240 honeydew1 +224 238 224 honeydew2 +193 205 193 honeydew3 +131 139 131 honeydew4 +255 240 245 LavenderBlush1 +238 224 229 LavenderBlush2 +205 193 197 LavenderBlush3 +139 131 134 LavenderBlush4 +255 228 225 MistyRose1 +238 213 210 MistyRose2 +205 183 181 MistyRose3 +139 125 123 MistyRose4 +240 255 255 azure1 +224 238 238 azure2 +193 205 205 azure3 +131 139 139 azure4 +131 111 255 SlateBlue1 +122 103 238 SlateBlue2 +105 89 205 SlateBlue3 + 71 60 139 SlateBlue4 + 72 118 255 RoyalBlue1 + 67 110 238 RoyalBlue2 + 58 95 205 RoyalBlue3 + 39 64 139 RoyalBlue4 + 0 0 255 blue1 + 0 0 238 blue2 + 0 0 205 blue3 + 0 0 139 blue4 + 30 144 255 DodgerBlue1 + 28 134 238 DodgerBlue2 + 24 116 205 DodgerBlue3 + 16 78 139 DodgerBlue4 + 99 184 255 SteelBlue1 + 92 172 238 SteelBlue2 + 79 148 205 SteelBlue3 + 54 100 139 SteelBlue4 + 0 191 255 DeepSkyBlue1 + 0 178 238 DeepSkyBlue2 + 0 154 205 DeepSkyBlue3 + 0 104 139 DeepSkyBlue4 +135 206 255 SkyBlue1 +126 192 238 SkyBlue2 +108 166 205 SkyBlue3 + 74 112 139 SkyBlue4 +176 226 255 LightSkyBlue1 +164 211 238 LightSkyBlue2 +141 182 205 LightSkyBlue3 + 96 123 139 LightSkyBlue4 +198 226 255 SlateGray1 +185 211 238 SlateGray2 +159 182 205 SlateGray3 +108 123 139 SlateGray4 +202 225 255 LightSteelBlue1 +188 210 238 LightSteelBlue2 +162 181 205 LightSteelBlue3 +110 123 139 LightSteelBlue4 +191 239 255 LightBlue1 +178 223 238 LightBlue2 +154 192 205 LightBlue3 +104 131 139 LightBlue4 +224 255 255 LightCyan1 +209 238 238 LightCyan2 +180 205 205 LightCyan3 +122 139 139 LightCyan4 +187 255 255 PaleTurquoise1 +174 238 238 PaleTurquoise2 +150 205 205 PaleTurquoise3 +102 139 139 PaleTurquoise4 +152 245 255 CadetBlue1 +142 229 238 CadetBlue2 +122 197 205 CadetBlue3 + 83 134 139 CadetBlue4 + 0 245 255 turquoise1 + 0 229 238 turquoise2 + 0 197 205 turquoise3 + 0 134 139 turquoise4 + 0 255 255 cyan1 + 0 238 238 cyan2 + 0 205 205 cyan3 + 0 139 139 cyan4 +151 255 255 DarkSlateGray1 +141 238 238 DarkSlateGray2 +121 205 205 DarkSlateGray3 + 82 139 139 DarkSlateGray4 +127 255 212 aquamarine1 +118 238 198 aquamarine2 +102 205 170 aquamarine3 + 69 139 116 aquamarine4 +193 255 193 DarkSeaGreen1 +180 238 180 DarkSeaGreen2 +155 205 155 DarkSeaGreen3 +105 139 105 DarkSeaGreen4 + 84 255 159 SeaGreen1 + 78 238 148 SeaGreen2 + 67 205 128 SeaGreen3 + 46 139 87 SeaGreen4 +154 255 154 PaleGreen1 +144 238 144 PaleGreen2 +124 205 124 PaleGreen3 + 84 139 84 PaleGreen4 + 0 255 127 SpringGreen1 + 0 238 118 SpringGreen2 + 0 205 102 SpringGreen3 + 0 139 69 SpringGreen4 + 0 255 0 green1 + 0 238 0 green2 + 0 205 0 green3 + 0 139 0 green4 +127 255 0 chartreuse1 +118 238 0 chartreuse2 +102 205 0 chartreuse3 + 69 139 0 chartreuse4 +192 255 62 OliveDrab1 +179 238 58 OliveDrab2 +154 205 50 OliveDrab3 +105 139 34 OliveDrab4 +202 255 112 DarkOliveGreen1 +188 238 104 DarkOliveGreen2 +162 205 90 DarkOliveGreen3 +110 139 61 DarkOliveGreen4 +255 246 143 khaki1 +238 230 133 khaki2 +205 198 115 khaki3 +139 134 78 khaki4 +255 236 139 LightGoldenrod1 +238 220 130 LightGoldenrod2 +205 190 112 LightGoldenrod3 +139 129 76 LightGoldenrod4 +255 255 224 LightYellow1 +238 238 209 LightYellow2 +205 205 180 LightYellow3 +139 139 122 LightYellow4 +255 255 0 yellow1 +238 238 0 yellow2 +205 205 0 yellow3 +139 139 0 yellow4 +255 215 0 gold1 +238 201 0 gold2 +205 173 0 gold3 +139 117 0 gold4 +255 193 37 goldenrod1 +238 180 34 goldenrod2 +205 155 29 goldenrod3 +139 105 20 goldenrod4 +255 185 15 DarkGoldenrod1 +238 173 14 DarkGoldenrod2 +205 149 12 DarkGoldenrod3 +139 101 8 DarkGoldenrod4 +255 193 193 RosyBrown1 +238 180 180 RosyBrown2 +205 155 155 RosyBrown3 +139 105 105 RosyBrown4 +255 106 106 IndianRed1 +238 99 99 IndianRed2 +205 85 85 IndianRed3 +139 58 58 IndianRed4 +255 130 71 sienna1 +238 121 66 sienna2 +205 104 57 sienna3 +139 71 38 sienna4 +255 211 155 burlywood1 +238 197 145 burlywood2 +205 170 125 burlywood3 +139 115 85 burlywood4 +255 231 186 wheat1 +238 216 174 wheat2 +205 186 150 wheat3 +139 126 102 wheat4 +255 165 79 tan1 +238 154 73 tan2 +205 133 63 tan3 +139 90 43 tan4 +255 127 36 chocolate1 +238 118 33 chocolate2 +205 102 29 chocolate3 +139 69 19 chocolate4 +255 48 48 firebrick1 +238 44 44 firebrick2 +205 38 38 firebrick3 +139 26 26 firebrick4 +255 64 64 brown1 +238 59 59 brown2 +205 51 51 brown3 +139 35 35 brown4 +255 140 105 salmon1 +238 130 98 salmon2 +205 112 84 salmon3 +139 76 57 salmon4 +255 160 122 LightSalmon1 +238 149 114 LightSalmon2 +205 129 98 LightSalmon3 +139 87 66 LightSalmon4 +255 165 0 orange1 +238 154 0 orange2 +205 133 0 orange3 +139 90 0 orange4 +255 127 0 DarkOrange1 +238 118 0 DarkOrange2 +205 102 0 DarkOrange3 +139 69 0 DarkOrange4 +255 114 86 coral1 +238 106 80 coral2 +205 91 69 coral3 +139 62 47 coral4 +255 99 71 tomato1 +238 92 66 tomato2 +205 79 57 tomato3 +139 54 38 tomato4 +255 69 0 OrangeRed1 +238 64 0 OrangeRed2 +205 55 0 OrangeRed3 +139 37 0 OrangeRed4 +255 0 0 red1 +238 0 0 red2 +205 0 0 red3 +139 0 0 red4 +255 20 147 DeepPink1 +238 18 137 DeepPink2 +205 16 118 DeepPink3 +139 10 80 DeepPink4 +255 110 180 HotPink1 +238 106 167 HotPink2 +205 96 144 HotPink3 +139 58 98 HotPink4 +255 181 197 pink1 +238 169 184 pink2 +205 145 158 pink3 +139 99 108 pink4 +255 174 185 LightPink1 +238 162 173 LightPink2 +205 140 149 LightPink3 +139 95 101 LightPink4 +255 130 171 PaleVioletRed1 +238 121 159 PaleVioletRed2 +205 104 137 PaleVioletRed3 +139 71 93 PaleVioletRed4 +255 52 179 maroon1 +238 48 167 maroon2 +205 41 144 maroon3 +139 28 98 maroon4 +255 62 150 VioletRed1 +238 58 140 VioletRed2 +205 50 120 VioletRed3 +139 34 82 VioletRed4 +255 0 255 magenta1 +238 0 238 magenta2 +205 0 205 magenta3 +139 0 139 magenta4 +255 131 250 orchid1 +238 122 233 orchid2 +205 105 201 orchid3 +139 71 137 orchid4 +255 187 255 plum1 +238 174 238 plum2 +205 150 205 plum3 +139 102 139 plum4 +224 102 255 MediumOrchid1 +209 95 238 MediumOrchid2 +180 82 205 MediumOrchid3 +122 55 139 MediumOrchid4 +191 62 255 DarkOrchid1 +178 58 238 DarkOrchid2 +154 50 205 DarkOrchid3 +104 34 139 DarkOrchid4 +155 48 255 purple1 +145 44 238 purple2 +125 38 205 purple3 + 85 26 139 purple4 +171 130 255 MediumPurple1 +159 121 238 MediumPurple2 +137 104 205 MediumPurple3 + 93 71 139 MediumPurple4 +255 225 255 thistle1 +238 210 238 thistle2 +205 181 205 thistle3 +139 123 139 thistle4 + 0 0 0 gray0 + 0 0 0 grey0 + 3 3 3 gray1 + 3 3 3 grey1 + 5 5 5 gray2 + 5 5 5 grey2 + 8 8 8 gray3 + 8 8 8 grey3 + 10 10 10 gray4 + 10 10 10 grey4 + 13 13 13 gray5 + 13 13 13 grey5 + 15 15 15 gray6 + 15 15 15 grey6 + 18 18 18 gray7 + 18 18 18 grey7 + 20 20 20 gray8 + 20 20 20 grey8 + 23 23 23 gray9 + 23 23 23 grey9 + 26 26 26 gray10 + 26 26 26 grey10 + 28 28 28 gray11 + 28 28 28 grey11 + 31 31 31 gray12 + 31 31 31 grey12 + 33 33 33 gray13 + 33 33 33 grey13 + 36 36 36 gray14 + 36 36 36 grey14 + 38 38 38 gray15 + 38 38 38 grey15 + 41 41 41 gray16 + 41 41 41 grey16 + 43 43 43 gray17 + 43 43 43 grey17 + 46 46 46 gray18 + 46 46 46 grey18 + 48 48 48 gray19 + 48 48 48 grey19 + 51 51 51 gray20 + 51 51 51 grey20 + 54 54 54 gray21 + 54 54 54 grey21 + 56 56 56 gray22 + 56 56 56 grey22 + 59 59 59 gray23 + 59 59 59 grey23 + 61 61 61 gray24 + 61 61 61 grey24 + 64 64 64 gray25 + 64 64 64 grey25 + 66 66 66 gray26 + 66 66 66 grey26 + 69 69 69 gray27 + 69 69 69 grey27 + 71 71 71 gray28 + 71 71 71 grey28 + 74 74 74 gray29 + 74 74 74 grey29 + 77 77 77 gray30 + 77 77 77 grey30 + 79 79 79 gray31 + 79 79 79 grey31 + 82 82 82 gray32 + 82 82 82 grey32 + 84 84 84 gray33 + 84 84 84 grey33 + 87 87 87 gray34 + 87 87 87 grey34 + 89 89 89 gray35 + 89 89 89 grey35 + 92 92 92 gray36 + 92 92 92 grey36 + 94 94 94 gray37 + 94 94 94 grey37 + 97 97 97 gray38 + 97 97 97 grey38 + 99 99 99 gray39 + 99 99 99 grey39 +102 102 102 gray40 +102 102 102 grey40 +105 105 105 gray41 +105 105 105 grey41 +107 107 107 gray42 +107 107 107 grey42 +110 110 110 gray43 +110 110 110 grey43 +112 112 112 gray44 +112 112 112 grey44 +115 115 115 gray45 +115 115 115 grey45 +117 117 117 gray46 +117 117 117 grey46 +120 120 120 gray47 +120 120 120 grey47 +122 122 122 gray48 +122 122 122 grey48 +125 125 125 gray49 +125 125 125 grey49 +127 127 127 gray50 +127 127 127 grey50 +130 130 130 gray51 +130 130 130 grey51 +133 133 133 gray52 +133 133 133 grey52 +135 135 135 gray53 +135 135 135 grey53 +138 138 138 gray54 +138 138 138 grey54 +140 140 140 gray55 +140 140 140 grey55 +143 143 143 gray56 +143 143 143 grey56 +145 145 145 gray57 +145 145 145 grey57 +148 148 148 gray58 +148 148 148 grey58 +150 150 150 gray59 +150 150 150 grey59 +153 153 153 gray60 +153 153 153 grey60 +156 156 156 gray61 +156 156 156 grey61 +158 158 158 gray62 +158 158 158 grey62 +161 161 161 gray63 +161 161 161 grey63 +163 163 163 gray64 +163 163 163 grey64 +166 166 166 gray65 +166 166 166 grey65 +168 168 168 gray66 +168 168 168 grey66 +171 171 171 gray67 +171 171 171 grey67 +173 173 173 gray68 +173 173 173 grey68 +176 176 176 gray69 +176 176 176 grey69 +179 179 179 gray70 +179 179 179 grey70 +181 181 181 gray71 +181 181 181 grey71 +184 184 184 gray72 +184 184 184 grey72 +186 186 186 gray73 +186 186 186 grey73 +189 189 189 gray74 +189 189 189 grey74 +191 191 191 gray75 +191 191 191 grey75 +194 194 194 gray76 +194 194 194 grey76 +196 196 196 gray77 +196 196 196 grey77 +199 199 199 gray78 +199 199 199 grey78 +201 201 201 gray79 +201 201 201 grey79 +204 204 204 gray80 +204 204 204 grey80 +207 207 207 gray81 +207 207 207 grey81 +209 209 209 gray82 +209 209 209 grey82 +212 212 212 gray83 +212 212 212 grey83 +214 214 214 gray84 +214 214 214 grey84 +217 217 217 gray85 +217 217 217 grey85 +219 219 219 gray86 +219 219 219 grey86 +222 222 222 gray87 +222 222 222 grey87 +224 224 224 gray88 +224 224 224 grey88 +227 227 227 gray89 +227 227 227 grey89 +229 229 229 gray90 +229 229 229 grey90 +232 232 232 gray91 +232 232 232 grey91 +235 235 235 gray92 +235 235 235 grey92 +237 237 237 gray93 +237 237 237 grey93 +240 240 240 gray94 +240 240 240 grey94 +242 242 242 gray95 +242 242 242 grey95 +245 245 245 gray96 +245 245 245 grey96 +247 247 247 gray97 +247 247 247 grey97 +250 250 250 gray98 +250 250 250 grey98 +252 252 252 gray99 +252 252 252 grey99 +255 255 255 gray100 +255 255 255 grey100 +169 169 169 dark grey +169 169 169 DarkGrey +169 169 169 dark gray +169 169 169 DarkGray +0 0 139 dark blue +0 0 139 DarkBlue +0 139 139 dark cyan +0 139 139 DarkCyan +139 0 139 dark magenta +139 0 139 DarkMagenta +139 0 0 dark red +139 0 0 DarkRed +144 238 144 light green +144 238 144 LightGreen diff --git a/basis/colors/constants/summary.txt b/basis/colors/constants/summary.txt new file mode 100644 index 0000000000..5551048750 --- /dev/null +++ b/basis/colors/constants/summary.txt @@ -0,0 +1 @@ +A utility to look up colors in the X11 rgb.txt color database diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 370dc26960..69a3a821e5 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -37,3 +37,11 @@ IN: combinators.smart.tests [ [ { 1 } { 2 } { 3 } ] B{ } append-outputs-as ] unit-test + +! Test nesting +: nested-smart-combo-test ( -- array ) + [ [ 1 2 ] output>array [ 3 4 ] output>array ] output>array ; + +\ nested-smart-combo-test must-infer + +[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test \ No newline at end of file diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 71d9c36412..d915b29ae5 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -3,8 +3,8 @@ USING: namespaces make math math.order math.parser sequences accessors kernel kernel.private layouts assocs words summary arrays combinators classes.algebra alien alien.c-types alien.structs -alien.strings alien.arrays sets libc continuations.private -fry cpu.architecture +alien.strings alien.arrays alien.complex sets libc +continuations.private fry cpu.architecture compiler.errors compiler.alien compiler.cfg diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor index 1b21e40bac..f3c2deb2d8 100644 --- a/basis/compiler/tests/alien.factor +++ b/basis/compiler/tests/alien.factor @@ -198,8 +198,8 @@ FUNCTION: int ffi_test_12 int a int b rect c int d int e int f ; FUNCTION: float ffi_test_23 ( float[3] x, float[3] y ) ; [ 32.0 ] [ - { 1.0 2.0 3.0 } >float-array underlying>> - { 4.0 5.0 6.0 } >float-array underlying>> + { 1.0 2.0 3.0 } >float-array + { 4.0 5.0 6.0 } >float-array ffi_test_23 ] unit-test @@ -558,3 +558,18 @@ FUNCTION: test_struct_14 ffi_test_44 ( ) ; inline : stack-frame-bustage ( -- a b ) ffi_test_44 gc 3 ; [ ] [ stack-frame-bustage 2drop ] unit-test + +FUNCTION: complex-float ffi_test_45 ( int x ) ; + +[ C{ 3.0 0.0 } ] [ 3 ffi_test_45 ] unit-test + +FUNCTION: complex-double ffi_test_46 ( int x ) ; + +[ C{ 3.0 0.0 } ] [ 3 ffi_test_46 ] unit-test + +FUNCTION: complex-float ffi_test_47 ( complex-float x, complex-double y ) ; + +[ C{ 4.0 4.0 } ] [ + C{ 1.0 2.0 } + C{ 1.5 1.0 } ffi_test_47 +] unit-test diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index f3b3238b4e..06d8d4f733 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel arrays sequences math math.order +USING: accessors kernel arrays sequences math math.order call math.partial-dispatch generic generic.standard generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart @@ -181,8 +181,9 @@ SYMBOL: history "custom-inlining" word-prop ; : inline-custom ( #call word -- ? ) - [ dup 1array ] [ "custom-inlining" word-prop ] bi* with-datastack - first object swap eliminate-dispatch ; + [ dup ] [ "custom-inlining" word-prop ] bi* + call( #call -- word/quot/f ) + object swap eliminate-dispatch ; : inline-instance-check ( #call word -- ? ) over in-d>> second value-info literal>> dup class? diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor index ec4ced8c9f..31faaef480 100644 --- a/basis/compiler/utilities/utilities.factor +++ b/basis/compiler/utilities/utilities.factor @@ -24,4 +24,4 @@ IN: compiler.utilities SYMBOL: yield-hook -yield-hook global [ [ ] or ] change-at +yield-hook [ [ ] ] initialize diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor index 61a3c38991..ce7f7d6110 100644 --- a/basis/concurrency/messaging/messaging.factor +++ b/basis/concurrency/messaging/messaging.factor @@ -85,4 +85,4 @@ PRIVATE> : get-process ( name -- process ) dup registered-processes at [ ] [ thread ] ?if ; -\ registered-processes global [ H{ } assoc-like ] change-at +\ registered-processes [ H{ } clone ] initialize diff --git a/basis/csv/csv-tests.factor b/basis/csv/csv-tests.factor index 4d78c2af86..50bc3836f5 100644 --- a/basis/csv/csv-tests.factor +++ b/basis/csv/csv-tests.factor @@ -1,11 +1,11 @@ -USING: io.streams.string csv tools.test shuffle kernel strings +USING: io.streams.string csv tools.test kernel strings io.pathnames io.files.unique io.encodings.utf8 io.files io.directories ; IN: csv.tests ! I like to name my unit tests : named-unit-test ( name output input -- ) - nipd unit-test ; inline + unit-test drop ; inline ! tests nicked from the wikipedia csv article ! http://en.wikipedia.org/wiki/Comma-separated_values diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor index 19cf5c5002..0d50d1ab2c 100644 --- a/basis/db/postgresql/lib/lib.factor +++ b/basis/db/postgresql/lib/lib.factor @@ -3,7 +3,7 @@ USING: arrays continuations db io kernel math namespaces quotations sequences db.postgresql.ffi alien alien.c-types db.types tools.walker ascii splitting math.parser combinators -libc shuffle calendar.format byte-arrays destructors prettyprint +libc calendar.format byte-arrays destructors prettyprint accessors strings serialize io.encodings.binary io.encodings.utf8 alien.strings io.streams.byte-array summary present urls specialized-arrays.uint specialized-arrays.alien db.private ; @@ -65,7 +65,7 @@ M: postgresql-result-null summary ( obj -- str ) } case ; : param-types ( statement -- seq ) - in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ; + in-params>> [ type>> type>oid ] uint-array{ } map-as ; : malloc-byte-array/length ( byte-array -- alien length ) [ malloc-byte-array &free ] [ length ] bi ; @@ -91,11 +91,11 @@ M: postgresql-result-null summary ( obj -- str ) ] 2map flip [ f f ] [ - first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi* + first2 [ >void*-array ] [ >uint-array ] bi* ] if-empty ; : param-formats ( statement -- seq ) - in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ; + in-params>> [ type>> type>param-format ] uint-array{ } map-as ; : do-postgresql-bound-statement ( statement -- res ) [ @@ -117,7 +117,7 @@ M: postgresql-result-null summary ( obj -- str ) : pq-get-string ( handle row column -- obj ) 3dup PQgetvalue utf8 alien>string - dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ; + dup empty? [ [ pq-get-is-null f ] dip ? ] [ [ 3drop ] dip ] if ; : pq-get-number ( handle row column -- obj ) pq-get-string dup [ string>number ] when ; @@ -134,7 +134,7 @@ M: postgresql-malloc-destructor dispose ( obj -- ) : pq-get-blob ( handle row column -- obj/f ) [ PQgetvalue ] 3keep 3dup PQgetlength dup 0 > [ - 3nip + [ 3drop ] dip [ memory>byte-array >string 0 diff --git a/extra/graphics/authors.txt b/basis/endian/authors.txt old mode 100644 new mode 100755 similarity index 100% rename from extra/graphics/authors.txt rename to basis/endian/authors.txt diff --git a/basis/endian/endian-tests.factor b/basis/endian/endian-tests.factor new file mode 100755 index 0000000000..b066ce6995 --- /dev/null +++ b/basis/endian/endian-tests.factor @@ -0,0 +1,7 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces tools.test endian ; +IN: endian.tests + +[ t ] [ [ endianness get big-endian = ] with-big-endian ] unit-test +[ t ] [ [ endianness get little-endian = ] with-little-endian ] unit-test diff --git a/basis/endian/endian.factor b/basis/endian/endian.factor new file mode 100755 index 0000000000..a832d6c0a2 --- /dev/null +++ b/basis/endian/endian.factor @@ -0,0 +1,67 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.c-types namespaces io.binary fry +kernel math ; +IN: endian + +SINGLETONS: big-endian little-endian ; + +: native-endianness ( -- class ) + 1 *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: endianness + +\ native-endianness get-global endianness set-global + +HOOK: >native-endian native-endianness ( obj n -- str ) + +M: big-endian >native-endian >be ; + +M: little-endian >native-endian >le ; + +HOOK: unsigned-native-endian> native-endianness ( obj -- str ) + +M: big-endian unsigned-native-endian> be> ; + +M: little-endian unsigned-native-endian> le> ; + +: signed-native-endian> ( obj n -- str ) + [ unsigned-native-endian> ] dip >signed ; + +HOOK: >endian endianness ( obj n -- str ) + +M: big-endian >endian >be ; + +M: little-endian >endian >le ; + +HOOK: endian> endianness ( seq -- n ) + +M: big-endian endian> be> ; + +M: little-endian endian> le> ; + +HOOK: unsigned-endian> endianness ( obj -- str ) + +M: big-endian unsigned-endian> be> ; + +M: little-endian unsigned-endian> le> ; + +: signed-endian> ( obj n -- str ) + [ unsigned-endian> ] dip >signed ; + +: with-endianness ( endian quot -- ) + [ endianness ] dip with-variable ; inline + +: with-big-endian ( quot -- ) + big-endian swap with-endianness ; inline + +: with-little-endian ( quot -- ) + little-endian swap with-endianness ; inline + +: with-native-endian ( quot -- ) + \ native-endianness get-global swap with-endianness ; inline diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor index 49c4dab0db..60a9f785e6 100644 --- a/basis/farkup/farkup-tests.factor +++ b/basis/farkup/farkup-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: farkup kernel peg peg.ebnf tools.test namespaces xml -urls.encoding assocs xml.utilities xml.data ; +urls.encoding assocs xml.traversal xml.data ; IN: farkup.tests relative-link-prefix off diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor index bad41296ee..a5951a5080 100755 --- a/basis/farkup/farkup.factor +++ b/basis/farkup/farkup.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays combinators io io.streams.string kernel math namespaces peg peg.ebnf -sequences sequences.deep strings xml.entities xml.literals +sequences sequences.deep strings xml.entities xml.syntax vectors splitting xmode.code2html urls.encoding xml.data xml.writer ; IN: farkup diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a5f3042b38..df008d52bd 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,11 +1,12 @@ IN: functors.tests -USING: functors tools.test math words kernel ; +USING: functors tools.test math words kernel multiline parser +io.streams.string generic ; << FUNCTOR: define-box ( T -- ) -B DEFINES ${T}-box +B DEFINES-CLASS ${T}-box DEFINES <${B}> WHERE @@ -62,4 +63,48 @@ WHERE >> -[ 4 ] [ 1 3 blah ] unit-test \ No newline at end of file +[ 4 ] [ 1 3 blah ] unit-test + +GENERIC: some-generic ( a -- b ) + +! Does replacing an ordinary word with a functor-generated one work? +[ [ ] ] [ + <" IN: functors.tests + + TUPLE: some-tuple ; + : some-word ( -- ) ; + M: some-tuple some-generic ; + "> "functors-test" parse-stream +] unit-test + +: test-redefinition ( -- ) + [ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test + [ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test + [ t ] [ + "some-tuple" "functors.tests" lookup + "some-generic" "functors.tests" lookup method >boolean + ] unit-test ; + +test-redefinition + +FUNCTOR: redefine-test ( W -- ) + +W-word DEFINES ${W}-word +W-tuple DEFINES-CLASS ${W}-tuple +W-generic IS ${W}-generic + +WHERE + +TUPLE: W-tuple ; +: W-word ( -- ) ; +M: W-tuple W-generic ; + +;FUNCTOR + +[ [ ] ] [ + <" IN: functors.tests + << "some" redefine-test >> + "> "functors-test" parse-stream +] unit-test + +test-redefinition \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index f4d35b6932..14151692f0 100644 --- a/basis/functors/functors.factor +++ b/basis/functors/functors.factor @@ -3,8 +3,9 @@ USING: kernel quotations classes.tuple make combinators generic words interpolate namespaces sequences io.streams.string fry classes.mixin effects lexer parser classes.tuple.parser -effects.parser locals.types locals.parser -locals.rewrite.closures vocabs.parser arrays accessors ; +effects.parser locals.types locals.parser generic.parser +locals.rewrite.closures vocabs.parser classes.parser +arrays accessors ; IN: functors ! This is a hack @@ -29,7 +30,7 @@ M: object >fake-quotations ; GENERIC: fake-quotations> ( fake -- quot ) M: fake-quotation fake-quotations> - seq>> [ fake-quotations> ] map >quotation ; + seq>> [ fake-quotations> ] [ ] map-as ; M: array fake-quotations> [ fake-quotations> ] map ; @@ -57,7 +58,7 @@ M: object fake-quotations> ; effect off scan-param parsed scan-param parsed - \ create-method parsed + \ create-method-in parsed parse-definition* DEFINE* ; parsing @@ -96,6 +97,8 @@ PRIVATE> : DEFINES [ create-in ] (INTERPOLATE) ; parsing +: DEFINES-CLASS [ create-class-in ] (INTERPOLATE) ; parsing + DEFER: ;FUNCTOR delimiter > non-chloe-attrs-only compile-attrs ] - [ compile-link-attrs ] - [ compile-a-url ] - tri - [ =href a> ] [code] ; +: process-attrs ( assoc -- newassoc ) + [ "@" ?head [ value present ] when ] assoc-map ; -: a-end-tag ( tag -- ) - drop [ ] [code] ; +: non-chloe-attrs ( tag -- ) + attrs>> non-chloe-attrs-only [ process-attrs ] [code-with] ; + +: a-attrs ( tag -- ) + [ non-chloe-attrs ] + [ compile-link-attrs ] + [ compile-a-url ] tri + [ present swap "href" swap [ set-at ] keep ] [code] ; CHLOE: a [ - [ a-start-tag ] [ compile-children ] [ a-end-tag ] tri + [ a-attrs ] + [ compile-children>string ] bi + [ [XML <-> XML] second swap >>attrs ] + [xml-code] ] compile-with-scope ; CHLOE: base - compile-a-url [ ] [code] ; + compile-a-url [ [XML /> 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 ] each ] when* - nested-forms get " " join f like nested-forms-key hidden-form-field - [ modify-form ] each-responder -
+ _ render-hidden + hidden-nested-fields + form-modifications + [XML
<-><-><->
XML] ] [code] ; -: compile-form-attrs ( method action attrs -- ) - [
] [code] ; +: (compile-form-attrs) ( method action -- ) + ! Leaves an assoc on the stack at runtime + [ compile-attr [ "method" pick set-at ] [code] ] + [ compile-attr [ resolve-base-path "action" pick set-at ] [code] ] + bi* ; -: form-start-tag ( tag -- ) - [ - [ "method" optional-attr "post" or ] - [ "action" required-attr ] - [ attrs>> non-chloe-attrs-only ] tri - compile-form-attrs - ] - [ "for" optional-attr compile-hidden-form-fields ] bi ; +: compile-method/action ( tag -- ) + ! generated code is ( assoc -- assoc ) + [ "method" optional-attr "post" or ] + [ "action" required-attr ] bi + (compile-form-attrs) ; -: form-end-tag ( tag -- ) - drop [
] [code] ; +: compile-form-attrs ( tag -- ) + [ non-chloe-attrs ] + [ compile-link-attrs ] + [ compile-method/action ] tri ; + +: hidden-fields ( tag -- ) + "for" optional-attr compile-hidden-form-fields ; CHLOE: form [ - { - [ compile-link-attrs ] - [ form-start-tag ] - [ compile-children ] - [ form-end-tag ] - } cleave + [ compile-form-attrs ] + [ hidden-fields ] + [ compile-children>string ] tri + [ + [XML
<-><->
XML] second + swap >>attrs + write-xml + ] [code] ] compile-with-scope ; : button-tag-markup ( -- xml ) @@ -121,13 +133,13 @@ CHLOE: form
- XML> ; + XML> body>> clone ; : add-tag-attrs ( attrs tag -- ) attrs>> swap update ; CHLOE: button - button-tag-markup body>> + button-tag-markup { [ [ attrs>> chloe-attrs-only ] dip add-tag-attrs ] [ [ attrs>> non-chloe-attrs-only ] dip "button" deep-tag-named add-tag-attrs ] diff --git a/basis/furnace/furnace-tests.factor b/basis/furnace/furnace-tests.factor index f6e5434997..c591b848ec 100644 --- a/basis/furnace/furnace-tests.factor +++ b/basis/furnace/furnace-tests.factor @@ -1,7 +1,7 @@ IN: furnace.tests USING: http http.server.dispatchers http.server.responses http.server furnace furnace.utilities tools.test kernel -namespaces accessors io.streams.string urls ; +namespaces accessors io.streams.string urls xml.writer ; TUPLE: funny-dispatcher < dispatcher ; : funny-dispatcher new-dispatcher ; @@ -30,8 +30,8 @@ M: base-path-check-responder call-responder* "a/b/c" split-path main-responder get call-responder body>> ] unit-test -[ "" ] -[ [ "&&&" "foo" hidden-form-field ] with-string-writer ] +[ "" ] +[ "&&&" "foo" hidden-form-field xml>string ] unit-test [ f ] [ request [ referrer ] with-variable ] unit-test diff --git a/basis/furnace/sessions/sessions.factor b/basis/furnace/sessions/sessions.factor index 8b7e1ab83f..52e705c153 100644 --- a/basis/furnace/sessions/sessions.factor +++ b/basis/furnace/sessions/sessions.factor @@ -5,7 +5,7 @@ strings random accessors quotations hashtables sequences continuations fry calendar combinators combinators.short-circuit destructors alarms io.sockets db db.tuples db.types http http.server http.server.dispatchers http.server.filters -html.elements furnace.cache furnace.scopes furnace.utilities ; +furnace.cache furnace.scopes furnace.utilities ; IN: furnace.sessions TUPLE: session < scope user-agent client ; diff --git a/basis/furnace/utilities/utilities-docs.factor b/basis/furnace/utilities/utilities-docs.factor index d2291786df..e7fdaf64d6 100644 --- a/basis/furnace/utilities/utilities-docs.factor +++ b/basis/furnace/utilities/utilities-docs.factor @@ -20,14 +20,14 @@ HELP: each-responder { $description "Applies the quotation to each responder involved in processing the current request." } ; HELP: hidden-form-field -{ $values { "value" string } { "name" string } } -{ $description "Renders an HTML hidden form field tag." } +{ $values { "value" string } { "name" string } { "xml" "an XML chunk" } } +{ $description "Renders an HTML hidden form field tag as XML." } { $notes "This word is used by session management, conversation scope and asides." } { $examples { $example - "USING: furnace.utilities io ;" - "\"bar\" \"foo\" hidden-form-field nl" - "" + "USING: furnace.utilities io xml.writer ;" + "\"bar\" \"foo\" hidden-form-field write-xml nl" + "" } } ; @@ -38,7 +38,7 @@ HELP: link-attr { $examples "Conversation scope adds attributes to link tags." } ; HELP: modify-form -{ $values { "responder" "a responder" } } +{ $values { "responder" "a responder" } { "xml/f" "an XML chunk or f" } } { $contract "Emits hidden form fields using " { $link hidden-form-field } "." } { $notes "This word is called by " { $link "html.templates.chloe.tags.form" } "." } { $examples "Session management, conversation scope and asides use hidden form fields to pass state." } ; diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor index e09047b74a..4fc68f7735 100755 --- a/basis/furnace/utilities/utilities.factor +++ b/basis/furnace/utilities/utilities.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: namespaces make assocs sequences kernel classes splitting words vocabs.loader accessors strings combinators arrays -continuations present fry urls html.elements http http.server +continuations present fry urls http http.server xml.syntax xml.writer http.server.redirection http.server.remapping ; IN: furnace.utilities @@ -77,18 +77,17 @@ GENERIC: link-attr ( tag responder -- ) M: object link-attr 2drop ; -GENERIC: modify-form ( responder -- ) +GENERIC: modify-form ( responder -- xml/f ) -M: object modify-form drop ; +M: object modify-form drop f ; -: hidden-form-field ( value name -- ) +: form-modifications ( -- xml ) + [ [ modify-form [ , ] when* ] each-responder ] { } make ; + +: hidden-form-field ( value name -- xml ) over [ - - ] [ 2drop ] if ; + [XML name=<->/> XML] + ] [ drop ] if ; : nested-forms-key "__n" ; diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor index 912f69587e..376ae5bed2 100644 --- a/basis/generalizations/generalizations-docs.factor +++ b/basis/generalizations/generalizations-docs.factor @@ -30,6 +30,10 @@ HELP: narray { nsequence narray } related-words +HELP: nsum +{ $values { "n" integer } } +{ $description "Adds the top " { $snippet "n" } " stack values." } ; + HELP: firstn { $values { "n" integer } } { $description "A generalization of " { $link first } ", " @@ -54,7 +58,7 @@ HELP: npick "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } + { $example "USING: kernel prettyprint generalizations ;" "1 2 3 4 4 npick .s clear" "1\n2\n3\n4\n1" } "Some core words expressed in terms of " { $link npick } ":" { $table { { $link dup } { $snippet "1 npick" } } @@ -71,7 +75,7 @@ HELP: ndup "placed on the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 ndup .s clear" "1\n2\n3\n4\n1\n2\n3\n4" } "Some core words expressed in terms of " { $link ndup } ":" { $table { { $link dup } { $snippet "1 ndup" } } @@ -87,7 +91,7 @@ HELP: nnip "for any number of items." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 nnip .s clear" "4" } "Some core words expressed in terms of " { $link nnip } ":" { $table { { $link nip } { $snippet "1 nnip" } } @@ -102,7 +106,7 @@ HELP: ndrop "for any number of items." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 3 ndrop .s clear" "1" } "Some core words expressed in terms of " { $link ndrop } ":" { $table { { $link drop } { $snippet "1 ndrop" } } @@ -117,7 +121,7 @@ HELP: nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 nrot .s clear" "2\n3\n4\n1" } "Some core words expressed in terms of " { $link nrot } ":" { $table { { $link swap } { $snippet "1 nrot" } } @@ -131,7 +135,7 @@ HELP: -nrot "number of items on the stack. " } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } + { $example "USING: prettyprint generalizations kernel ;" "1 2 3 4 4 -nrot .s clear" "4\n1\n2\n3" } "Some core words expressed in terms of " { $link -nrot } ":" { $table { { $link swap } { $snippet "1 -nrot" } } @@ -147,8 +151,8 @@ HELP: ndip "stack. The quotation can consume and produce any number of items." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } + { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 [ dup ] 1 ndip .s clear" "1\n1\n2" } + { $example "USING: generalizations kernel prettyprint kernel ;" "1 2 3 [ drop ] 2 ndip .s clear" "2\n3" } "Some core words expressed in terms of " { $link ndip } ":" { $table { { $link dip } { $snippet "1 ndip" } } @@ -164,7 +168,7 @@ HELP: nslip "removed from the stack, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s clear" "99\n1\n2\n3\n4\n5" } "Some core words expressed in terms of " { $link nslip } ":" { $table { { $link slip } { $snippet "1 nslip" } } @@ -180,7 +184,7 @@ HELP: nkeep "saved, the quotation called, and the items restored." } { $examples - { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s clear" "99\n1\n2\n3\n4\n5" } "Some core words expressed in terms of " { $link nkeep } ":" { $table { { $link keep } { $snippet "1 nkeep" } } @@ -238,6 +242,11 @@ HELP: ncleave } } ; +HELP: nspread +{ $values { "quots" "a sequence of quotations" } { "n" integer } } +{ $description "A generalization of " { $link spread } " that can work for any quotation arity." +} ; + HELP: mnswap { $values { "m" integer } { "n" integer } } { $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." } @@ -250,6 +259,17 @@ HELP: mnswap } } ; +HELP: nweave +{ $values { "n" integer } } +{ $description "Copies the top " { $snippet "n" } " stack elements underneath each one of the " { $snippet "n" } " elements below." } +{ $examples + { $example + "USING: arrays kernel generalizations prettyprint ;" + "\"e1\" \"e2\" \"o1\" \"o2\" 2 nweave [ 3array ] 3dip 3array 2array ." + "{ { \"e1\" \"o1\" \"o2\" } { \"e2\" \"o1\" \"o2\" } }" + } +} ; + HELP: n*quot { $values { "n" integer } { "seq" sequence } @@ -299,18 +319,14 @@ HELP: ntuck } { $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ; -ARTICLE: "generalizations" "Generalized shuffle words and combinators" -"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " -"macros where the arity of the input quotations depends on an " -"input parameter." -$nl -"Generalized sequence operations:" +ARTICLE: "sequence-generalizations" "Generalized sequence operations" { $subsection narray } { $subsection nsequence } { $subsection firstn } { $subsection nappend } -{ $subsection nappend-as } -"Generated stack shuffle operations:" +{ $subsection nappend-as } ; + +ARTICLE: "shuffle-generalizations" "Generalized shuffle words" { $subsection ndup } { $subsection npick } { $subsection nrot } @@ -319,14 +335,28 @@ $nl { $subsection ndrop } { $subsection ntuck } { $subsection mnswap } -"Generalized combinators:" +{ $subsection nweave } ; + +ARTICLE: "combinator-generalizations" "Generalized combinators" { $subsection ndip } { $subsection nslip } { $subsection nkeep } { $subsection napply } { $subsection ncleave } -"Generalized quotation construction:" +{ $subsection nspread } ; + +ARTICLE: "other-generalizations" "Additional generalizations" { $subsection ncurry } -{ $subsection nwith } ; +{ $subsection nwith } +{ $subsection nsum } ; + +ARTICLE: "generalizations" "Generalized shuffle words and combinators" +"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in " +"macros where the arity of the input quotations depends on an " +"input parameter." +{ $subsection "sequence-generalizations" } +{ $subsection "shuffle-generalizations" } +{ $subsection "combinator-generalizations" } +{ $subsection "other-generalizations" } ; ABOUT: "generalizations" diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor index 35e02f08b4..7ede271d01 100644 --- a/basis/generalizations/generalizations-tests.factor +++ b/basis/generalizations/generalizations-tests.factor @@ -53,3 +53,12 @@ IN: generalizations.tests [ 4 nappend ] must-infer [ 4 { } nappend-as ] must-infer + +[ 17 ] [ 3 1 3 3 7 5 nsum ] unit-test +{ 4 1 } [ 4 nsum ] must-infer-as + +[ "e1" "o1" "o2" "e2" "o1" "o2" ] [ "e1" "e2" "o1" "o2" 2 nweave ] unit-test +{ 3 5 } [ 2 nweave ] must-infer-as + +[ { 0 1 2 } { 3 5 4 } { 7 8 6 } ] +[ 9 [ ] each { [ 3array ] [ swap 3array ] [ rot 3array ] } 3 nspread ] unit-test \ No newline at end of file diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 4692fd20db..9b2b2456c2 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007, 2008 Chris Double, Doug Coleman, Eduardo +! Copyright (C) 2007, 2009 Chris Double, Doug Coleman, Eduardo ! Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private math combinators @@ -23,6 +23,9 @@ MACRO: nsequence ( n seq -- ) MACRO: narray ( n -- ) '[ _ { } nsequence ] ; +MACRO: nsum ( n -- ) + 1- [ + ] n*quot ; + MACRO: firstn ( n -- ) dup zero? [ drop [ drop ] ] [ [ [ '[ [ _ ] dip nth-unsafe ] ] map ] @@ -70,11 +73,23 @@ MACRO: ncleave ( quots n -- ) [ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi compose ; +MACRO: nspread ( quots n -- ) + over empty? [ 2drop [ ] ] [ + [ [ but-last ] dip ] + [ [ peek ] dip ] 2bi + swap + '[ [ _ _ nspread ] _ ndip @ ] + ] if ; + MACRO: napply ( quot n -- ) swap spread>quot ; MACRO: mnswap ( m n -- ) - 1+ '[ _ -nrot ] spread>quot ; + 1+ '[ _ -nrot ] swap '[ _ _ napply ] ; + +MACRO: nweave ( n -- ) + [ dup [ '[ _ _ mnswap ] ] with map ] keep + '[ _ _ ncleave ] ; : nappend-as ( n exemplar -- seq ) [ narray concat ] dip like ; inline diff --git a/basis/help/help.factor b/basis/help/help.factor index 272bdc1db3..f980032a8b 100644 --- a/basis/help/help.factor +++ b/basis/help/help.factor @@ -118,7 +118,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ; SYMBOL: help-hook -help-hook global [ [ print-topic ] or ] change-at +help-hook [ [ print-topic ] ] initialize : help ( topic -- ) help-hook get call ; diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor index 26fc4e2637..cccf320e44 100644 --- a/basis/help/html/html.factor +++ b/basis/help/html/html.factor @@ -5,7 +5,7 @@ io.files io.files.temp io.directories html.streams help kernel assocs sequences make words accessors arrays help.topics vocabs tools.vocabs tools.vocabs.browser namespaces prettyprint io vocabs.loader serialize fry memoize unicode.case math.order -sorting debugger html xml.literals xml.writer ; +sorting debugger html xml.syntax xml.writer ; IN: help.html : escape-char ( ch -- ) diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor index b5f8b78ea3..57f64459c8 100755 --- a/basis/help/lint/lint.factor +++ b/basis/help/lint/lint.factor @@ -7,7 +7,7 @@ combinators combinators.short-circuit splitting debugger hashtables sorting effects vocabs vocabs.loader assocs editors continuations classes.predicate macros math sets eval vocabs.parser words.symbol values grouping unicode.categories -sequences.deep ; +sequences.deep call ; IN: help.lint SYMBOL: vocabs-quot @@ -15,9 +15,9 @@ SYMBOL: vocabs-quot : check-example ( element -- ) [ rest [ - but-last "\n" join 1vector - [ (eval>string) ] with-datastack - peek "\n" ?tail drop + but-last "\n" join + [ (eval>string) ] call( code -- output ) + "\n" ?tail drop ] keep peek assert= ] vocabs-quot get call ; @@ -145,7 +145,7 @@ M: help-error error. bi ; : check-something ( obj quot -- ) - flush '[ _ assert-depth ] swap '[ _ , ] recover ; inline + flush '[ _ call( -- ) ] swap '[ _ , ] recover ; inline : check-word ( word -- ) [ with-file-vocabs ] vocabs-quot set diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor index e6b19d5baa..8c687eb1d5 100644 --- a/basis/help/topics/topics.factor +++ b/basis/help/topics/topics.factor @@ -27,11 +27,11 @@ M: link summary ! Help articles SYMBOL: articles -articles global [ H{ } assoc-like ] change-at +articles [ H{ } clone ] initialize SYMBOL: article-xref -article-xref global [ H{ } assoc-like ] change-at +article-xref [ H{ } clone ] initialize GENERIC: article-name ( topic -- string ) GENERIC: article-title ( topic -- string ) diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor index ce4bddde6a..b432cc0cc6 100644 --- a/basis/html/components/components-docs.factor +++ b/basis/html/components/components-docs.factor @@ -100,6 +100,6 @@ $nl { $subsection farkup } "Creating custom components:" { $subsection render* } -"Custom components can emit HTML using the " { $vocab-link "xml.literals" } " vocabulary." ; +"Custom components can emit HTML using the " { $vocab-link "xml.syntax" } " vocabulary." ; ABOUT: "html.components" diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor index f811343df2..2b18e28351 100644 --- a/basis/html/components/components.factor +++ b/basis/html/components/components.factor @@ -4,14 +4,14 @@ USING: accessors kernel namespaces io math.parser assocs classes classes.tuple words arrays sequences splitting mirrors hashtables combinators continuations math strings inspector fry locals calendar calendar.format xml.entities xml.data -validators urls present xml.writer xml.literals xml +validators urls present xml.writer xml.syntax xml xmode.code2html lcs.diff2html farkup io.streams.string html html.streams html.forms ; IN: html.components GENERIC: render* ( value name renderer -- xml ) -: render ( name renderer -- ) +: render>xml ( name renderer -- xml ) prepare-value [ dup validation-error? @@ -20,7 +20,10 @@ GENERIC: render* ( value name renderer -- xml ) if ] 2dip render* - swap 2array write-xml ; + swap 2array ; + +: render ( name renderer -- ) + render>xml write-xml ; SINGLETON: label diff --git a/basis/html/forms/forms.factor b/basis/html/forms/forms.factor index 0a69e2ed70..d5c744beab 100644 --- a/basis/html/forms/forms.factor +++ b/basis/html/forms/forms.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel accessors strings namespaces assocs hashtables io mirrors math fry sequences words continuations -xml.entities xml.writer xml.literals ; +xml.entities xml.writer xml.syntax ; IN: html.forms TUPLE: form errors values validation-failed ; diff --git a/basis/html/html.factor b/basis/html/html.factor index 5e86add10e..e86b4917d7 100644 --- a/basis/html/html.factor +++ b/basis/html/html.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2009 Chris Double, Daniel Ehrenberg, ! Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel xml.data xml.writer xml.literals urls.encoding ; +USING: kernel xml.data xml.writer xml.syntax urls.encoding ; IN: html : simple-page ( title head body -- xml ) @@ -21,4 +21,4 @@ IN: html [XML <-> XML] ; : simple-link ( xml url -- xml' ) - url-encode swap [XML ><-> XML] ; \ No newline at end of file + url-encode swap [XML ><-> XML] ; diff --git a/basis/html/streams/streams.factor b/basis/html/streams/streams.factor index 0a4b8eddd4..28d6e6d5de 100644 --- a/basis/html/streams/streams.factor +++ b/basis/html/streams/streams.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel assocs io io.styles math math.order math.parser -sequences strings make words combinators macros xml.literals html fry +sequences strings make words combinators macros xml.syntax html fry destructors ; IN: html.streams diff --git a/basis/html/templates/chloe/chloe-docs.factor b/basis/html/templates/chloe/chloe-docs.factor index f6408d3b59..18e6db66f6 100644 --- a/basis/html/templates/chloe/chloe-docs.factor +++ b/basis/html/templates/chloe/chloe-docs.factor @@ -128,7 +128,7 @@ ARTICLE: "html.templates.chloe.tags.form" "Chloe link and form tags" "" " View" - "s" + "" } } } { { $snippet "t:base" } { "Outputs an HTML " { $snippet "" } " tag. The attributes are interpreted in the same manner as the attributes of " { $snippet "t:a" } "." } } @@ -261,8 +261,8 @@ $nl ARTICLE: "html.templates.chloe.extend.components.example" "An example of a custom Chloe component" "As an example, let's develop a custom Chloe component which renders an image stored in a form value. Since the component does not require any configuration, we can define a singleton class:" { $code "SINGLETON: image" } -"Now we define a method on the " { $link render* } " generic word which renders the image using " { $vocab-link "html.elements" } ":" -{ $code "M: image render* 2drop ;" } +"Now we define a method on the " { $link render* } " generic word which renders the image using " { $link { "xml.syntax" "literals" } } ":" +{ $code "M: image render* 2drop [XML /> XML] ;" } "Finally, we can define a Chloe component:" { $code "COMPONENT: image" } "We can use it as follows, assuming the current form has a value named " { $snippet "image" } ":" diff --git a/basis/html/templates/chloe/chloe-tests.factor b/basis/html/templates/chloe/chloe-tests.factor index 19b67f7018..4e454dcee4 100644 --- a/basis/html/templates/chloe/chloe-tests.factor +++ b/basis/html/templates/chloe/chloe-tests.factor @@ -135,7 +135,7 @@ TUPLE: person first-name last-name ; [ ] [ H{ { "a" H{ { "b" "c" } } } } values set ] unit-test -[ "
" ] [ +[ "
" ] [ [ "test10" test-template call-template ] run-template diff --git a/basis/html/templates/chloe/chloe.factor b/basis/html/templates/chloe/chloe.factor index e5b40fcfaa..eafa3c3a5d 100644 --- a/basis/html/templates/chloe/chloe.factor +++ b/basis/html/templates/chloe/chloe.factor @@ -4,11 +4,10 @@ USING: accessors kernel sequences combinators kernel fry namespaces make classes.tuple assocs splitting words arrays io io.files io.files.info io.encodings.utf8 io.streams.string unicode.case mirrors math urls present multiline quotations xml -logging continuations -xml.data xml.writer xml.literals strings +logging call +xml.data xml.writer xml.syntax strings html.forms html -html.elements html.components html.templates html.templates.chloe.compiler @@ -28,7 +27,9 @@ CHLOE: write-title drop "head" tag-stack get member? "title" tag-stack get member? not and - [ write-title ] [ write-title ] ? [code] ; + [ get-title [XML <-> XML] ] + [ get-title ] ? + [xml-code] ; CHLOE: style dup "include" optional-attr [ @@ -39,10 +40,9 @@ CHLOE: style CHLOE: write-style drop [ - - ] [code] ; + get-style + [XML XML] + ] [xml-code] ; CHLOE: even [ "index" value even? swap when ] process-children ; @@ -130,6 +130,6 @@ TUPLE: cached-template path last-modified quot ; template-cache get clear-assoc ; M: chloe call-template* - template-quot assert-depth ; + template-quot call( -- ) ; INSTANCE: chloe template diff --git a/basis/html/templates/chloe/compiler/compiler.factor b/basis/html/templates/chloe/compiler/compiler.factor index 7180e8cdbc..3cb7523bdc 100644 --- a/basis/html/templates/chloe/compiler/compiler.factor +++ b/basis/html/templates/chloe/compiler/compiler.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs namespaces make kernel sequences accessors combinators strings splitting io io.streams.string present -xml.writer xml.data xml.entities html.forms -html.templates html.templates.chloe.syntax continuations ; +xml.writer xml.data xml.entities html.forms call +html.templates html.templates.chloe.syntax ; IN: html.templates.chloe.compiler : chloe-attrs-only ( assoc -- assoc' ) @@ -42,6 +42,9 @@ DEFER: compile-element : [code-with] ( obj quot -- ) reset-buffer [ , ] [ % ] bi* ; +: [xml-code] ( quot -- ) + [ write-xml ] compose [code] ; + : expand-attr ( value -- ) [ value present write ] [code-with] ; @@ -80,7 +83,7 @@ ERROR: unknown-chloe-tag tag ; : compile-chloe-tag ( tag -- ) dup main>> dup tags get at - [ curry assert-depth ] + [ call( tag -- ) ] [ unknown-chloe-tag ] ?if ; diff --git a/basis/html/templates/chloe/syntax/syntax.factor b/basis/html/templates/chloe/syntax/syntax.factor index c2ecd4506b..faf8bed66b 100644 --- a/basis/html/templates/chloe/syntax/syntax.factor +++ b/basis/html/templates/chloe/syntax/syntax.factor @@ -5,13 +5,13 @@ USING: accessors kernel sequences combinators kernel namespaces classes.tuple assocs splitting words arrays memoize parser lexer io io.files io.encodings.utf8 io.streams.string unicode.case mirrors fry math urls -multiline xml xml.data xml.writer xml.utilities +multiline xml xml.data xml.writer xml.syntax html.components html.templates ; SYMBOL: tags -tags global [ H{ } clone or ] change-at +tags [ H{ } clone ] initialize : define-chloe-tag ( name quot -- ) swap tags get set-at ; diff --git a/basis/html/templates/fhtml/fhtml.factor b/basis/html/templates/fhtml/fhtml.factor index c419c4a197..78202d6460 100644 --- a/basis/html/templates/fhtml/fhtml.factor +++ b/basis/html/templates/fhtml/fhtml.factor @@ -3,7 +3,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: continuations sequences kernel namespaces debugger combinators math quotations generic strings splitting accessors -assocs fry vocabs.parser parser lexer io io.files +assocs fry vocabs.parser parser lexer io io.files call io.streams.string io.encodings.utf8 html.templates ; IN: html.templates.fhtml @@ -72,6 +72,6 @@ TUPLE: fhtml path ; C: fhtml M: fhtml call-template* ( filename -- ) - '[ _ path>> utf8 file-contents eval-template ] assert-depth ; + [ path>> utf8 file-contents eval-template ] call( filename -- ) ; INSTANCE: fhtml template diff --git a/basis/html/templates/templates.factor b/basis/html/templates/templates.factor index efaf8d6a62..4a416e353f 100644 --- a/basis/html/templates/templates.factor +++ b/basis/html/templates/templates.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel fry io io.encodings.utf8 io.files debugger prettyprint continuations namespaces boxes sequences -arrays strings html io.streams.string -quotations xml.data xml.writer xml.literals ; +arrays strings html io.streams.string assocs +quotations xml.data xml.writer xml.syntax ; IN: html.templates MIXIN: template @@ -34,8 +34,11 @@ SYMBOL: title : set-title ( string -- ) title get >box ; +: get-title ( -- string ) + title get value>> ; + : write-title ( -- ) - title get value>> write ; + get-title write ; SYMBOL: style @@ -43,24 +46,30 @@ SYMBOL: style "\n" style get push-all style get push-all ; +: get-style ( -- string ) + style get >string ; + : write-style ( -- ) - style get >string write ; + get-style write ; SYMBOL: atom-feeds : add-atom-feed ( title url -- ) 2array atom-feeds get push ; -: write-atom-feeds ( -- ) +: get-atom-feeds ( -- xml ) atom-feeds get [ - first2 [XML + [XML href=<->/> - XML] write-xml - ] each ; + XML] + ] { } assoc>map ; + +: write-atom-feeds ( -- ) + get-atom-feeds write-xml ; SYMBOL: nested-template? diff --git a/basis/http/http-tests.factor b/basis/http/http-tests.factor index f593980467..49acdb639c 100644 --- a/basis/http/http-tests.factor +++ b/basis/http/http-tests.factor @@ -299,7 +299,7 @@ test-db [ [ "Goodbye" ] [ "http://localhost/quit" add-port http-get nip ] unit-test USING: html.components html.forms -xml xml.utilities validators +xml xml.traversal validators furnace furnace.conversations ; SYMBOL: a diff --git a/basis/http/server/responses/responses.factor b/basis/http/server/responses/responses.factor index c9b4600ac8..3902b7f5e2 100644 --- a/basis/http/server/responses/responses.factor +++ b/basis/http/server/responses/responses.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: math.parser http accessors kernel xml.literals xml.writer +USING: math.parser http accessors kernel xml.syntax xml.writer io io.streams.string io.encodings.utf8 ; IN: http.server.responses diff --git a/basis/http/server/server.factor b/basis/http/server/server.factor index b6ee70057b..f2f3deead2 100755 --- a/basis/http/server/server.factor +++ b/basis/http/server/server.factor @@ -161,7 +161,7 @@ C: trivial-responder M: trivial-responder call-responder* nip response>> clone ; -main-responder global [ <404> or ] change-at +main-responder [ <404> ] initialize : invert-slice ( slice -- slice' ) dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ; diff --git a/basis/http/server/static/static.factor b/basis/http/server/static/static.factor index 2df8838061..53d3d4f917 100644 --- a/basis/http/server/static/static.factor +++ b/basis/http/server/static/static.factor @@ -4,7 +4,7 @@ USING: calendar kernel math math.order math.parser namespaces parser sequences strings assocs hashtables debugger mime.types sorting logging calendar.format accessors splitting io io.files io.files.info io.directories io.pathnames io.encodings.binary -fry xml.entities destructors urls html xml.literals +fry xml.entities destructors urls html xml.syntax html.templates.fhtml http http.server http.server.responses http.server.redirection xml.writer ; IN: http.server.static diff --git a/basis/sequences/next/authors.txt b/basis/inverse/authors.txt similarity index 100% rename from basis/sequences/next/authors.txt rename to basis/inverse/authors.txt diff --git a/extra/inverse/inverse-docs.factor b/basis/inverse/inverse-docs.factor similarity index 100% rename from extra/inverse/inverse-docs.factor rename to basis/inverse/inverse-docs.factor diff --git a/extra/inverse/inverse-tests.factor b/basis/inverse/inverse-tests.factor similarity index 96% rename from extra/inverse/inverse-tests.factor rename to basis/inverse/inverse-tests.factor index a9234fcff4..9d81992eae 100644 --- a/extra/inverse/inverse-tests.factor +++ b/basis/inverse/inverse-tests.factor @@ -71,6 +71,9 @@ C: nil [ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test [ ] [ 3 [ _ ] undo ] unit-test +[ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test +[ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test + [ { 1 } ] [ { 1 2 3 } [ { 2 3 } append ] undo ] unit-test [ { 3 } ] [ { 1 2 3 } [ { 1 2 } prepend ] undo ] unit-test [ { 1 2 3 } [ { 1 2 } append ] undo ] must-fail diff --git a/extra/inverse/inverse.factor b/basis/inverse/inverse.factor similarity index 97% rename from extra/inverse/inverse.factor rename to basis/inverse/inverse.factor index a86e673c9c..1006e45e77 100755 --- a/extra/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -5,7 +5,7 @@ sequences assocs math arrays stack-checker effects generalizations continuations debugger classes.tuple namespaces make vectors bit-arrays byte-arrays strings sbufs math.functions macros sequences.private combinators mirrors splitting -combinators.short-circuit fry words.symbol ; +combinators.short-circuit fry words.symbol generalizations ; RENAME: _ fry => __ IN: inverse @@ -163,7 +163,7 @@ ERROR: missing-literal ; \ - [ + ] [ - ] define-math-inverse \ * [ / ] [ / ] define-math-inverse \ / [ * ] [ / ] define-math-inverse -\ ^ [ recip ^ ] [ [ log ] bi@ / ] define-math-inverse +\ ^ [ recip ^ ] [ swap [ log ] bi@ / ] define-math-inverse \ ? 2 [ [ assert-literal ] bi@ @@ -199,6 +199,7 @@ DEFER: _ \ 2array [ 2 assure-length first2 ] define-inverse \ 3array [ 3 assure-length first3 ] define-inverse \ 4array [ 4 assure-length first4 ] define-inverse +\ narray 1 [ [ firstn ] curry ] define-pop-inverse \ first [ 1array ] define-inverse \ first2 [ 2array ] define-inverse diff --git a/extra/inverse/summary.txt b/basis/inverse/summary.txt similarity index 100% rename from extra/inverse/summary.txt rename to basis/inverse/summary.txt diff --git a/extra/inverse/tags.txt b/basis/inverse/tags.txt similarity index 100% rename from extra/inverse/tags.txt rename to basis/inverse/tags.txt diff --git a/basis/io/backend/unix/multiplexers/epoll/epoll.factor b/basis/io/backend/unix/multiplexers/epoll/epoll.factor index a91f62f1df..e1428fee4d 100644 --- a/basis/io/backend/unix/multiplexers/epoll/epoll.factor +++ b/basis/io/backend/unix/multiplexers/epoll/epoll.factor @@ -51,7 +51,7 @@ M: epoll-mx remove-output-callbacks ( fd mx -- seq ) ] [ 2drop f ] if ; : wait-event ( mx us -- n ) - [ [ fd>> ] [ events>> ] bi [ underlying>> ] [ length ] bi ] [ 1000 /i ] bi* + [ [ fd>> ] [ events>> ] bi dup length ] [ 1000 /i ] bi* epoll_wait multiplexer-error ; : handle-event ( event mx -- ) diff --git a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor index 2a6648981b..7bd157136a 100644 --- a/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor +++ b/basis/io/backend/unix/multiplexers/kqueue/kqueue.factor @@ -59,7 +59,7 @@ M: kqueue-mx remove-output-callbacks ( fd mx -- seq ) : wait-kevent ( mx timespec -- n ) [ [ fd>> f 0 ] - [ events>> [ underlying>> ] [ length ] bi ] bi + [ events>> dup length ] bi ] dip kevent multiplexer-error ; : handle-kevent ( mx kevent -- ) diff --git a/basis/io/backend/unix/multiplexers/select/select.factor b/basis/io/backend/unix/multiplexers/select/select.factor index c62101e478..7d0acb4140 100644 --- a/basis/io/backend/unix/multiplexers/select/select.factor +++ b/basis/io/backend/unix/multiplexers/select/select.factor @@ -44,8 +44,8 @@ TUPLE: select-mx < mx read-fdset write-fdset ; : init-fdsets ( mx -- nfds read write except ) [ num-fds ] - [ read-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] - [ write-fdset/tasks [ init-fdset ] [ underlying>> ] bi ] tri + [ read-fdset/tasks [ init-fdset ] keep ] + [ write-fdset/tasks [ init-fdset ] keep ] tri f ; M:: select-mx wait-for-events ( us mx -- ) diff --git a/basis/io/backend/unix/unix.factor b/basis/io/backend/unix/unix.factor index 4bc8868a3c..f5e6426859 100644 --- a/basis/io/backend/unix/unix.factor +++ b/basis/io/backend/unix/unix.factor @@ -46,6 +46,15 @@ M: fd cancel-operation ( fd -- ) 2bi ] if ; +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 + [ fd>> swap ] dip lseek io-error ; + SYMBOL: +retry+ ! just try the operation again without blocking SYMBOL: +input+ SYMBOL: +output+ @@ -84,8 +93,8 @@ M: fd refill fd>> over buffer>> [ buffer-end ] [ buffer-capacity ] bi read { { [ dup 0 >= ] [ swap buffer>> n>buffer f ] } - { [ err_no EINTR = ] [ 2drop +retry+ ] } - { [ err_no EAGAIN = ] [ 2drop +input+ ] } + { [ errno EINTR = ] [ 2drop +retry+ ] } + { [ errno EAGAIN = ] [ 2drop +input+ ] } [ (io-error) ] } cond ; @@ -104,8 +113,8 @@ M: fd drain over buffer>> buffer-consume buffer>> buffer-empty? f +output+ ? ] } - { [ err_no EINTR = ] [ 2drop +retry+ ] } - { [ err_no EAGAIN = ] [ 2drop +output+ ] } + { [ errno EINTR = ] [ 2drop +retry+ ] } + { [ errno EAGAIN = ] [ 2drop +output+ ] } [ (io-error) ] } cond ; @@ -143,7 +152,7 @@ M: stdin dispose* stdin data>> handle-fd buffer buffer-end size read dup 0 < [ drop - err_no EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if + errno EINTR = [ buffer stdin size refill-stdin ] [ (io-error) ] if ] [ size = [ "Error reading stdin pipe" throw ] unless size buffer n>buffer @@ -177,7 +186,7 @@ TUPLE: mx-port < port mx ; : multiplexer-error ( n -- n ) dup 0 < [ - err_no [ EAGAIN = ] [ EINTR = ] bi or + errno [ EAGAIN = ] [ EINTR = ] bi or [ drop 0 ] [ (io-error) ] if ] when ; diff --git a/basis/io/backend/windows/nt/nt.factor b/basis/io/backend/windows/nt/nt.factor index c6b24a0a11..6f283ac1bb 100755 --- a/basis/io/backend/windows/nt/nt.factor +++ b/basis/io/backend/windows/nt/nt.factor @@ -82,6 +82,24 @@ M: winnt init-io ( -- ) H{ } clone pending-overlapped set-global windows.winsock:init-winsock ; +ERROR: invalid-file-size n ; + +: handle>file-size ( handle -- n ) + 0 [ GetFileSizeEx win32-error=0/f ] keep *ulonglong ; + +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 [ set-seek-ptr ] } + { seek-relative [ [ ptr>> + ] keep set-seek-ptr ] } + { seek-end [ [ handle>> handle>file-size + ] keep set-seek-ptr ] } + [ bad-seek-type ] + } case ; + : file-error? ( n -- eof? ) zero? [ GetLastError { diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor index a56bd1194b..6afae92429 100644 --- a/basis/io/encodings/iana/iana.factor +++ b/basis/io/encodings/iana/iana.factor @@ -47,8 +47,8 @@ PRIVATE> "resource:basis/io/encodings/iana/character-sets" utf8 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 -- ) [ diff --git a/basis/io/launcher/windows/nt/nt-tests.factor b/basis/io/launcher/windows/nt/nt-tests.factor old mode 100644 new mode 100755 index 4dd0eebed3..04202365fd --- a/basis/io/launcher/windows/nt/nt-tests.factor +++ b/basis/io/launcher/windows/nt/nt-tests.factor @@ -37,11 +37,12 @@ IN: io.launcher.windows.nt.tests "out.txt" temp-file ascii file-lines first ] unit-test -[ ] [ +[ "( scratchpad ) " ] [ 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 ) @@ -162,3 +163,5 @@ IN: io.launcher.windows.nt.tests "append-test" temp-file ascii file-contents ] unit-test + + diff --git a/basis/io/launcher/windows/windows.factor b/basis/io/launcher/windows/windows.factor index 0497754aa2..7de6c25a13 100755 --- a/basis/io/launcher/windows/windows.factor +++ b/basis/io/launcher/windows/windows.factor @@ -103,7 +103,7 @@ TUPLE: CreateProcess-args over get-environment [ swap % "=" % % "\0" % ] assoc-each "\0" % - ] ushort-array{ } make underlying>> + ] ushort-array{ } make >>lpEnvironment ] when ; @@ -158,7 +158,7 @@ M: windows kill-process* ( handle -- ) M: windows wait-for-processes ( -- ? ) processes get keys dup [ handle>> PROCESS_INFORMATION-hProcess ] void*-array{ } map-as - [ length ] [ underlying>> ] bi 0 0 + [ length ] keep 0 0 WaitForMultipleObjects dup HEX: ffffffff = [ win32-error ] when dup WAIT_TIMEOUT = [ 2drop t ] [ swap nth process-exited f ] if ; diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor index 6a0015084b..f94733ca56 100644 --- a/basis/io/pipes/unix/unix.factor +++ b/basis/io/pipes/unix/unix.factor @@ -7,5 +7,5 @@ QUALIFIED: io.pipes M: unix io.pipes:(pipe) ( -- pair ) 2 - [ underlying>> pipe io-error ] + [ pipe io-error ] [ first2 [ init-fd ] bi@ io.pipes:pipe boa ] bi ; diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor index 1fe717d5ee..1a58d4200b 100644 --- a/basis/io/ports/ports.factor +++ b/basis/io/ports/ports.factor @@ -120,6 +120,18 @@ M: output-port stream-write HOOK: (wait-to-write) io-backend ( port -- ) +HOOK: seek-handle os ( n seek-type handle -- ) + +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 -- ) M: object shutdown drop ; diff --git a/basis/io/sockets/secure/openssl/openssl.factor b/basis/io/sockets/secure/openssl/openssl.factor index 0326969e4f..f78f61ef3b 100644 --- a/basis/io/sockets/secure/openssl/openssl.factor +++ b/basis/io/sockets/secure/openssl/openssl.factor @@ -46,11 +46,13 @@ TUPLE: openssl-context < secure-context aliens sessions ; [ push ] [ drop ] 2bi ; : set-default-password ( ctx -- ) - [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] - [ - [ handle>> ] [ default-pasword ] bi - SSL_CTX_set_default_passwd_cb_userdata - ] bi ; + dup config>> password>> [ + [ handle>> password-callback SSL_CTX_set_default_passwd_cb ] + [ + [ handle>> ] [ default-pasword ] bi + SSL_CTX_set_default_passwd_cb_userdata + ] bi + ] [ drop ] if ; : use-private-key-file ( ctx -- ) dup config>> key-file>> [ diff --git a/basis/io/sockets/secure/unix/unix.factor b/basis/io/sockets/secure/unix/unix.factor index 8419246eb6..f1f39a0559 100644 --- a/basis/io/sockets/secure/unix/unix.factor +++ b/basis/io/sockets/secure/unix/unix.factor @@ -15,7 +15,7 @@ M: ssl-handle handle-fd file>> handle-fd ; ERR_get_error dup zero? [ drop { - { -1 [ err_no ECONNRESET = [ premature-close ] [ (io-error) ] if ] } + { -1 [ errno ECONNRESET = [ premature-close ] [ (io-error) ] if ] } { 0 [ premature-close ] } } case ] [ nip (ssl-error) ] if ; diff --git a/basis/io/sockets/unix/unix.factor b/basis/io/sockets/unix/unix.factor index f209df5862..e701874afd 100644 --- a/basis/io/sockets/unix/unix.factor +++ b/basis/io/sockets/unix/unix.factor @@ -37,8 +37,8 @@ M: object (get-remote-address) ( handle local -- sockaddr ) dup handle>> handle-fd f 0 write { { [ 0 = ] [ drop ] } - { [ err_no EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] } - { [ err_no EINTR = ] [ wait-to-connect ] } + { [ errno EAGAIN = ] [ dup +output+ wait-for-port wait-to-connect ] } + { [ errno EINTR = ] [ wait-to-connect ] } [ (io-error) ] } cond ; @@ -46,7 +46,7 @@ M: object establish-connection ( client-out remote -- ) [ drop ] [ [ handle>> handle-fd ] [ make-sockaddr/size ] bi* connect ] 2bi { { [ 0 = ] [ drop ] } - { [ err_no EINPROGRESS = ] [ + { [ errno EINPROGRESS = ] [ [ +output+ wait-for-port ] [ wait-to-connect ] bi ] } [ (io-error) ] @@ -78,8 +78,8 @@ M: object (accept) ( server addrspec -- fd sockaddr ) 2dup do-accept { { [ over 0 >= ] [ [ 2nip init-fd ] dip ] } - { [ err_no EINTR = ] [ 2drop (accept) ] } - { [ err_no EAGAIN = ] [ + { [ errno EINTR = ] [ 2drop (accept) ] } + { [ errno EAGAIN = ] [ 2drop [ drop +input+ wait-for-port ] [ (accept) ] @@ -121,10 +121,10 @@ M: unix (receive) ( datagram -- packet sockaddr ) :: do-send ( packet sockaddr len socket datagram -- ) socket handle-fd packet dup length 0 sockaddr len sendto 0 < [ - err_no EINTR = [ + errno EINTR = [ packet sockaddr len socket datagram do-send ] [ - err_no EAGAIN = [ + errno EAGAIN = [ datagram +output+ wait-for-port packet sockaddr len socket datagram do-send ] [ diff --git a/basis/lcs/diff2html/diff2html.factor b/basis/lcs/diff2html/diff2html.factor index 16e6cc8d97..ca9e48eb05 100644 --- a/basis/lcs/diff2html/diff2html.factor +++ b/basis/lcs/diff2html/diff2html.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: lcs xml.literals xml.writer kernel strings ; +USING: lcs xml.syntax xml.writer kernel strings ; FROM: accessors => item>> ; FROM: io => write ; FROM: sequences => each if-empty when-empty map ; diff --git a/basis/libc/libc.factor b/basis/libc/libc.factor index c4d351e6a0..c154544f81 100644 --- a/basis/libc/libc.factor +++ b/basis/libc/libc.factor @@ -2,10 +2,16 @@ ! Copyright (C) 2007, 2008 Slava Pestov ! Copyright (C) 2007, 2008 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: alien assocs continuations destructors kernel -namespaces accessors sets summary ; +USING: alien assocs continuations destructors +kernel namespaces accessors sets summary ; IN: libc +: errno ( -- int ) + "int" "factor" "err_no" { } alien-invoke ; + +: clear-errno ( -- ) + "void" "factor" "clear_err_no" { } alien-invoke ; + dup add-malloc ; : realloc ( alien size -- newalien ) + [ >c-ptr ] dip over malloc-exists? [ realloc-error ] unless dupd (realloc) check-ptr swap delete-malloc dup add-malloc ; : free ( alien -- ) - dup delete-malloc - (free) ; + >c-ptr [ delete-malloc ] [ (free) ] bi ; : memcpy ( dst src size -- ) "void" "libc" "memcpy" { "void*" "void*" "ulong" } alien-invoke ; diff --git a/extra/lists/authors.txt b/basis/lists/authors.txt similarity index 100% rename from extra/lists/authors.txt rename to basis/lists/authors.txt diff --git a/extra/lists/lazy/authors.txt b/basis/lists/lazy/authors.txt similarity index 100% rename from extra/lists/lazy/authors.txt rename to basis/lists/lazy/authors.txt diff --git a/extra/lists/lazy/examples/authors.txt b/basis/lists/lazy/examples/authors.txt similarity index 100% rename from extra/lists/lazy/examples/authors.txt rename to basis/lists/lazy/examples/authors.txt diff --git a/extra/lists/lazy/examples/examples-tests.factor b/basis/lists/lazy/examples/examples-tests.factor similarity index 100% rename from extra/lists/lazy/examples/examples-tests.factor rename to basis/lists/lazy/examples/examples-tests.factor diff --git a/extra/lists/lazy/examples/examples.factor b/basis/lists/lazy/examples/examples.factor similarity index 100% rename from extra/lists/lazy/examples/examples.factor rename to basis/lists/lazy/examples/examples.factor diff --git a/extra/lists/lazy/lazy-docs.factor b/basis/lists/lazy/lazy-docs.factor similarity index 82% rename from extra/lists/lazy/lazy-docs.factor rename to basis/lists/lazy/lazy-docs.factor index c402cdf15b..08fe3bbcba 100644 --- a/extra/lists/lazy/lazy-docs.factor +++ b/basis/lists/lazy/lazy-docs.factor @@ -1,11 +1,54 @@ ! 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 } +{ $subsection lappend } +{ $subsection lconcat } +{ $subsection lcartesian-product } +{ $subsection lcartesian-product* } +{ $subsection lmerge } +{ $subsection ltake } ; + HELP: lazy-cons -{ $values { "car" { $quotation "( -- X )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } +{ $values { "car" { $quotation "( -- elt )" } } { "cdr" { $quotation "( -- cons )" } } { "promise" "the resulting cons object" } } { $description "Constructs a cons object for a lazy list from two quotations. The " { $snippet "car" } " quotation should return the head of the list, and the " { $snippet "cons" } " quotation the tail when called. When " { $link cons } " or " { $link cdr } " are called on the lazy-cons object then the appropriate quotation is called." } { $see-also cons car cdr nil nil? } ; @@ -28,16 +71,12 @@ HELP: { $description "Constructs a cons object that wraps an existing cons object. Requests for the car, cdr and nil? will be remembered after the first call, and the previous result returned on subsequent calls." } { $see-also cons car cdr nil nil? } ; -{ lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words +{ lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lazy-map { $values { "list" "a cons object" } { "quot" { $quotation "( obj -- X )" } } { "result" "resulting cons object" } } { $description "Perform a similar functionality to that of the " { $link map } " word, but in a lazy manner. No evaluation of the list elements occurs initially but a " { $link } " 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 } " object is returned which conforms to the list protocol. Calling " { $link car } ", " { $link cdr } " or " { $link nil? } " on this will evaluate elements as required." } ; @@ -86,7 +125,7 @@ HELP: >list { $description "Convert the object into a list. Existing lists are passed through intact, sequences are converted using " { $link seq>list } " and other objects cause an error to be thrown." } { $see-also seq>list } ; -{ leach foldl lazy-map lazy-map-with ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words +{ leach foldl lazy-map ltake lfilter lappend lfrom lfrom-by lconcat lcartesian-product lcartesian-product* lcomp lcomp* lmerge lwhile luntil } related-words HELP: lconcat { $values { "list" "a list of lists" } { "result" "a list" } } diff --git a/extra/lists/lazy/lazy-tests.factor b/basis/lists/lazy/lazy-tests.factor similarity index 78% rename from extra/lists/lazy/lazy-tests.factor rename to basis/lists/lazy/lazy-tests.factor index 5749f94364..f4e55cba19 100644 --- a/extra/lists/lazy/lazy-tests.factor +++ b/basis/lists/lazy/lazy-tests.factor @@ -1,6 +1,5 @@ ! 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 @@ -25,5 +24,12 @@ IN: lists.lazy.tests ] unit-test [ { 4 5 6 } ] [ - 3 { 1 2 3 } >list [ + ] lazy-map-with list>array + 3 { 1 2 3 } >list [ + ] with lazy-map list>array ] unit-test + +[ [ ] lmap ] must-infer +[ [ ] lmap>array ] must-infer +[ [ drop ] foldr ] must-infer +[ [ drop ] foldl ] must-infer +[ [ drop ] leach ] must-infer +[ lnth ] must-infer diff --git a/extra/lists/lazy/lazy.factor b/basis/lists/lazy/lazy.factor similarity index 92% rename from extra/lists/lazy/lazy.factor rename to basis/lists/lazy/lazy.factor index e60fcbaadf..d3b08a11fb 100644 --- a/extra/lists/lazy/lazy.factor +++ b/basis/lists/lazy/lazy.factor @@ -1,12 +1,7 @@ -! Copyright (C) 2004 Chris Double. +! Copyright (C) 2004, 2008 Chris Double, Matthew Willis, James Cash. ! 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 ; +quotations promises combinators io lists accessors call ; IN: lists.lazy M: promise car ( promise -- car ) @@ -86,7 +81,7 @@ C: lazy-map M: lazy-map car ( lazy-map -- car ) [ cons>> car ] keep - quot>> call ; + quot>> call( old -- new ) ; M: lazy-map cdr ( lazy-map -- cdr ) [ cons>> cdr ] keep @@ -95,9 +90,6 @@ M: lazy-map cdr ( lazy-map -- cdr ) 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 @@ -130,7 +122,7 @@ M: lazy-until car ( lazy-until -- car ) cons>> car ; M: lazy-until cdr ( lazy-until -- cdr ) - [ cons>> uncons ] keep quot>> tuck call + [ cons>> unswons ] keep quot>> tuck call( elt -- ? ) [ 2drop nil ] [ luntil ] if ; M: lazy-until nil? ( lazy-until -- bool ) @@ -150,7 +142,7 @@ M: lazy-while cdr ( lazy-while -- cdr ) [ cons>> cdr ] keep quot>> lwhile ; M: lazy-while nil? ( lazy-while -- bool ) - [ car ] keep quot>> call not ; + [ car ] keep quot>> call( elt -- ? ) not ; TUPLE: lazy-filter cons quot ; @@ -160,7 +152,7 @@ C: lazy-filter over nil? [ 2drop nil ] [ ] if ; : car-filter? ( lazy-filter -- ? ) - [ cons>> car ] [ quot>> ] bi call ; + [ cons>> car ] [ quot>> ] bi call( elt -- ? ) ; : skip ( lazy-filter -- ) dup cons>> cdr >>cons drop ; @@ -221,7 +213,7 @@ M: lazy-from-by car ( lazy-from-by -- car ) M: lazy-from-by cdr ( lazy-from-by -- cdr ) [ n>> ] keep - quot>> dup slip lfrom-by ; + quot>> [ call( old -- new ) ] keep lfrom-by ; M: lazy-from-by nil? ( lazy-from-by -- bool ) drop f ; @@ -289,7 +281,7 @@ DEFER: lconcat dup nil? [ drop nil ] [ - uncons swap (lconcat) + uncons (lconcat) ] if ; M: lazy-concat car ( lazy-concat -- car ) @@ -306,14 +298,14 @@ M: lazy-concat nil? ( lazy-concat -- bool ) ] if ; : lcartesian-product ( list1 list2 -- result ) - swap [ swap [ 2array ] lazy-map-with ] lazy-map-with lconcat ; + swap [ swap [ 2array ] with lazy-map ] with lazy-map lconcat ; : lcartesian-product* ( lists -- result ) dup nil? [ drop nil ] [ [ car ] keep cdr [ car lcartesian-product ] keep cdr list>array swap [ - swap [ swap [ suffix ] lazy-map-with ] lazy-map-with lconcat + swap [ swap [ suffix ] with lazy-map ] with lazy-map lconcat ] reduce ] if ; @@ -355,7 +347,8 @@ M: lazy-io car ( lazy-io -- car ) dup car>> dup [ nip ] [ - drop dup stream>> over quot>> call + drop dup stream>> over quot>> + call( stream -- value ) >>car ] if ; diff --git a/extra/lists/lazy/old-doc.html b/basis/lists/lazy/old-doc.html similarity index 100% rename from extra/lists/lazy/old-doc.html rename to basis/lists/lazy/old-doc.html diff --git a/extra/lists/lazy/summary.txt b/basis/lists/lazy/summary.txt similarity index 100% rename from extra/lists/lazy/summary.txt rename to basis/lists/lazy/summary.txt diff --git a/extra/lists/lazy/tags.txt b/basis/lists/lazy/tags.txt similarity index 100% rename from extra/lists/lazy/tags.txt rename to basis/lists/lazy/tags.txt diff --git a/basis/lists/lists-docs.factor b/basis/lists/lists-docs.factor new file mode 100644 index 0000000000..8494d7c352 --- /dev/null +++ b/basis/lists/lists-docs.factor @@ -0,0 +1,187 @@ +! 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." } ; diff --git a/extra/lists/lists-tests.factor b/basis/lists/lists-tests.factor similarity index 63% rename from extra/lists/lists-tests.factor rename to basis/lists/lists-tests.factor index 4a08a4d1e3..13d2e03e0f 100644 --- a/extra/lists/lists-tests.factor +++ b/basis/lists/lists-tests.factor @@ -1,11 +1,10 @@ ! Copyright (C) 2008 James Cash ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test lists math ; - +USING: tools.test lists math kernel ; IN: lists.tests { { 3 4 5 6 7 } } [ - { 1 2 3 4 5 } seq>list [ 2 + ] lmap list>seq + { 1 2 3 4 5 } sequence>cons [ 2 + ] lmap list>array ] unit-test { { 3 4 5 6 } } [ @@ -38,33 +37,35 @@ IN: lists.tests +nil+ } } } +nil+ } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons + { 1 2 { 3 4 { 5 } } } deep-sequence>cons ] unit-test { { 1 2 { 3 4 { 5 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons cons>seq + { 1 2 { 3 4 { 5 } } } deep-sequence>cons deep-list>array ] unit-test { T{ cons f 2 T{ cons f 3 T{ cons f 4 T{ cons f 5 +nil+ } } } } } [ - { 1 2 3 4 } seq>cons [ 1+ ] lmap + { 1 2 3 4 } sequence>cons [ 1+ ] lmap ] unit-test { 15 } [ - { 1 2 3 4 5 } seq>list 0 [ + ] foldr + { 1 2 3 4 5 } sequence>cons 0 [ + ] foldr ] unit-test { { 5 4 3 2 1 } } [ - { 1 2 3 4 5 } seq>list lreverse list>seq + { 1 2 3 4 5 } sequence>cons lreverse list>array ] unit-test { 5 } [ - { 1 2 3 4 5 } seq>list llength + { 1 2 3 4 5 } sequence>cons llength ] unit-test { { 3 4 { 5 6 { 7 } } } } [ - { 1 2 { 3 4 { 5 } } } seq>cons [ atom? ] [ 2 + ] traverse cons>seq + { 1 2 { 3 4 { 5 } } } deep-sequence>cons [ atom? ] [ 2 + ] traverse deep-list>array ] unit-test { { 1 2 3 4 5 6 } } [ - { 1 2 3 } seq>list { 4 5 6 } seq>list lappend list>seq -] unit-test \ No newline at end of file + { 1 2 3 } sequence>cons { 4 5 6 } sequence>cons lappend list>array +] unit-test + +[ { 1 } { 2 } ] [ { 1 2 } sequence>cons 1 lcut [ list>array ] bi@ ] unit-test diff --git a/basis/lists/lists.factor b/basis/lists/lists.factor new file mode 100644 index 0000000000..4b0abb7f2d --- /dev/null +++ b/basis/lists/lists.factor @@ -0,0 +1,147 @@ +! 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 ; + + + +: 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 ) + nil [ swap cons ] reduce ; + + + +: deep-sequence>cons ( sequence -- cons ) + [ ] keep nil + [ tuck same? [ deep-sequence>cons ] when swons ] with reduce ; + +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 diff --git a/extra/lists/summary.txt b/basis/lists/summary.txt similarity index 100% rename from extra/lists/summary.txt rename to basis/lists/summary.txt diff --git a/basis/sequences/next/tags.txt b/basis/lists/tags.txt similarity index 100% rename from basis/sequences/next/tags.txt rename to basis/lists/tags.txt diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor index 704cae459a..acd2c3383f 100644 --- a/basis/macros/macros-docs.factor +++ b/basis/macros/macros-docs.factor @@ -1,27 +1,54 @@ -USING: help.markup help.syntax quotations kernel ; +USING: help.markup help.syntax quotations kernel +stack-checker.transforms sequences ; IN: macros HELP: MACRO: { $syntax "MACRO: word ( inputs... -- ) definition... ;" } -{ $description "Defines a compile-time code transformation. If all inputs to the word are literal and the word calling the macro has a static stack effect, then the macro body is invoked at compile-time to produce a quotation; this quotation is then spliced into the compiled code. If the inputs are not literal, or if the word is invoked from a word which does not have a static stack effect, the macro body will execute every time and the result will be passed to " { $link call } "." -$nl -"The stack effect declaration must be present because it tells the compiler how many literal inputs to expect." -} +{ $description "Defines a code transformation. The definition must have stack effect " { $snippet "( inputs... -- quot )" } "." } { $notes - "Semantically, the following two definitions are equivalent:" + "A call of a macro inside a word definition is replaced with the quotation expansion at compile-time if precisely the following conditions hold:" + { $list + { "All inputs to the macro call are literal" } + { "The word calling the macro has a static stack effect" } + { "The expansion quotation produced by the macro has a static stack effect" } + } + "If any of these conditions fail to hold, the macro will still work, but expansion will be performed at run-time." + $nl + "Other than possible compile-time expansion, the following two definition styles are equivalent:" { $code "MACRO: foo ... ;" } { $code ": foo ... call ;" } - "However, the compiler folds in macro definitions at compile-time where possible; if the macro body performs an expensive calculation, it can lead to a performance boost." + "Conceptually, macros allow computation to be moved from run-time to compile-time, splicing the result of this computation into the generated quotation." +} +{ $examples + "A macro that calls a quotation but preserves any values it consumes off the stack:" + { $code + "USING: fry generalizations ;" + "MACRO: preserving ( quot -- )" + " [ infer in>> length ] keep '[ _ ndup @ ] ;" + } + "Using this macro, we can define a variant of " { $link if } " which takes a predicate quotation instead of a boolean; any values consumed by the predicate quotation are restored immediately after:" + { $code + ": ifte ( pred true false -- ) [ preserving ] 2dip if ; inline" + } + "Note that " { $snippet "ifte" } " is an ordinary word, and it passes one of its inputs to the macro. If another word calls " { $snippet "ifte" } " with all three input quotations literal, then " { $snippet "ifte" } " will be inlined and " { $snippet "preserving" } " will expand at compile-time, and the generated machine code will be exactly the same as if the inputs consumed by the predicate were duplicated by hand." + $nl + "The " { $snippet "ifte" } " combinator presented here has similar semantics to the " { $snippet "ifte" } " combinator of the Joy programming language." } ; HELP: macro { $class-description "Class of words defined with " { $link POSTPONE: MACRO: } "." } ; ARTICLE: "macros" "Macros" -"The " { $vocab-link "macros" } " vocabulary implements macros in the Lisp sense; compile-time code transformers and generators. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code." +"The " { $vocab-link "macros" } " vocabulary implements " { $emphasis "macros" } ", which are code transformations that may run at compile-time under the right circumstances." +$nl +"Macros can be used to give static stack effects to combinators that otherwise would not have static stack effects. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code." +$nl +"Factor macros are similar to Lisp macros; they are not like C preprocessor macros." $nl "Defining new macros:" { $subsection POSTPONE: MACRO: } -"Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ; +"A slightly lower-level facility, " { $emphasis "compiler transforms" } ", allows an ordinary word definition to co-exist with a version that performs compile-time expansion." +{ $subsection define-transform } +"An example is the " { $link member? } " word. If the input sequence is a literal, the compile transform kicks in and converts the " { $link member? } " call into a series of conditionals. Otherwise, if the input sequence is not literal, a call to the definition of " { $link member? } " is generated." ; ABOUT: "macros" diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 1481e6eea5..4fba7efba3 100644 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -4,9 +4,13 @@ USING: parser kernel sequences words effects combinators assocs definitions quotations namespaces memoize accessors ; IN: macros +> 1 ; +PRIVATE> + : define-macro ( word definition -- ) [ "macro" set-word-prop ] [ over real-macro-effect memoize-quot [ call ] append define ] diff --git a/basis/math/blas/cblas/cblas.factor b/basis/math/blas/cblas/cblas.factor deleted file mode 100644 index 2a2e9e3a72..0000000000 --- a/basis/math/blas/cblas/cblas.factor +++ /dev/null @@ -1,574 +0,0 @@ -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 ) ; - diff --git a/basis/math/blas/cblas/summary.txt b/basis/math/blas/cblas/summary.txt deleted file mode 100644 index c72e78eb0d..0000000000 --- a/basis/math/blas/cblas/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library diff --git a/basis/math/blas/ffi/authors.txt b/basis/math/blas/ffi/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/basis/math/blas/ffi/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor new file mode 100644 index 0000000000..1749103ce4 --- /dev/null +++ b/basis/math/blas/ffi/ffi.factor @@ -0,0 +1,522 @@ +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 ) ; diff --git a/basis/math/blas/ffi/summary.txt b/basis/math/blas/ffi/summary.txt new file mode 100644 index 0000000000..8c0106b173 --- /dev/null +++ b/basis/math/blas/ffi/summary.txt @@ -0,0 +1 @@ +Low-level bindings to the Basic Linear Algebra Subroutines (BLAS) library diff --git a/basis/math/blas/cblas/tags.txt b/basis/math/blas/ffi/tags.txt similarity index 63% rename from basis/math/blas/cblas/tags.txt rename to basis/math/blas/ffi/tags.txt index 241ec1ecda..f468a9989d 100644 --- a/basis/math/blas/cblas/tags.txt +++ b/basis/math/blas/ffi/tags.txt @@ -1,2 +1,3 @@ math bindings +fortran diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor index f20a565e1f..17d2f9ccd1 100644 --- a/basis/math/blas/matrices/matrices-docs.factor +++ b/basis/math/blas/matrices/matrices-docs.factor @@ -8,40 +8,40 @@ ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" { $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 } { $subsection } -{ $subsection } -{ $subsection } +{ $subsection } +{ $subsection } { $subsection } { $subsection } -{ $subsection } -{ $subsection } +{ $subsection } +{ $subsection } "For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:" { $subsection } { $subsection } "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:" @@ -87,8 +87,8 @@ HELP: blas-matrix-base { $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 @@ -104,14 +104,14 @@ HELP: float-blas-matrix { $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 @@ -272,7 +272,7 @@ HELP: cmatrix{ { 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{ @@ -281,7 +281,7 @@ HELP: 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{ diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index 7b03ddf42a..6fad545501 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -1,11 +1,13 @@ 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 ; @@ -25,7 +27,7 @@ GENERIC: n*M.M+n*M! ( alpha A B beta C -- C=alpha*A.B+beta*C ) > [ CblasTrans ] [ CblasNoTrans ] if ; + transpose>> [ "T" ] [ "N" ] if ; GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) @@ -38,73 +40,70 @@ 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 @@ -250,16 +249,18 @@ FUNCTOR: (define-blas-matrix) ( TYPE T U C -- ) VECTOR IS ${TYPE}-blas-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 ${TYPE}-blas-matrix +MATRIX DEFINES-CLASS ${TYPE}-blas-matrix DEFINES <${TYPE}-blas-matrix> >MATRIX DEFINES >${TYPE}-blas-matrix -XMATRIX{ DEFINES ${T}matrix{ + +t [ T >lower ] + +XMATRIX{ DEFINES ${t}matrix{ WHERE @@ -277,21 +278,16 @@ M: MATRIX (blas-vector-like) drop ; : >MATRIX ( arrays -- matrix ) - [ >ARRAY underlying>> ] (>matrix) - ; + [ >ARRAY underlying>> ] (>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 @@ -304,12 +300,12 @@ M: MATRIX pprint-delims : 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 >> diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index ede10ab61b..241ec1ecda 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1 +1,2 @@ math +bindings diff --git a/basis/math/blas/vectors/vectors-docs.factor b/basis/math/blas/vectors/vectors-docs.factor index b37a4b966e..296437c32b 100644 --- a/basis/math/blas/vectors/vectors-docs.factor +++ b/basis/math/blas/vectors/vectors-docs.factor @@ -37,8 +37,8 @@ HELP: blas-vector-base { $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 @@ -51,10 +51,10 @@ HELP: float-blas-vector { $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 } } @@ -145,11 +145,11 @@ HELP: dvector{ 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{ diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 3b7f89f730..84b5fd9e6f 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,10 +1,12 @@ -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 ; @@ -31,7 +33,7 @@ GENERIC: (blas-direct-array) ( blas-vector -- direct-array ) : 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 @@ -130,15 +132,20 @@ FUNCTOR: (define-blas-vector) ( TYPE T -- ) IS >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 ${TYPE}-blas-vector +VECTOR DEFINES-CLASS ${TYPE}-blas-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 @@ -157,7 +164,7 @@ M: VECTOR element-type M: VECTOR Vswap (prepare-swap) [ XSWAP ] 2dip ; M: VECTOR Viamax - (prepare-nrm2) IXAMAX ; + (prepare-nrm2) IXAMAX 1- ; M: VECTOR (blas-vector-like) drop ; @@ -167,6 +174,11 @@ M: VECTOR (blas-direct-array) [ [ length>> ] [ inc>> ] bi * ] bi ; +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 @@ -178,11 +190,9 @@ 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 @@ -194,33 +204,6 @@ M: VECTOR Vnorm (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 -- ) - - DEFINES ->COMPLEX-ARRAY DEFINES >${TYPE}-complex-array -ARG>COMPLEX DEFINES arg>${TYPE}-complex -COMPLEX>ARG DEFINES ${TYPE}-complex>arg - IS ->ARRAY IS >${TYPE}-array - -WHERE - -: ( alien len -- sequence ) - 1 shift ; -: >COMPLEX-ARRAY ( sequence -- sequence ) - >ARRAY ; -: COMPLEX>ARG ( complex -- alien ) - >rect 2array >ARRAY underlying>> ; -: ARG>COMPLEX ( alien -- complex ) - 2 first2 rect> ; ;FUNCTOR @@ -228,35 +211,21 @@ WHERE 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 - [ XDOTU_SUB ] keep - ARG>TYPE ; + (prepare-dot) XDOTU ; M: VECTOR V.conj - (prepare-dot) TYPE - [ 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 @@ -264,16 +233,14 @@ M: VECTOR n*V! : 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 ; +: 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 -"float" "c" "s" define-complex-blas-vector -"double" "z" "d" define-complex-blas-vector +"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 >> diff --git a/basis/math/polynomials/polynomials.factor b/basis/math/polynomials/polynomials.factor index 1ece3d915e..749bde3a10 100644 --- a/basis/math/polynomials/polynomials.factor +++ b/basis/math/polynomials/polynomials.factor @@ -1,6 +1,6 @@ ! 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 @@ -75,7 +75,7 @@ PRIVATE> 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 ; diff --git a/basis/math/primes/factors/factors-tests.factor b/basis/math/primes/factors/factors-tests.factor index f247683c1c..983de51216 100644 --- a/basis/math/primes/factors/factors-tests.factor +++ b/basis/math/primes/factors/factors-tests.factor @@ -6,3 +6,4 @@ USING: math.primes.factors tools.test ; { { 999983 1000003 } } [ 999969000187000867 unique-factors ] unit-test { 999967000236000612 } [ 999969000187000867 totient ] unit-test { 0 } [ 1 totient ] unit-test +{ { 425612003 } } [ 425612003 factors ] unit-test diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor index 05d6b26010..4c36fc0a85 100644 --- a/basis/math/primes/factors/factors.factor +++ b/basis/math/primes/factors/factors.factor @@ -16,7 +16,11 @@ IN: math.primes.factors PRIVATE> : group-factors ( n -- seq ) - [ 2 [ over 1 > ] [ write-factor next-prime ] [ ] while 2drop ] { } make ; + [ + 2 + [ 2dup sq < ] [ write-factor next-prime ] [ ] until + drop dup 2 < [ drop ] [ 1 2array , ] if + ] { } make ; : unique-factors ( n -- seq ) group-factors [ first ] map ; diff --git a/basis/mime/multipart/multipart.factor b/basis/mime/multipart/multipart.factor index fc3024bd01..37d5e13129 100755 --- a/basis/mime/multipart/multipart.factor +++ b/basis/mime/multipart/multipart.factor @@ -42,7 +42,7 @@ ERROR: end-of-stream multipart ; [ t >>end-of-stream? ] if* ; : maybe-fill-bytes ( multipart -- multipart ) - dup bytes>> [ fill-bytes ] unless ; + dup bytes>> length 256 < [ fill-bytes ] when ; : split-bytes ( bytes separator -- leftover-bytes safe-to-dump ) dupd [ length ] bi@ 1- - short cut-slice swap ; @@ -65,6 +65,7 @@ ERROR: end-of-stream multipart ; [ dump-until-separator ] with-string-writer ; : read-header ( multipart -- multipart ) + maybe-fill-bytes dup bytes>> "--\r\n" sequence= [ t >>end-of-stream? ] [ @@ -99,7 +100,7 @@ ERROR: end-of-stream multipart ; dup name>> empty-name? [ drop ] [ - [ [ header>> ] [ name>> unquote ] [ name-content>> ] tri mime-variable boa ] + [ name-content>> ] [ name>> unquote ] [ mime-parts>> set-at ] tri ] if ; diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor index f5868ee7a1..6d9ac95965 100644 --- a/basis/opengl/opengl.factor +++ b/basis/opengl/opengl.factor @@ -53,16 +53,16 @@ MACRO: all-enabled-client-state ( seq quot -- ) glMatrixMode glPopMatrix ; inline : gl-material ( face pname params -- ) - float-array{ } like underlying>> glMaterialfv ; + float-array{ } like glMaterialfv ; : gl-vertex-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip underlying>> glVertexPointer ; inline + [ 2 GL_FLOAT 0 ] dip glVertexPointer ; inline : gl-color-pointer ( seq -- ) - [ 4 GL_FLOAT 0 ] dip underlying>> glColorPointer ; inline + [ 4 GL_FLOAT 0 ] dip glColorPointer ; inline : gl-texture-coord-pointer ( seq -- ) - [ 2 GL_FLOAT 0 ] dip underlying>> glTexCoordPointer ; inline + [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline : line-vertices ( a b -- ) [ first2 [ 0.5 + ] bi@ ] bi@ 4 float-array{ } nsequence @@ -177,7 +177,7 @@ MACRO: all-enabled-client-state ( seq quot -- ) glActiveTexture swap glBindTexture gl-error ; : (set-draw-buffers) ( buffers -- ) - [ length ] [ >uint-array underlying>> ] bi glDrawBuffers ; + [ length ] [ >uint-array ] bi glDrawBuffers ; MACRO: set-draw-buffers ( buffers -- ) words>values [ (set-draw-buffers) ] curry ; diff --git a/basis/opengl/shaders/shaders.factor b/basis/opengl/shaders/shaders.factor index eb5bbb0ee8..a77d29da2f 100755 --- a/basis/opengl/shaders/shaders.factor +++ b/basis/opengl/shaders/shaders.factor @@ -96,7 +96,7 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ; dup gl-program-shaders-length 0 over - [ underlying>> glGetAttachedShaders ] keep ; + [ glGetAttachedShaders ] keep ; : delete-gl-program-only ( program -- ) glDeleteProgram ; inline diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor index aec4414c71..27cba6d6e7 100755 --- a/basis/pack/pack.factor +++ b/basis/pack/pack.factor @@ -5,33 +5,9 @@ io.binary io.streams.string kernel math math.parser namespaces make parser prettyprint quotations sequences strings vectors words macros math.functions math.bitwise fry generalizations combinators.smart io.streams.byte-array io.encodings.binary -math.vectors combinators multiline ; +math.vectors combinators multiline endian ; IN: pack -SYMBOL: big-endian - -: big-endian? ( -- ? ) - 1 *char zero? ; - - - -: >signed ( x n -- y ) - 2dup neg 1+ shift 1 = [ 2^ - ] [ drop ] if ; - -: >endian ( obj n -- str ) - big-endian get [ >be ] [ >le ] if ; inline - -: unsigned-endian> ( obj -- str ) - big-endian get [ be> ] [ le> ] if ; inline - -: signed-endian> ( obj n -- str ) - [ unsigned-endian> ] dip >signed ; - GENERIC: >n-byte-array ( obj n -- byte-array ) M: integer >n-byte-array ( m n -- byte-array ) >endian ; @@ -111,13 +87,11 @@ CONSTANT: packed-length-table { CHAR: D 8 } } +PRIVATE> + MACRO: pack ( str -- quot ) [ pack-table at '[ _ execute ] ] { } map-as - '[ _ spread ] - '[ _ input + '[ [ [ _ spread ] inputpacked-length ( ch -- n ) packed-length-table at ; inline @@ -126,35 +100,35 @@ PRIVATE> [ ch>packed-length ] sigma ; : pack-native ( seq str -- seq ) - [ set-big-endian pack ] with-scope ; inline + '[ _ _ pack ] with-native-endian ; inline : pack-be ( seq str -- seq ) - [ big-endian on pack ] with-scope ; inline + '[ _ _ pack ] with-big-endian ; inline : pack-le ( seq str -- seq ) - [ big-endian off pack ] with-scope ; inline + '[ _ _ pack ] with-little-endian ; inline + MACRO: unpack ( str -- quot ) [ [ ch>packed-length ] { } map-as start/end ] [ [ unpack-table at '[ @ ] ] { } map-as ] bi [ '[ [ _ _ ] dip @ ] ] 3map - '[ _ cleave ] '[ _ output>array ] ; - -PRIVATE> + '[ [ _ cleave ] output>array ] ; : unpack-native ( seq str -- seq ) - [ set-big-endian unpack ] with-scope ; inline + '[ _ _ unpack ] with-native-endian ; inline : unpack-be ( seq str -- seq ) - [ big-endian on unpack ] with-scope ; inline + '[ _ _ unpack ] with-big-endian ; inline : unpack-le ( seq str -- seq ) - [ big-endian off unpack ] with-scope ; inline + '[ _ _ unpack ] with-little-endian ; inline ERROR: packed-read-fail str bytes ; diff --git a/basis/persistent/deques/deques-docs.factor b/basis/persistent/deques/deques-docs.factor index 43018bed16..f1027d107b 100644 --- a/basis/persistent/deques/deques-docs.factor +++ b/basis/persistent/deques/deques-docs.factor @@ -1,3 +1,5 @@ +! Copyright (C) 2008 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax kernel sequences ; IN: persistent.deques diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index be63d807b9..8f93ae1ab8 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -1,7 +1,6 @@ -! 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 @@ -9,32 +8,13 @@ IN: persistent.deques ! same source, it could take O(m) amortized time per update. 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 ] reduce ; - -: length ( list -- length ) - 0 [ drop 1+ ] reduce ; - -: cut ( list index -- back front-reversed ) - f swap [ [ [ cdr>> ] [ car>> ] bi ] dip ] 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 ) T{ deque } ; +: ( -- deque ) + T{ deque f +nil+ +nil+ } ; : deque-empty? ( deque -- ? ) - [ front>> ] [ back>> ] bi or not ; + { [ front>> nil? ] [ back>> nil? ] } 1&& ; > ] [ back>> ] bi deque boa ; inline + [ front>> cons ] [ back>> ] bi deque boa ; inline PRIVATE> : push-front ( deque item -- newdeque ) @@ -60,14 +40,15 @@ PRIVATE> > 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 ) @@ -76,12 +57,14 @@ PRIVATE> : 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 ) - [ push-back ] sequences:reduce ; + [ 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 ; diff --git a/basis/regexp/traversal/traversal.factor b/basis/regexp/traversal/traversal.factor index d8c25eda18..104a6c2ce1 100644 --- a/basis/regexp/traversal/traversal.factor +++ b/basis/regexp/traversal/traversal.factor @@ -2,8 +2,7 @@ ! 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 @@ -170,7 +169,7 @@ M: capture-group-off flag-action ( dfa-traverser flag -- ) ] [ 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|| ; diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor index 81a6d69a09..24713545b1 100644 --- a/basis/roman/roman.factor +++ b/basis/roman/roman.factor @@ -31,7 +31,7 @@ ERROR: roman-range-error n ; ] 2each drop ; : (roman>) ( seq -- n ) - dup [ roman>n ] map swap all-eq? [ + [ [ roman>n ] map ] [ all-eq? ] bi [ sum ] [ first2 swap - diff --git a/basis/sequences/next/next-tests.factor b/basis/sequences/next/next-tests.factor deleted file mode 100644 index be728b2d8e..0000000000 --- a/basis/sequences/next/next-tests.factor +++ /dev/null @@ -1,5 +0,0 @@ -USING: sequences.next tools.test arrays kernel math sequences ; - -[ { { 1 0 } { 2 1 } { f 2 } } ] [ 3 [ 2array ] map-next ] unit-test - -[ 8 ] [ 3 [ 1+ ] map 0 swap [ swap [ + + ] [ drop ] if* ] each-next ] unit-test diff --git a/basis/sequences/next/next.factor b/basis/sequences/next/next.factor deleted file mode 100644 index 19b406cc58..0000000000 --- a/basis/sequences/next/next.factor +++ /dev/null @@ -1,21 +0,0 @@ -USING: kernel sequences sequences.private math ; -IN: sequences.next - - - -: each-next ( seq quot: ( next-elt elt -- ) -- ) - iterate-seq [ (map-next) ] 2curry each-integer ; inline - -: map-next ( seq quot: ( next-elt elt -- newelt ) -- newseq ) - over dup length swap new-sequence [ - iterate-seq [ (map-next) ] 2curry - ] dip [ collect ] keep ; inline diff --git a/basis/sequences/next/summary.txt b/basis/sequences/next/summary.txt deleted file mode 100644 index fe5bd315de..0000000000 --- a/basis/sequences/next/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Iteration with access to next element diff --git a/basis/shuffle/shuffle-tests.factor b/basis/shuffle/shuffle-tests.factor index f190544e19..e091af2d06 100644 --- a/basis/shuffle/shuffle-tests.factor +++ b/basis/shuffle/shuffle-tests.factor @@ -1,5 +1,5 @@ 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 diff --git a/basis/shuffle/shuffle.factor b/basis/shuffle/shuffle.factor index b195e4abf9..6cae048d27 100644 --- a/basis/shuffle/shuffle.factor +++ b/basis/shuffle/shuffle.factor @@ -1,19 +1,29 @@ ! 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 +index-assoc ( sequence -- assoc ) + dup length zip >hashtable ; + +PRIVATE> + +MACRO: shuffle-effect ( effect -- ) + [ out>> ] [ in>> >index-assoc ] bi + [ + [ nip assoc-size , \ narray , ] + [ [ at \ swap \ nth [ ] 3sequence ] curry map , \ cleave , ] 2bi + ] [ ] make ; + +: shuffle( + ")" parse-effect parsed \ shuffle-effect parsed ; parsing + : 2swap ( x y z t -- z t x y ) 2 2 mnswap ; inline -: nipd ( a b c -- b c ) rot drop ; inline - -: 3nip ( a b c d -- d ) 3 nnip ; inline - -: 4nip ( a b c d e -- e ) 4 nnip ; 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 diff --git a/basis/specialized-arrays/complex-double/complex-double-tests.factor b/basis/specialized-arrays/complex-double/complex-double-tests.factor new file mode 100644 index 0000000000..9f2bcc99b7 --- /dev/null +++ b/basis/specialized-arrays/complex-double/complex-double-tests.factor @@ -0,0 +1,13 @@ +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 diff --git a/basis/specialized-arrays/complex-double/complex-double.factor b/basis/specialized-arrays/complex-double/complex-double.factor new file mode 100644 index 0000000000..00b07fb9b3 --- /dev/null +++ b/basis/specialized-arrays/complex-double/complex-double.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.complex-double + +<< "complex-double" define-array >> diff --git a/basis/specialized-arrays/complex-float/complex-float.factor b/basis/specialized-arrays/complex-float/complex-float.factor new file mode 100644 index 0000000000..5348343bae --- /dev/null +++ b/basis/specialized-arrays/complex-float/complex-float.factor @@ -0,0 +1,4 @@ +USE: specialized-arrays.functor +IN: specialized-arrays.complex-float + +<< "complex-float" define-array >> diff --git a/basis/specialized-arrays/direct/complex-double/complex-double.factor b/basis/specialized-arrays/direct/complex-double/complex-double.factor new file mode 100644 index 0000000000..ae8d2b5fb3 --- /dev/null +++ b/basis/specialized-arrays/direct/complex-double/complex-double.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.complex-double specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.complex-double + +<< "complex-double" define-direct-array >> diff --git a/basis/specialized-arrays/direct/complex-float/complex-float.factor b/basis/specialized-arrays/direct/complex-float/complex-float.factor new file mode 100644 index 0000000000..8971196297 --- /dev/null +++ b/basis/specialized-arrays/direct/complex-float/complex-float.factor @@ -0,0 +1,4 @@ +USING: specialized-arrays.complex-float specialized-arrays.direct.functor ; +IN: specialized-arrays.direct.complex-float + +<< "complex-float" define-direct-array >> diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index ce23186fc6..e7e891fede 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/basis/specialized-arrays/direct/functor/functor.factor @@ -11,10 +11,10 @@ A' IS ${T}-array >A' IS >${T}-array IS <${A'}> -A DEFINES direct-${T}-array +A DEFINES-CLASS direct-${T}-array 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 diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 9a56346be4..09433a3b51 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/basis/specialized-arrays/functor/functor.factor @@ -15,14 +15,14 @@ M: bad-byte-array-length summary FUNCTOR: define-array ( T -- ) -A DEFINES ${T}-array +A DEFINES-CLASS ${T}-array DEFINES <${A}> (A) DEFINES (${A}) >A DEFINES >${A} 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 diff --git a/basis/specialized-arrays/specialized-arrays-docs.factor b/basis/specialized-arrays/specialized-arrays-docs.factor index 1c1b3dbc59..9015cccd8f 100644 --- a/basis/specialized-arrays/specialized-arrays-docs.factor +++ b/basis/specialized-arrays/specialized-arrays-docs.factor @@ -28,6 +28,8 @@ $nl { $snippet "ulonglong" } { $snippet "float" } { $snippet "double" } + { $snippet "complex-float" } + { $snippet "complex-double" } { $snippet "void*" } { $snippet "bool" } } diff --git a/basis/specialized-arrays/specialized-arrays-tests.factor b/basis/specialized-arrays/specialized-arrays-tests.factor index 1ca041191e..73e719b806 100644 --- a/basis/specialized-arrays/specialized-arrays-tests.factor +++ b/basis/specialized-arrays/specialized-arrays-tests.factor @@ -1,7 +1,8 @@ IN: specialized-arrays.tests USING: tools.test specialized-arrays sequences specialized-arrays.int specialized-arrays.bool -specialized-arrays.ushort alien.c-types accessors kernel ; +specialized-arrays.ushort alien.c-types accessors kernel +specialized-arrays.direct.int arrays ; [ t ] [ { 1 2 3 } >int-array int-array? ] unit-test @@ -16,3 +17,7 @@ specialized-arrays.ushort alien.c-types accessors kernel ; ] unit-test [ B{ 210 4 1 } byte-array>ushort-array ] must-fail + +[ { 3 1 3 3 7 } ] [ + int-array{ 3 1 3 3 7 } malloc-byte-array 5 >array +] unit-test \ No newline at end of file diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 2410cc284e..9d48a9e79e 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -9,7 +9,7 @@ FUNCTOR: define-vector ( T -- ) A IS ${T}-array IS <${A}> -V DEFINES ${T}-vector +V DEFINES-CLASS ${T}-vector DEFINES <${V}> >V DEFINES >${V} V{ DEFINES ${V}{ diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 7cdce301b5..56aebb20e7 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -89,44 +89,37 @@ M: composed infer-call* M: object infer-call* \ literal-expected inference-warning ; -: infer-slip ( -- ) - 1 infer->r infer-call 1 infer-r> ; +: infer-nslip ( n -- ) + [ infer->r infer-call ] [ infer-r> ] bi ; -: infer-2slip ( -- ) - 2 infer->r infer-call 2 infer-r> ; +: infer-slip ( -- ) 1 infer-nslip ; -: infer-3slip ( -- ) - 3 infer->r infer-call 3 infer-r> ; +: infer-2slip ( -- ) 2 infer-nslip ; -: infer-dip ( -- ) - literals get - [ \ dip def>> infer-quot-here ] - [ pop 1 infer->r infer-quot-here 1 infer-r> ] +: infer-3slip ( -- ) 3 infer-nslip ; + +: infer-ndip ( word n -- ) + [ literals get ] 2dip + [ '[ _ def>> infer-quot-here ] ] + [ '[ _ [ pop ] dip [ infer->r infer-quot-here ] [ infer-r> ] bi ] ] bi* if-empty ; -: infer-2dip ( -- ) - literals get - [ \ 2dip def>> infer-quot-here ] - [ pop 2 infer->r infer-quot-here 2 infer-r> ] - if-empty ; +: infer-dip ( -- ) \ dip 1 infer-ndip ; -: infer-3dip ( -- ) - literals get - [ \ 3dip def>> infer-quot-here ] - [ pop 3 infer->r infer-quot-here 3 infer-r> ] - if-empty ; +: infer-2dip ( -- ) \ 2dip 2 infer-ndip ; -: infer-curry ( -- ) - 2 consume-d - dup first2 make-known - [ push-d ] [ 1array ] bi - \ curry #call, ; +: infer-3dip ( -- ) \ 3dip 3 infer-ndip ; -: infer-compose ( -- ) - 2 consume-d - dup first2 make-known - [ push-d ] [ 1array ] bi - \ compose #call, ; +: infer-builder ( quot word -- ) + [ + [ 2 consume-d ] dip + [ dup first2 ] dip call make-known + [ push-d ] [ 1array ] bi + ] dip #call, ; inline + +: infer-curry ( -- ) [ ] \ curry infer-builder ; + +: infer-compose ( -- ) [ ] \ compose infer-builder ; : infer-execute ( -- ) pop-literal nip diff --git a/basis/stack-checker/stack-checker-docs.factor b/basis/stack-checker/stack-checker-docs.factor index 5b67cd9adc..5926f08d8c 100644 --- a/basis/stack-checker/stack-checker-docs.factor +++ b/basis/stack-checker/stack-checker-docs.factor @@ -80,13 +80,6 @@ $nl "[ [ 5 ] t foo ] infer." } ; -ARTICLE: "compiler-transforms" "Compiler transforms" -"Compiler transforms can be used to allow words to compile which would otherwise not have a stack effect, and to expand combinators into more efficient code at compile time." -{ $subsection define-transform } -"An example is the " { $link cond } " word. If the association list of quotations it is given is literal, the entire form is expanded into a series of nested calls to " { $link if } "." -$nl -"The " { $vocab-link "macros" } " vocabulary defines some nice syntax sugar which makes compiler transforms easier to work with." ; - ARTICLE: "inference" "Stack effect inference" "The stack effect inference tool is used to check correctness of code before it is run. It is also used by the optimizing compiler to build the high-level SSA representation on which optimizations can be performed. Only words for which a stack effect can be inferred will compile with the optimizing compiler; all other words will be compiled with the non-optimizing compiler (see " { $link "compiler" } ")." $nl @@ -103,7 +96,6 @@ $nl { $subsection "inference-recursive-combinators" } { $subsection "inference-branches" } { $subsection "inference-errors" } -{ $subsection "compiler-transforms" } { $see-also "effects" } ; ABOUT: "inference" diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index 4d7295042c..bc6eb9f092 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -577,3 +577,8 @@ DEFER: eee' [ bogus-error ] must-infer [ [ clear ] infer. ] [ inference-error? ] must-fail-with + +: debugging-curry-folding ( quot -- ) + [ debugging-curry-folding ] curry call ; inline recursive + +[ [ ] debugging-curry-folding ] must-infer \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms-docs.factor b/basis/stack-checker/transforms/transforms-docs.factor index a178669595..de0edc4528 100644 --- a/basis/stack-checker/transforms/transforms-docs.factor +++ b/basis/stack-checker/transforms/transforms-docs.factor @@ -3,12 +3,11 @@ USING: help.markup help.syntax combinators words kernel ; HELP: define-transform { $values { "word" word } { "quot" "a quotation taking " { $snippet "n" } " inputs from the stack and producing another quotation as output" } { "n" "a non-negative integer" } } -{ $description "Defines a compiler transform for the optimizing compiler. When a call to " { $snippet "word" } " is being compiled, the compiler ensures that the top " { $snippet "n" } " stack values are literal; if they are not, compilation fails. The literal values are passed to the quotation, which is expected to produce a new quotation. The call to the word is then replaced by this quotation." } -{ $examples "Here is a word which pops " { $snippet "n" } " values from the stack:" -{ $code ": ndrop ( n -- ) [ drop ] times ;" } -"This word is inefficient; it does not have a static stack effect. This means that words calling " { $snippet "ndrop" } " cannot be compiled by the optimizing compiler, and additionally, a call to this word will always involve a loop with arithmetic, even if the value of " { $snippet "n" } " is known at compile time. A compiler transform can fix this:" -{ $code "\\ ndrop [ \\ drop >quotation ] 1 define-transform" } -"Now, a call like " { $snippet "4 ndrop" } " is replaced with " { $snippet "drop drop drop drop" } " at compile time; the optimizer then ensures that this compiles as a single machine instruction, which is a lot cheaper than an actual call to " { $snippet "ndrop" } "." +{ $description "Defines a compiler transform for the optimizing compiler." + "When a call to " { $snippet "word" } " is being compiled, the compiler first checks that the top " { $snippet "n" } " stack values are literal, and if so, calls the quotation with those inputs at compile time. The quotation can output a new quotation, or " { $link f } "." $nl -"The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":" +"If the quotation outputs " { $link f } ", or if not all inputs are literal, a call to the word is compiled as usual, or compilation fails if the word does not have a static stack effect." +$nl +"Otherwise, if the transform output a new quotation, the quotation replaces the word's call site." } +{ $examples "The " { $link cond } " word compiles to efficient code because it is transformed using " { $link cond>quot } ":" { $code "\\ cond [ cond>quot ] 1 define-transform" } } ; diff --git a/basis/stack-checker/transforms/transforms-tests.factor b/basis/stack-checker/transforms/transforms-tests.factor index 8ae30dcd97..fe580084c0 100644 --- a/basis/stack-checker/transforms/transforms-tests.factor +++ b/basis/stack-checker/transforms/transforms-tests.factor @@ -42,3 +42,27 @@ C: color [ bad-new-test ] must-infer [ bad-new-test ] must-fail + +! Corner case if macro expansion calls 'infer', found by Doug +DEFER: smart-combo ( quot -- ) + +\ smart-combo [ infer [ ] curry ] 1 define-transform + +[ [ "a" "b" "c" ] smart-combo ] must-infer + +[ [ [ "a" "b" ] smart-combo "c" ] smart-combo ] must-infer + +: very-smart-combo ( quot -- ) smart-combo ; inline + +[ [ "a" "b" "c" ] very-smart-combo ] must-infer + +[ [ [ "a" "b" ] very-smart-combo "c" ] very-smart-combo ] must-infer + +! Caveat found by Doug +DEFER: curry-folding-test ( quot -- ) + +\ curry-folding-test [ length \ drop >quotation ] 1 define-transform + +{ 3 0 } [ [ 1 2 3 ] curry-folding-test ] must-infer-as +{ 3 0 } [ 1 [ 2 3 ] curry curry-folding-test ] must-infer-as +{ 3 0 } [ [ 1 2 ] 3 [ ] curry compose curry-folding-test ] must-infer-as \ No newline at end of file diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor index 808ea6a141..a2f616480a 100755 --- a/basis/stack-checker/transforms/transforms.factor +++ b/basis/stack-checker/transforms/transforms.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2007, 2008 Slava Pestov. +! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: fry accessors arrays kernel words sequences generic math namespaces make quotations assocs combinators classes.tuple classes.tuple.private effects summary hashtables classes generic -sets definitions generic.standard slots.private continuations +sets definitions generic.standard slots.private continuations locals stack-checker.backend stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; @@ -15,48 +15,34 @@ IN: stack-checker.transforms [ dup infer-word apply-word/effect ] if ; -: ((apply-transform)) ( word quot values stack -- ) - rot with-datastack first2 - dup [ - [ - [ drop ] - [ [ length meta-d shorten-by ] [ #drop, ] bi ] bi* - ] 2dip - swap infer-quot - ] [ - 3drop give-up-transform - ] if ; inline +:: ((apply-transform)) ( word quot values stack rstate -- ) + rstate recursive-state + [ stack quot with-datastack first ] with-variable + [ + word inlined-dependency depends-on + values [ length meta-d shorten-by ] [ #drop, ] bi + rstate infer-quot + ] [ word give-up-transform ] if* ; + +: literals? ( values -- ? ) [ literal-value? ] all? ; : (apply-transform) ( word quot n -- ) - ensure-d dup [ known literal? ] all? [ - dup empty? [ - recursive-state get 1array - ] [ + ensure-d dup literals? [ + dup empty? [ dup recursive-state get ] [ [ ] [ [ literal value>> ] map ] [ first literal recursion>> ] tri - prefix ] if ((apply-transform)) ] [ 2drop give-up-transform ] if ; : apply-transform ( word -- ) - [ inlined-dependency depends-on ] [ - [ ] - [ "transform-quot" word-prop ] - [ "transform-n" word-prop ] - tri - (apply-transform) - ] bi ; + [ ] [ "transform-quot" word-prop ] [ "transform-n" word-prop ] tri + (apply-transform) ; : apply-macro ( word -- ) - [ inlined-dependency depends-on ] [ - [ ] - [ "macro" word-prop ] - [ "declared-effect" word-prop in>> length ] - tri - (apply-transform) - ] bi ; + [ ] [ "macro" word-prop ] [ "declared-effect" word-prop in>> length ] tri + (apply-transform) ; : define-transform ( word quot n -- ) [ drop "transform-quot" set-word-prop ] diff --git a/basis/stack-checker/values/values.factor b/basis/stack-checker/values/values.factor index 97aa774e55..19db441381 100644 --- a/basis/stack-checker/values/values.factor +++ b/basis/stack-checker/values/values.factor @@ -26,27 +26,51 @@ SYMBOL: known-values : copy-values ( values -- values' ) [ copy-value ] map ; +GENERIC: (literal-value?) ( value -- ? ) + +M: object (literal-value?) drop f ; + +GENERIC: (literal) ( value -- literal ) + ! Literal value TUPLE: literal < identity-tuple value recursion hashcode ; +: literal ( value -- literal ) known (literal) ; + +: literal-value? ( value -- ? ) known (literal-value?) ; + M: literal hashcode* nip hashcode>> ; : ( obj -- value ) recursive-state get over hashcode \ literal boa ; -GENERIC: (literal) ( value -- literal ) +M: literal (literal-value?) drop t ; M: literal (literal) ; -: literal ( value -- literal ) - known (literal) ; +: curried/composed-literal ( input1 input2 quot -- literal ) + [ [ literal ] bi@ ] dip + [ [ [ value>> ] bi@ ] dip call ] [ drop nip recursion>> ] 3bi + over hashcode \ literal boa ; inline ! Result of curry TUPLE: curried obj quot ; C: curried +: >curried< ( curried -- obj quot ) + [ obj>> ] [ quot>> ] bi ; inline + +M: curried (literal-value?) >curried< [ literal-value? ] both? ; +M: curried (literal) >curried< [ curry ] curried/composed-literal ; + ! Result of compose TUPLE: composed quot1 quot2 ; C: composed + +: >composed< ( composed -- quot1 quot2 ) + [ quot1>> ] [ quot2>> ] bi ; inline + +M: composed (literal-value?) >composed< [ literal-value? ] both? ; +M: composed (literal) >composed< [ compose ] curried/composed-literal ; \ No newline at end of file diff --git a/basis/struct-arrays/struct-arrays-tests.factor b/basis/struct-arrays/struct-arrays-tests.factor index 6f77e66cd2..a8ce98888c 100755 --- a/basis/struct-arrays/struct-arrays-tests.factor +++ b/basis/struct-arrays/struct-arrays-tests.factor @@ -22,7 +22,7 @@ C-STRUCT: test-struct [ 5/4 ] [ [ 2 "test-struct" malloc-struct-array - dup underlying>> &free drop + dup &free drop 1 2 make-point over set-first 3 4 make-point over set-second 0 [ [ test-struct-x ] [ test-struct-y ] bi / + ] reduce @@ -34,6 +34,6 @@ C-STRUCT: test-struct [ ] [ [ 10 "test-struct" malloc-struct-array - underlying>> &free drop + &free drop ] with-destructors ] unit-test \ No newline at end of file diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor index 4cd5ef17b3..9901fd4ce4 100755 --- a/basis/syndication/syndication.factor +++ b/basis/syndication/syndication.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2006 Chris Double, Daniel Ehrenberg. ! Portions copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: xml.utilities kernel assocs math.order +USING: xml.traversal kernel assocs math.order strings sequences xml.data xml.writer io.streams.string combinators xml xml.entities.html io.files io - http.client namespaces make xml.literals hashtables + http.client namespaces make xml.syntax hashtables calendar.format accessors continuations urls present ; IN: syndication diff --git a/basis/tools/annotations/annotations.factor b/basis/tools/annotations/annotations.factor index ecf3ba0a76..b436be5163 100644 --- a/basis/tools/annotations/annotations.factor +++ b/basis/tools/annotations/annotations.factor @@ -87,7 +87,7 @@ M: word annotate-methods SYMBOL: word-timing -word-timing global [ H{ } clone or ] change-at +word-timing [ H{ } clone ] initialize : reset-word-timing ( -- ) word-timing get clear-assoc ; diff --git a/basis/tools/deploy/backend/backend.factor b/basis/tools/deploy/backend/backend.factor old mode 100644 new mode 100755 index 636e44062e..ff851edce6 --- a/basis/tools/deploy/backend/backend.factor +++ b/basis/tools/deploy/backend/backend.factor @@ -11,8 +11,8 @@ tools.deploy.config.editor bootstrap.image io.encodings.utf8 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 [ diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor old mode 100644 new mode 100755 index 91b4d603af..8fe31ac6cc --- a/basis/tools/deploy/macosx/macosx.factor +++ b/basis/tools/deploy/macosx/macosx.factor @@ -54,7 +54,7 @@ IN: tools.deploy.macosx } 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 ) diff --git a/basis/tools/deploy/unix/unix.factor b/basis/tools/deploy/unix/unix.factor old mode 100644 new mode 100755 index 9e0bb8ac68..c9bf308357 --- a/basis/tools/deploy/unix/unix.factor +++ b/basis/tools/deploy/unix/unix.factor @@ -8,7 +8,7 @@ IN: tools.deploy.unix : create-app-dir ( vocab bundle-name -- vm ) dup "" copy-fonts - "" copy-vm + copy-vm dup OCT: 755 set-file-permissions ; : bundle-name ( -- str ) diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor index 7ce635b1ba..0e9146b26e 100755 --- a/basis/tools/deploy/windows/windows.factor +++ b/basis/tools/deploy/windows/windows.factor @@ -1,9 +1,9 @@ -! 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 -- ) @@ -15,13 +15,18 @@ IN: tools.deploy.windows "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:" [ diff --git a/basis/ui/cocoa/cocoa.factor b/basis/ui/cocoa/cocoa.factor index 331c0a698c..2fc8856b26 100755 --- a/basis/ui/cocoa/cocoa.factor +++ b/basis/ui/cocoa/cocoa.factor @@ -141,9 +141,9 @@ CLASS: { 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 [ diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor index 732a438203..f57fb60bcd 100644 --- a/basis/ui/gadgets/worlds/worlds.factor +++ b/basis/ui/gadgets/worlds/worlds.factor @@ -81,7 +81,7 @@ SYMBOL: ui-error-hook : 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? [ diff --git a/basis/ui/tools/interactor/interactor.factor b/basis/ui/tools/interactor/interactor.factor index 40da6ebafc..eb2eef3742 100644 --- a/basis/ui/tools/interactor/interactor.factor +++ b/basis/ui/tools/interactor/interactor.factor @@ -5,7 +5,7 @@ hashtables io io.styles kernel math math.order math.vectors 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 @@ -82,8 +82,7 @@ M: interactor model-changed 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 diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor index 37ce4ea499..78f150987f 100644 --- a/basis/ui/ui.factor +++ b/basis/ui/ui.factor @@ -4,7 +4,7 @@ USING: arrays assocs io kernel math models namespaces make 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 @@ -140,7 +140,7 @@ SYMBOL: ui-hook layout-queued redraw-worlds send-queued-gestures - ] assert-depth + ] call( -- ) ] [ ui-error ] recover ; SYMBOL: ui-thread diff --git a/basis/unicode/case/case-tests.factor b/basis/unicode/case/case-tests.factor index 6e26a36a19..52a8d9755e 100644 --- a/basis/unicode/case/case-tests.factor +++ b/basis/unicode/case/case-tests.factor @@ -1,4 +1,7 @@ -USING: unicode.case tools.test namespaces ; +! Copyright (C) 2008, 2009 Daniel Ehrenberg. +! See http://factorcode.org/license.txt for BSD license. +USING: unicode.case unicode.case.private tools.test namespaces strings unicode.normalize ; +IN: unicode.case.tests \ >upper must-infer \ >lower must-infer @@ -9,12 +12,21 @@ USING: unicode.case tools.test namespaces ; [ "\u0003C3a\u0003C2 \u0003C3\u0003C2 \u0003C3a\u0003C2" ] [ "\u0003A3A\u0003A3 \u0003A3\u0003A3 \u0003A3A\u0003A3" >lower ] unit-test [ t ] [ "hello how are you?" lower? ] unit-test [ + [ f ] [ i-dot? ] unit-test + [ f ] [ lt? ] unit-test "tr" locale set + [ t ] [ i-dot? ] unit-test + [ f ] [ lt? ] unit-test [ "i\u000131i \u000131jj" ] [ "i\u000131I\u000307 IJj" >lower ] unit-test [ "I\u000307\u000131i Ijj" ] [ "i\u000131I\u000307 IJj" >title ] unit-test [ "I\u000307II\u000307 IJJ" ] [ "i\u000131I\u000307 IJj" >upper ] unit-test "lt" locale set - ! Lithuanian casing tests + [ f ] [ i-dot? ] unit-test + [ t ] [ lt? ] unit-test + [ "i\u000307\u000300" ] [ HEX: CC 1string nfd >lower ] unit-test + [ "\u00012f\u000307" ] [ HEX: 12E 1string nfd >lower nfc ] unit-test + [ "I\u000300" ] [ "i\u000307\u000300" >upper ] unit-test +! [ "I\u000300" ] [ "i\u000307\u000300" >title ] unit-test ] with-scope [ t ] [ "asdf" lower? ] unit-test diff --git a/basis/unicode/case/case.factor b/basis/unicode/case/case.factor index 7566138e11..3ac98cd57f 100644 --- a/basis/unicode/case/case.factor +++ b/basis/unicode/case/case.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008 Daniel Ehrenberg. +! Copyright (C) 2008, 2009 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. -USING: unicode.data sequences sequences.next namespaces +USING: unicode.data sequences namespaces sbufs make unicode.syntax unicode.normalize math hints -unicode.categories combinators unicode.syntax assocs +unicode.categories combinators unicode.syntax assocs combinators.short-circuit strings splitting kernel accessors unicode.breaks fry locals ; QUALIFIED: ascii IN: unicode.case @@ -26,6 +26,9 @@ SYMBOL: locale ! Just casing locale, or overall? : i-dot? ( -- ? ) locale get { "tr" "az" } member? ; +: lt? ( -- ? ) + locale get "lt" = ; + : lithuanian? ( -- ? ) locale get "lt" = ; : dot-over ( -- ch ) HEX: 307 ; @@ -37,18 +40,21 @@ SYMBOL: locale ! Just casing locale, or overall? : mark-above? ( ch -- ? ) combining-class 230 = ; -: with-rest ( seq quot: ( seq -- seq ) -- seq ) - [ unclip ] dip swap slip prefix ; inline +:: with-rest ( seq quot: ( seq -- seq ) -- seq ) + seq unclip quot dip prefix ; inline : add-dots ( seq -- seq ) - [ [ "" ] [ - dup first mark-above? - [ CHAR: combining-dot-above prefix ] when + [ [ { } ] [ + [ + dup first + { [ mark-above? ] [ CHAR: combining-ogonek = ] } 1|| + [ CHAR: combining-dot-above prefix ] when + ] map ] if-empty ] with-rest ; inline : lithuanian>lower ( string -- lower ) - "i" split add-dots "i" join - "j" split add-dots "i" join ; inline + "I" split add-dots "I" join + "J" split add-dots "J" join ; inline : turk>upper ( string -- upper-i ) "i" "I\u000307" replace ; inline @@ -88,13 +94,16 @@ SYMBOL: locale ! Just casing locale, or overall? PRIVATE> : >lower ( string -- lower ) - i-dot? [ turk>lower ] when final-sigma + i-dot? [ turk>lower ] when + lt? [ lithuanian>lower ] when + final-sigma [ lower>> ] [ ch>lower ] map-case ; HINTS: >lower string ; : >upper ( string -- upper ) i-dot? [ turk>upper ] when + lt? [ lithuanian>upper ] when [ upper>> ] [ ch>upper ] map-case ; HINTS: >upper string ; @@ -103,6 +112,7 @@ HINTS: >upper string ; : (>title) ( string -- title ) i-dot? [ turk>upper ] when + lt? [ lithuanian>upper ] when [ title>> ] [ ch>title ] map-case ; inline : title-word ( string -- title ) diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 42444261e2..a6a0147504 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -17,6 +17,10 @@ CONSTANT: MAP_FILE 0 CONSTANT: MAP_SHARED 1 CONSTANT: MAP_PRIVATE 2 +CONSTANT: SEEK_SET 0 +CONSTANT: SEEK_CUR 1 +CONSTANT: SEEK_END 2 + : MAP_FAILED ( -- alien ) -1 ; inline CONSTANT: NGROUPS_MAX 16 @@ -37,18 +41,13 @@ C-STRUCT: group { "int" "gr_gid" } { "char**" "gr_mem" } ; -LIBRARY: factor - -FUNCTION: void clear_err_no ( ) ; -FUNCTION: int err_no ( ) ; - LIBRARY: libc FUNCTION: char* strerror ( int errno ) ; ERROR: unix-error errno message ; -: (io-error) ( -- * ) err_no dup strerror unix-error ; +: (io-error) ( -- * ) errno dup strerror unix-error ; : io-error ( n -- ) 0 < [ (io-error) ] when ; @@ -61,7 +60,7 @@ MACRO:: unix-system-call ( quot -- ) n ndup quot call dup 0 < [ drop n narray - err_no dup strerror + errno dup strerror word unix-system-call-error ] [ n nnip diff --git a/basis/unix/utilities/utilities.factor b/basis/unix/utilities/utilities.factor index e2f780cd13..29b137e3de 100644 --- a/basis/unix/utilities/utilities.factor +++ b/basis/unix/utilities/utilities.factor @@ -16,5 +16,5 @@ IN: unix.utilities '[ [ advance ] [ *void* _ alien>string ] bi ] [ ] produce nip ; -: strings>alien ( strings encoding -- alien ) - '[ _ malloc-string ] void*-array{ } map-as f suffix underlying>> ; +: strings>alien ( strings encoding -- array ) + '[ _ malloc-string ] void*-array{ } map-as f suffix ; diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor index f6c25980ea..437a9419e3 100644 --- a/basis/urls/urls-docs.factor +++ b/basis/urls/urls-docs.factor @@ -82,8 +82,8 @@ HELP: parse-host { $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" } } ; diff --git a/basis/windows/com/wrapper/wrapper.factor b/basis/windows/com/wrapper/wrapper.factor index 813d8315ac..c86cde23d9 100755 --- a/basis/windows/com/wrapper/wrapper.factor +++ b/basis/windows/com/wrapper/wrapper.factor @@ -132,7 +132,7 @@ unless [ [ 1 ] 2dip set-alien-unsigned-4 ] [ drop ] 2bi ; : (callbacks>vtbl) ( callbacks -- vtbl ) - [ execute ] void*-array{ } map-as underlying>> malloc-byte-array ; + [ execute ] void*-array{ } map-as malloc-byte-array ; : (callbacks>vtbls) ( callbacks -- vtbls ) [ (callbacks>vtbl) ] map ; diff --git a/basis/windows/dinput/constants/constants.factor b/basis/windows/dinput/constants/constants.factor index 0e9a03f075..314fb167e3 100755 --- a/basis/windows/dinput/constants/constants.factor +++ b/basis/windows/dinput/constants/constants.factor @@ -59,7 +59,7 @@ SYMBOLS: struct args i alien set-nth ] each-index - alien underlying>> + alien ] ; : (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien ) diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index d3e823f844..3494e83e83 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1235,7 +1235,7 @@ ALIAS: GetFileAttributesEx GetFileAttributesExW FUNCTION: BOOL GetFileInformationByHandle ( HANDLE hFile, LPBY_HANDLE_FILE_INFORMATION lpFileInformation ) ; FUNCTION: DWORD GetFileSize ( HANDLE hFile, LPDWORD lpFileSizeHigh ) ; -! FUNCTION: GetFileSizeEx +FUNCTION: BOOL GetFileSizeEx ( HANDLE hFile, PLARGE_INTEGER lpFileSize ) ; FUNCTION: BOOL GetFileTime ( HANDLE hFile, LPFILETIME lpCreationTime, LPFILETIME lpLastAccessTime, LPFILETIME lpLastWriteTime ) ; FUNCTION: DWORD GetFileType ( HANDLE hFile ) ; ! FUNCTION: GetFirmwareEnvironmentVariableA diff --git a/basis/wrap/strings/strings-docs.factor b/basis/wrap/strings/strings-docs.factor new file mode 100644 index 0000000000..e20780d3ac --- /dev/null +++ b/basis/wrap/strings/strings-docs.factor @@ -0,0 +1,25 @@ +! 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." } ; + diff --git a/basis/wrap/strings/strings-tests.factor b/basis/wrap/strings/strings-tests.factor new file mode 100644 index 0000000000..e66572dc1b --- /dev/null +++ b/basis/wrap/strings/strings-tests.factor @@ -0,0 +1,43 @@ +! 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 diff --git a/basis/wrap/strings/strings.factor b/basis/wrap/strings/strings.factor new file mode 100644 index 0000000000..7009352f2a --- /dev/null +++ b/basis/wrap/strings/strings.factor @@ -0,0 +1,29 @@ +! Copyright (C) 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: wrap kernel sequences fry splitting math ; +IN: wrap.strings + + ] 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 ; diff --git a/basis/wrap/words/words-docs.factor b/basis/wrap/words/words-docs.factor new file mode 100644 index 0000000000..422aea0ac3 --- /dev/null +++ b/basis/wrap/words/words-docs.factor @@ -0,0 +1,25 @@ +! 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 } ; + +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 } "." } +{ $see-also wrap-words } ; + +HELP: +{ $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 } ; diff --git a/basis/wrap/wrap-tests.factor b/basis/wrap/words/words-tests.factor similarity index 55% rename from basis/wrap/wrap-tests.factor rename to basis/wrap/words/words-tests.factor index ba5168a1c2..7598b382ba 100644 --- a/basis/wrap/wrap-tests.factor +++ b/basis/wrap/words/words-tests.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2008, 2009 Daniel Ehrenberg, Slava Pestov +! Copyright (C) 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: tools.test wrap multiline sequences ; -IN: wrap.tests - +USING: tools.test wrap.words sequences ; +IN: wrap.words.tests + [ { { @@ -22,7 +22,7 @@ IN: wrap.tests T{ word f 3 2 t } T{ word f 4 10 f } T{ word f 5 10 f } - } 35 wrap [ { } like ] map + } 35 35 wrap-words [ { } like ] map ] unit-test [ @@ -48,35 +48,35 @@ IN: wrap.tests T{ word f 3 9 t } T{ word f 4 10 f } T{ word f 5 10 f } - } 35 wrap [ { } like ] map + } 35 35 wrap-words [ { } like ] map ] unit-test [ - <" This is a -long piece -of text -that we -wish to -word wrap."> + { + { + 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 } + } + } ] [ - <" 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 + { + 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 -[ "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 +\ wrap-words must-infer diff --git a/basis/wrap/words/words.factor b/basis/wrap/words/words.factor new file mode 100644 index 0000000000..bcf4460170 --- /dev/null +++ b/basis/wrap/words/words.factor @@ -0,0 +1,40 @@ +! 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 + +> ] map sum ; + +: make-element ( whites blacks -- element ) + [ append ] [ [ words-length ] bi@ ] 2bi ; + +: ?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 [ ?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 ; + diff --git a/basis/wrap/wrap-docs.factor b/basis/wrap/wrap-docs.factor index c94e12907f..feac7c51a7 100644 --- a/basis/wrap/wrap-docs.factor +++ b/basis/wrap/wrap-docs.factor @@ -6,36 +6,6 @@ IN: wrap 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 } ; - -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 } "." } -{ $see-also wrap } ; - -HELP: -{ $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" } ; diff --git a/basis/wrap/wrap.factor b/basis/wrap/wrap.factor index e93509b58e..0b7f869141 100644 --- a/basis/wrap/wrap.factor +++ b/basis/wrap/wrap.factor @@ -1,73 +1,85 @@ -! 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 -TUPLE: word key width break? ; +: element-length ( element -- n ) + [ black>> ] [ white>> ] bi + ; -C: word +TUPLE: paragraph lines head-width tail-cost ; +C: paragraph -> 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 -- ) +: paragraph-cost ( paragraph -- cost ) + dup lines>> 1list? [ drop 0 ] [ + [ head-width>> deviation ] + [ tail-cost>> ] bi + + ] if ; + +: min-cost ( paragraphs -- paragraph ) + [ paragraph-cost ] min-by ; + +: new-line ( paragraph element -- paragraph ) + [ [ lines>> ] [ 1list ] bi* swons ] + [ nip black>> ] + [ drop paragraph-cost ] 2tri + ; + +: glue ( paragraph element -- paragraph ) + [ [ lines>> unswons ] dip swons swons ] + [ [ head-width>> ] [ element-length ] bi* + ] + [ drop tail-cost>> ] 2tri + ; + +: wrap-step ( paragraphs element -- paragraphs ) + [ '[ _ glue ] map ] + [ [ min-cost ] dip new-line ] + 2bi prefix + [ fits? ] filter ; + +: 1paragraph ( element -- paragraph ) + [ 1list 1list ] + [ black>> ] bi + 0 ; + +: post-process ( paragraph -- array ) + lines>> deep-list>array + [ [ contents>> ] map ] map ; + +: initialize ( elements -- elements paragraph ) + unclip-slice 1paragraph 1array ; + +: wrap ( elements line-max line-ideal -- paragraph ) [ - dup find-optimal-break - [ cut-slice [ , ] [ (wrap) ] bi* ] [ , ] if* - ] unless-empty ; - -: intersperse ( seq elt -- seq' ) - [ '[ _ , ] [ , ] interleave ] { } make ; - -: split-lines ( string -- words-lines ) - string-lines [ - " \t" split harvest - [ dup length f ] map - " " 1 t intersperse - ] map ; - -: join-words ( wrapped-lines -- lines ) - [ - [ break?>> ] trim-slice - [ key>> ] map concat - ] map ; - -: join-lines ( strings -- string ) - "\n" join ; - -PRIVATE> - -: wrap ( words width -- lines ) - width [ - [ (wrap) ] { } make - ] with-variable ; - -: wrap-lines ( lines width -- newlines ) - [ split-lines ] dip '[ _ wrap join-words ] 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 ; + line-ideal set + line-max set + initialize + [ wrap-step ] reduce + min-cost + post-process + ] with-scope ; diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index d3fe0a8447..8375636a72 100644 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -51,7 +51,7 @@ TUPLE: x-clipboard atom contents ; "TARGETS" x-atom 32 PropModeReplace { "UTF8_STRING" "STRING" "TARGETS" "TIMESTAMP" - } [ x-atom ] int-array{ } map-as underlying>> + } [ x-atom ] int-array{ } map-as 4 XChangeProperty drop ; : set-timestamp-prop ( evt -- ) diff --git a/basis/x11/glx/glx.factor b/basis/x11/glx/glx.factor index e0b786ce7d..11473d6e83 100644 --- a/basis/x11/glx/glx.factor +++ b/basis/x11/glx/glx.factor @@ -93,7 +93,7 @@ FUNCTION: void* glXGetProcAddressARB ( char* procname ) ; GLX_RGBA , GLX_DEPTH_SIZE , 16 , 0 , - ] int-array{ } make underlying>> + ] int-array{ } make glXChooseVisual [ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ; diff --git a/basis/x11/xim/xim.factor b/basis/x11/xim/xim.factor index 856420af0f..534e47ac37 100644 --- a/basis/x11/xim/xim.factor +++ b/basis/x11/xim/xim.factor @@ -50,7 +50,7 @@ SYMBOL: keysym : lookup-string ( event xic -- string keysym ) [ prepare-lookup - swap keybuf get underlying>> buf-size keysym get 0 + swap keybuf get buf-size keysym get 0 XwcLookupString finish-lookup ] with-scope ; diff --git a/basis/xml-rpc/xml-rpc.factor b/basis/xml-rpc/xml-rpc.factor index d9028756f2..690ebe94f8 100644 --- a/basis/xml-rpc/xml-rpc.factor +++ b/basis/xml-rpc/xml-rpc.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel xml arrays math generic http.client combinators hashtables namespaces io base64 sequences strings -calendar xml.data xml.writer xml.utilities assocs math.parser -debugger calendar.format math.order xml.literals xml.dispatch ; +calendar xml.data xml.writer xml.traversal assocs math.parser +debugger calendar.format math.order xml.syntax ; IN: xml-rpc ! * Sending RPC requests @@ -113,20 +113,24 @@ M: server-error error. "Description: " write dup message>> print "Tag: " write tag>> xml>string print ; -PROCESS: xml>item ( tag -- object ) +TAGS: xml>item ( tag -- object ) TAG: string xml>item children>string ; -TAG: i4/int/double xml>item +: children>number ( tag -- n ) children>string string>number ; +TAG: i4 xml>item children>number ; +TAG: int xml>item children>number ; +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 @@ -174,5 +178,5 @@ TAG: array xml>item ! This needs to do something in the event of an error [ send-rpc ] dip http-post nip string>xml receive-rpc ; -: invoke-method ( params method url -- ) +: invoke-method ( params method url -- response ) [ swap ] dip post-rpc ; diff --git a/basis/xml/data/data-docs.factor b/basis/xml/data/data-docs.factor index 639ef5591c..8c837fdf19 100644 --- a/basis/xml/data/data-docs.factor +++ b/basis/xml/data/data-docs.factor @@ -10,7 +10,7 @@ ARTICLE: "xml.data" "XML data types" "Simple words for manipulating names:" { $subsection names-match? } { $subsection assure-name } -"For high-level tools for manipulating XML, see " { $vocab-link "xml.utilities" } ; +"For high-level tools for manipulating XML, see " { $vocab-link "xml.traversal" } ; ARTICLE: { "xml.data" "classes" } "XML data classes" "XML documents and chunks are made of the following classes:" diff --git a/basis/xml/dispatch/dispatch-docs.factor b/basis/xml/dispatch/dispatch-docs.factor deleted file mode 100644 index 572a75cd05..0000000000 --- a/basis/xml/dispatch/dispatch-docs.factor +++ /dev/null @@ -1,25 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: help.markup help.syntax ; -IN: xml.dispatch - -ABOUT: "xml.dispatch" - -ARTICLE: "xml.dispatch" "Dispatch on XML tag names" -"Two parsing words define a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use" -{ $subsection POSTPONE: PROCESS: } -"and to define a new 'method' for this word, use" -{ $subsection POSTPONE: TAG: } ; - -HELP: PROCESS: -{ $syntax "PROCESS: word" } -{ $values { "word" "a new word to define" } } -{ $description "creates a new word to process XML tags" } -{ $see-also POSTPONE: TAG: } ; - -HELP: TAG: -{ $syntax "TAG: tag word definition... ;" } -{ $values { "tag" "an xml tag name" } { "word" "an XML process" } } -{ $description "defines what a process should do when it encounters a specific tag" } -{ $examples { $code "PROCESS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } -{ $see-also POSTPONE: PROCESS: } ; diff --git a/basis/xml/dispatch/dispatch-tests.factor b/basis/xml/dispatch/dispatch-tests.factor deleted file mode 100644 index 6f3179bc02..0000000000 --- a/basis/xml/dispatch/dispatch-tests.factor +++ /dev/null @@ -1,31 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: xml io kernel math sequences strings xml.utilities -tools.test math.parser xml.dispatch ; -IN: xml.dispatch.tests - -PROCESS: calculate ( tag -- n ) - -: calc-2children ( tag -- n n ) - children-tags first2 [ calculate ] dip calculate ; - -TAG: number calculate - children>string string>number ; -TAG: add calculate - calc-2children + ; -TAG: minus calculate - calc-2children - ; -TAG: times calculate - calc-2children * ; -TAG: divide calculate - calc-2children / ; -TAG: neg calculate - children-tags first calculate neg ; - -: calc-arith ( string -- n ) - string>xml first-child-tag calculate ; - -[ 32 ] [ - "13-8" - calc-arith -] unit-test diff --git a/basis/xml/dispatch/dispatch.factor b/basis/xml/dispatch/dispatch.factor deleted file mode 100644 index 23cb43cc47..0000000000 --- a/basis/xml/dispatch/dispatch.factor +++ /dev/null @@ -1,27 +0,0 @@ -! Copyright (C) 2005, 2009 Daniel Ehrenberg -! See http://factorcode.org/license.txt for BSD license. -USING: words assocs kernel accessors parser sequences summary -lexer splitting fry ; -IN: xml.dispatch - -TUPLE: process-missing process tag ; -M: process-missing summary - drop "Tag not implemented on process" ; - -: run-process ( tag word -- ) - 2dup "xtable" word-prop - [ dup main>> ] dip at* [ 2nip call ] [ - drop \ process-missing boa throw - ] if ; - -: PROCESS: - CREATE - dup H{ } clone "xtable" set-word-prop - dup '[ _ run-process ] define ; parsing - -: TAG: - scan scan-word - parse-definition - swap "xtable" word-prop - rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ; - parsing diff --git a/basis/xml/literals/authors.txt b/basis/xml/literals/authors.txt deleted file mode 100644 index 29e79639ae..0000000000 --- a/basis/xml/literals/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg \ No newline at end of file diff --git a/basis/xml/literals/literals-docs.factor b/basis/xml/literals/literals-docs.factor deleted file mode 100644 index a37fcbd711..0000000000 --- a/basis/xml/literals/literals-docs.factor +++ /dev/null @@ -1,60 +0,0 @@ -USING: help.markup help.syntax present multiline xml.data ; -IN: xml.literals - -ABOUT: "xml.literals" - -ARTICLE: "xml.literals" "XML literals" -"The " { $vocab-link "xml.literals" } " vocabulary provides a convenient syntax for generating XML documents and chunks. It defines the following parsing words:" -{ $subsection POSTPONE: ... XML>" } -{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ; - -HELP: [XML -{ $syntax "[XML foo ... bar ... baz XML]" } -{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.literals" "interpolation" } } "." } ; - -ARTICLE: { "xml.literals" "interpolation" } "XML interpolation syntax" -"XML interpolation has two forms for each of the words " { $link POSTPONE: " } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles." -$nl -"These forms can be used where a tag might go, as in " { $snippet "[XML <-> XML]" } " or where an attribute might go, as in " { $snippet "[XML /> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:" -{ $example -{" USING: splitting sequences xml.writer xml.literals ; -"one two three" " " split -[ [XML <-> XML] ] map -<-> XML> pprint-xml"} -{" - - - one - - - two - - - three - -"} } -"Here is an example of the locals version:" -{ $example -{" USING: locals urls xml.literals xml.writer ; -[let | - number [ 3 ] - false [ f ] - url [ URL" http://factorcode.org/" ] - string [ "hello" ] - word [ \ drop ] | - - false=<-false-> - url=<-url-> - string=<-string-> - word=<-word-> /> - XML> pprint-xml ] "} -{" -"} } ; diff --git a/basis/xml/literals/literals-tests.factor b/basis/xml/literals/literals-tests.factor deleted file mode 100644 index 59bd178f39..0000000000 --- a/basis/xml/literals/literals-tests.factor +++ /dev/null @@ -1,68 +0,0 @@ -! Copyright (C) 2009 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: tools.test xml.literals multiline kernel assocs -sequences accessors xml.writer xml.literals.private -locals splitting urls xml.data classes ; -IN: xml.literals.tests - -[ "a" "c" { "a" "c" f } ] [ - "<-a->/><->" - string>doc - [ second var>> ] - [ fourth "val" attr var>> ] - [ extract-variables ] tri -] unit-test - -[ {" - - one - - y - -"} ] [ - [let* | a [ "one" ] c [ "two" ] x [ "y" ] - d [ [XML <-x-> XML] ] | - <-a-> /> <-d-> - XML> pprint-xml>string - ] -] unit-test - -[ {" - - - one - - - two - - - three - -"} ] [ - "one two three" " " split - [ [XML <-> XML] ] map - <-> XML> pprint-xml>string -] unit-test - -[ {" -"} ] -[ 3 f URL" http://factorcode.org/" "hello" \ drop - false=<-> url=<-> string=<-> word=<->/> XML> - pprint-xml>string ] unit-test - -[ "3" ] [ 3 [XML <-> XML] xml>string ] unit-test -[ "" ] [ f [XML <-> XML] xml>string ] unit-test - -\ <-> /> XML] ] must-infer - -[ xml-chunk ] [ [ [XML XML] ] first class ] unit-test -[ xml ] [ [ XML> ] first class ] unit-test -[ xml-chunk ] [ [ [XML /> XML] ] third class ] unit-test -[ xml ] [ [ /> XML> ] third class ] unit-test -[ 1 ] [ [ [XML XML] ] length ] unit-test -[ 1 ] [ [ XML> ] length ] unit-test - -[ "" ] [ [XML XML] concat ] unit-test diff --git a/basis/xml/literals/literals.factor b/basis/xml/literals/literals.factor deleted file mode 100644 index f245c7a542..0000000000 --- a/basis/xml/literals/literals.factor +++ /dev/null @@ -1,109 +0,0 @@ -! Copyright (C) 2009 Daniel Ehrenberg. -! See http://factorcode.org/license.txt for BSD license. -USING: xml xml.state kernel sequences fry assocs xml.data -accessors strings make multiline parser namespaces macros -sequences.deep generalizations words combinators -math present arrays unicode.categories ; -IN: xml.literals - -chunk ( string -- chunk ) - t interpolating? [ string>xml-chunk ] with-variable ; - -: string>doc ( string -- xml ) - t interpolating? [ string>xml ] with-variable ; - -DEFER: interpolate-sequence - -: interpolate-attrs ( table attrs -- attrs ) - swap '[ - dup interpolated? - [ var>> _ at dup [ present ] when ] when - ] assoc-map [ nip ] assoc-filter ; - -: interpolate-tag ( table tag -- tag ) - [ nip name>> ] - [ attrs>> interpolate-attrs ] - [ children>> [ interpolate-sequence ] [ drop f ] if* ] 2tri - ; - -GENERIC: push-item ( item -- ) -M: string push-item , ; -M: xml-data push-item , ; -M: object push-item present , ; -M: sequence push-item - dup xml-data? [ , ] [ [ push-item ] each ] if ; -M: number push-item present , ; -M: xml-chunk push-item % ; - -GENERIC: interpolate-item ( table item -- ) -M: object interpolate-item nip , ; -M: tag interpolate-item interpolate-tag , ; -M: interpolated interpolate-item - var>> swap at push-item ; - -: interpolate-sequence ( table seq -- seq ) - [ [ interpolate-item ] with each ] { } make ; - -: interpolate-xml-doc ( table xml -- xml ) - (clone) [ interpolate-tag ] change-body ; - -: (each-interpolated) ( item quot: ( interpolated -- ) -- ) - { - { [ over interpolated? ] [ call ] } - { [ over tag? ] [ - [ attrs>> values [ interpolated? ] filter ] dip each - ] } - { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] } - [ 2drop ] - } cond ; inline recursive - -: each-interpolated ( xml quot -- ) - '[ _ (each-interpolated) ] deep-each ; inline - -: number<-> ( doc -- dup ) - 0 over [ - dup var>> [ - over >>var [ 1+ ] dip - ] unless drop - ] each-interpolated drop ; - -GENERIC: interpolate-xml ( table xml -- xml ) - -M: xml interpolate-xml - interpolate-xml-doc ; - -M: xml-chunk interpolate-xml - interpolate-sequence ; - -: >search-hash ( seq -- hash ) - [ dup search ] H{ } map>assoc ; - -: extract-variables ( xml -- seq ) - [ [ var>> , ] each-interpolated ] { } make ; - -: nenum ( ... n -- assoc ) - narray ; inline - -: collect ( accum variables -- accum ? ) - { - { [ dup empty? ] [ drop f ] } ! Just a literal - { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals - { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry - [ drop "XML interpolation contains both fry and locals" throw ] ! mixed - } cond ; - -: parse-def ( accum delimiter quot -- accum ) - [ parse-multiline-string [ blank? ] trim ] dip call - [ extract-variables collect ] keep swap - [ number<-> parsed ] dip - [ \ interpolate-xml parsed ] when ; inline - -PRIVATE> - -: " [ string>doc ] parse-def ; parsing - -: [XML - "XML]" [ string>chunk ] parse-def ; parsing diff --git a/basis/xml/literals/summary.txt b/basis/xml/literals/summary.txt deleted file mode 100644 index 7c18fc8c76..0000000000 --- a/basis/xml/literals/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Syntax for XML interpolation diff --git a/basis/xml/literals/tags.txt b/basis/xml/literals/tags.txt deleted file mode 100644 index d236e9679f..0000000000 --- a/basis/xml/literals/tags.txt +++ /dev/null @@ -1,2 +0,0 @@ -syntax -enterprise diff --git a/basis/xml/dispatch/authors.txt b/basis/xml/syntax/authors.txt similarity index 100% rename from basis/xml/dispatch/authors.txt rename to basis/xml/syntax/authors.txt diff --git a/basis/xml/dispatch/summary.txt b/basis/xml/syntax/summary.txt similarity index 100% rename from basis/xml/dispatch/summary.txt rename to basis/xml/syntax/summary.txt diff --git a/basis/xml/syntax/syntax-docs.factor b/basis/xml/syntax/syntax-docs.factor new file mode 100644 index 0000000000..34473fecfc --- /dev/null +++ b/basis/xml/syntax/syntax-docs.factor @@ -0,0 +1,101 @@ +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: help.markup help.syntax xml.data present multiline ; +IN: xml.syntax + +ABOUT: "xml.syntax" + +ARTICLE: "xml.syntax" "Syntax extensions for XML" +"The " { $link "xml.syntax" } " vocabulary defines a number of new parsing words forXML processing." +{ $subsection { "xml.syntax" "tags" } } +{ $subsection { "xml.syntax" "literals" } } +{ $subsection POSTPONE: XML-NS: } ; + +ARTICLE: { "xml.syntax" "tags" } "Dispatch on XML tag names" +"There is a system, analogous to generic words, for processing XML. A word can dispatch off the name of the tag that is passed to it. To define such a word, use" +{ $subsection POSTPONE: TAGS: } +"and to define a new 'method' for this word, use" +{ $subsection POSTPONE: TAG: } ; + +HELP: TAGS: +{ $syntax "TAGS: word" } +{ $values { "word" "a new word to define" } } +{ $description "Creates a new word to which dispatches on XML tag names." } +{ $see-also POSTPONE: TAG: } ; + +HELP: TAG: +{ $syntax "TAG: tag word definition... ;" } +{ $values { "tag" "an XML tag name" } { "word" "an XML process" } } +{ $description "Defines a 'method' on a word created with " { $link POSTPONE: TAGS: } ". It determines what such a word should do for an argument that is has the given name." } +{ $examples { $code "TAGS: x ( tag -- )\nTAG: a x drop \"hi\" write ;" } } +{ $see-also POSTPONE: TAGS: } ; + +ARTICLE: { "xml.syntax" "literals" } "XML literals" +"The following words provide syntax for XML literals:" +{ $subsection POSTPONE: ... XML>" } +{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML document (" { $link xml } ") on the stack. It can be used for interpolation as well, if interpolation slots are used. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ; + +HELP: [XML +{ $syntax "[XML foo ... bar ... baz XML]" } +{ $description "This gives syntax for literal XML documents. When evaluated, there is an XML chunk (" { $link xml-chunk } ") on the stack. For more information about XML interpolation, see " { $link { "xml.syntax" "interpolation" } } "." } ; + +ARTICLE: { "xml.syntax" "interpolation" } "XML interpolation syntax" +"XML interpolation has two forms for each of the words " { $link POSTPONE: " } ". To splice something in from the stack, in the style of " { $vocab-link "fry" } ", use the syntax " { $snippet "<->" } ". An XML interpolation form may only use one of these styles." +$nl +"These forms can be used where a tag might go, as in " { $snippet "[XML <-> XML]" } " or where an attribute might go, as in " { $snippet "[XML /> XML]" } ". When an attribute is spliced in, it is not included if the value is " { $snippet "f" } " and if the value is not a string, the value is put through " { $link present } ". Here is an example of the fry style of XML interpolation:" +{ $example +{" USING: splitting sequences xml.writer xml.syntax ; +"one two three" " " split +[ [XML <-> XML] ] map +<-> XML> pprint-xml"} +{" + + + one + + + two + + + three + +"} } +"Here is an example of the locals version:" +{ $example +{" USING: locals urls xml.syntax xml.writer ; +[let | + number [ 3 ] + false [ f ] + url [ URL" http://factorcode.org/" ] + string [ "hello" ] + word [ \ drop ] | + + false=<-false-> + url=<-url-> + string=<-string-> + word=<-word-> /> + XML> pprint-xml ] "} +{" +"} } +"XML interpolation can also be used, in conjunction with " { $vocab-link "inverse" } " in pattern matching. For example:" +{ $example {" USING: sequences xml.syntax inverse ; +: dispatch ( xml -- string ) + { + { [ [XML <-> XML] ] [ "a" prepend ] } + { [ [XML <-> XML] ] [ "b" prepend ] } + { [ [XML XML] ] [ "yes" ] } + { [ [XML /> XML] ] [ "no" prepend ] } + } switch ; +[XML pple XML] dispatch write "} "apple" } ; + +HELP: XML-NS: +{ $syntax "XML-NS: name http://url" } +{ $description "Defines a new word of the given name which constructs XML names in the namespace of the given URL. The names constructed are memoized." } ; diff --git a/basis/xml/syntax/syntax-tests.factor b/basis/xml/syntax/syntax-tests.factor new file mode 100644 index 0000000000..10ab961ec0 --- /dev/null +++ b/basis/xml/syntax/syntax-tests.factor @@ -0,0 +1,138 @@ +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: xml io kernel math sequences strings xml.traversal +tools.test math.parser xml.syntax xml.data xml.syntax.private +accessors multiline locals inverse xml.writer splitting classes ; +IN: xml.syntax.tests + +! TAGS test + +TAGS: calculate ( tag -- n ) + +: calc-2children ( tag -- n n ) + children-tags first2 [ calculate ] dip calculate ; + +TAG: number calculate + children>string string>number ; +TAG: add calculate + calc-2children + ; +TAG: minus calculate + calc-2children - ; +TAG: times calculate + calc-2children * ; +TAG: divide calculate + calc-2children / ; +TAG: neg calculate + children-tags first calculate neg ; + +: calc-arith ( string -- n ) + string>xml first-child-tag calculate ; + +[ 32 ] [ + "13-8" + calc-arith +] unit-test + +\ calc-arith must-infer + +XML-NS: foo http://blah.com + +[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test + +! XML literals + +[ "a" "c" { "a" "c" f } ] [ + "<-a->/><->" + string>doc + [ second var>> ] + [ fourth "val" attr var>> ] + [ extract-variables ] tri +] unit-test + +[ {" + + one + + y + +"} ] [ + [let* | a [ "one" ] c [ "two" ] x [ "y" ] + d [ [XML <-x-> XML] ] | + <-a-> /> <-d-> + XML> pprint-xml>string + ] +] unit-test + +[ {" + + + one + + + two + + + three + +"} ] [ + "one two three" " " split + [ [XML <-> XML] ] map + <-> XML> pprint-xml>string +] unit-test + +[ {" +"} ] +[ 3 f "http://factorcode.org/" "hello" \ drop + false=<-> url=<-> string=<-> word=<->/> XML> + pprint-xml>string ] unit-test + +[ "3" ] [ 3 [XML <-> XML] xml>string ] unit-test +[ "" ] [ f [XML <-> XML] xml>string ] unit-test + +\ XML] ] must-infer +[ [XML <-> /> XML] ] must-infer + +[ xml-chunk ] [ [ [XML XML] ] first class ] unit-test +[ xml ] [ [ XML> ] first class ] unit-test +[ xml-chunk ] [ [ [XML /> XML] ] third class ] unit-test +[ xml ] [ [ /> XML> ] third class ] unit-test +[ 1 ] [ [ [XML XML] ] length ] unit-test +[ 1 ] [ [ XML> ] length ] unit-test + +[ "" ] [ [XML XML] concat ] unit-test + +USE: inverse + +[ "foo" ] [ [XML foo XML] [ [XML <-> XML] ] undo ] unit-test +[ "foo" ] [ [XML XML] [ [XML /> XML] ] undo ] unit-test +[ "foo" "baz" ] [ [XML baz XML] [ [XML ><-> XML] ] undo ] unit-test + +: dispatch ( xml -- string ) + { + { [ [XML <-> XML] ] [ "a" prepend ] } + { [ [XML <-> XML] ] [ "b" prepend ] } + { [ [XML XML] ] [ "byes" ] } + { [ [XML /> XML] ] [ "bno" prepend ] } + } switch ; + +[ "apple" ] [ [XML pple XML] dispatch ] unit-test +[ "banana" ] [ [XML anana XML] dispatch ] unit-test +[ "byes" ] [ [XML XML] dispatch ] unit-test +[ "bnowhere" ] [ [XML XML] dispatch ] unit-test +[ "baboon" ] [ [XML aboon XML] dispatch ] unit-test +[ "apple" ] [ pple XML> dispatch ] unit-test +[ "apple" ] [ pple XML> body>> dispatch ] unit-test + +: dispatch-doc ( xml -- string ) + { + { [ <-> XML> ] [ "a" prepend ] } + { [ <-> XML> ] [ "b" prepend ] } + { [ XML> ] [ "byes" ] } + { [ /> XML> ] [ "bno" prepend ] } + } switch ; + +[ "apple" ] [ pple XML> dispatch-doc ] unit-test +[ "apple" ] [ [XML pple XML] dispatch-doc ] unit-test +[ "apple" ] [ pple XML> body>> dispatch-doc ] unit-test diff --git a/basis/xml/syntax/syntax.factor b/basis/xml/syntax/syntax.factor new file mode 100644 index 0000000000..8e6bebfe6b --- /dev/null +++ b/basis/xml/syntax/syntax.factor @@ -0,0 +1,243 @@ +! Copyright (C) 2005, 2009 Daniel Ehrenberg +! See http://factorcode.org/license.txt for BSD license. +USING: words assocs kernel accessors parser sequences summary +lexer splitting combinators locals xml.data memoize sequences.deep +xml.data xml.state xml namespaces present arrays generalizations strings +make math macros multiline inverse combinators.short-circuit +sorting fry unicode.categories ; +IN: xml.syntax + +alist swap '[ _ no-tag boa throw ] suffix + '[ dup main>> _ case ] ; + +: define-tags ( word -- ) + dup dup "xtable" word-prop compile-tags define ; + +:: define-tag ( string word quot -- ) + quot string word "xtable" word-prop set-at + word define-tags ; + +PRIVATE> + +: TAGS: + CREATE + [ H{ } clone "xtable" set-word-prop ] + [ define-tags ] bi ; parsing + +: TAG: + scan scan-word parse-definition define-tag ; parsing + +: XML-NS: + CREATE-WORD (( string -- name )) over set-stack-effect + scan '[ f swap _ ] define-memoized ; parsing + +> ] dip each-attrs ] } + { [ over attrs? ] [ each-attrs ] } + { [ over xml? ] [ [ body>> ] dip (each-interpolated) ] } + [ 2drop ] + } cond ; inline recursive + +: each-interpolated ( xml quot -- ) + '[ _ (each-interpolated) ] deep-each ; inline + +: has-interpolated? ( xml -- ? ) + ! If this becomes a performance problem, it can be improved + f swap [ 2drop t ] each-interpolated ; + +: when-interpolated ( xml quot -- genquot ) + [ dup has-interpolated? ] dip [ '[ _ swap ] ] if ; inline + +: string>chunk ( string -- chunk ) + t interpolating? [ string>xml-chunk ] with-variable ; + +: string>doc ( string -- xml ) + t interpolating? [ string>xml ] with-variable ; + +DEFER: interpolate-sequence + +: get-interpolated ( interpolated -- quot ) + var>> '[ [ _ swap at ] keep ] ; + +: ?present ( object -- string ) + dup [ present ] when ; + +: interpolate-attr ( key value -- quot ) + dup interpolated? + [ get-interpolated '[ _ swap @ [ ?present 2array ] dip ] ] + [ 2array '[ _ swap ] ] if ; + +: filter-nulls ( assoc -- newassoc ) + [ nip ] assoc-filter ; + +: interpolate-attrs ( attrs -- quot ) + [ + [ [ interpolate-attr ] { } assoc>map [ ] join ] + [ assoc-size ] bi + '[ @ _ swap [ narray filter-nulls ] dip ] + ] when-interpolated ; + +: interpolate-tag ( tag -- quot ) + [ + [ name>> ] + [ attrs>> interpolate-attrs ] + [ children>> interpolate-sequence ] tri + '[ _ swap @ @ [ ] dip ] + ] when-interpolated ; + +GENERIC: push-item ( item -- ) +M: string push-item , ; +M: xml-data push-item , ; +M: object push-item present , ; +M: sequence push-item + dup xml-data? [ , ] [ [ push-item ] each ] if ; +M: number push-item present , ; +M: xml-chunk push-item % ; + +: concat-interpolate ( array -- newarray ) + [ [ push-item ] each ] { } make ; + +GENERIC: interpolate-item ( item -- quot ) +M: object interpolate-item [ swap ] curry ; +M: tag interpolate-item interpolate-tag ; +M: interpolated interpolate-item get-interpolated ; + +: interpolate-sequence ( seq -- quot ) + [ + [ [ interpolate-item ] map concat ] + [ length ] bi + '[ @ _ swap [ narray concat-interpolate ] dip ] + ] when-interpolated ; + +GENERIC: [interpolate-xml] ( xml -- quot ) + +M: xml [interpolate-xml] + dup body>> interpolate-tag + '[ _ (clone) swap @ drop >>body ] ; + +M: xml-chunk [interpolate-xml] + interpolate-sequence + '[ @ drop ] ; + +MACRO: interpolate-xml ( xml -- quot ) + [interpolate-xml] ; + +: number<-> ( doc -- dup ) + 0 over [ + dup var>> [ + over >>var [ 1+ ] dip + ] unless drop + ] each-interpolated drop ; + +: >search-hash ( seq -- hash ) + [ dup search ] H{ } map>assoc ; + +: extract-variables ( xml -- seq ) + [ [ var>> , ] each-interpolated ] { } make ; + +: nenum ( ... n -- assoc ) + narray ; inline + +: collect ( accum variables -- accum ? ) + { + { [ dup empty? ] [ drop f ] } ! Just a literal + { [ dup [ ] all? ] [ >search-hash parsed t ] } ! locals + { [ dup [ not ] all? ] [ length parsed \ nenum parsed t ] } ! fry + [ drop "XML interpolation contains both fry and locals" throw ] ! mixed + } cond ; + +: parse-def ( accum delimiter quot -- accum ) + [ parse-multiline-string [ blank? ] trim ] dip call + [ extract-variables collect ] keep swap + [ number<-> parsed ] dip + [ \ interpolate-xml parsed ] when ; inline + +PRIVATE> + +: " [ string>doc ] parse-def ; parsing + +: [XML + "XML]" [ string>chunk ] parse-def ; parsing + +: remove-blanks ( seq -- newseq ) + [ { [ string? not ] [ [ blank? ] all? not ] } 1|| ] filter ; + +GENERIC: >xml ( xml -- tag ) +M: xml >xml body>> ; +M: tag >xml ; +M: xml-chunk >xml + remove-blanks + [ length 1 =/fail ] + [ first dup tag? [ fail ] unless ] bi ; +M: object >xml fail ; + +: 1chunk ( object -- xml-chunk ) + 1array ; + +GENERIC: >xml-chunk ( xml -- chunk ) +M: xml >xml-chunk body>> 1chunk ; +M: xml-chunk >xml-chunk ; +M: object >xml-chunk 1chunk ; + +GENERIC: [undo-xml] ( xml -- quot ) + +M: xml [undo-xml] + body>> [undo-xml] '[ >xml @ ] ; + +M: xml-chunk [undo-xml] + seq>> [undo-xml] '[ >xml-chunk @ ] ; + +: undo-attrs ( attrs -- quot: ( attrs -- ) ) + [ + [ main>> ] dip dup interpolated? + [ var>> '[ _ attr _ set ] ] + [ '[ _ attr _ =/fail ] ] if + ] { } assoc>map '[ _ cleave ] ; + +M: tag [undo-xml] ( tag -- quot: ( tag -- ) ) + { + [ name>> main>> '[ name>> main>> _ =/fail ] ] + [ attrs>> undo-attrs ] + [ children>> [undo-xml] '[ children>> @ ] ] + } cleave '[ _ _ _ tri ] ; + +: firstn-strong ( seq n -- ... ) + [ swap length =/fail ] + [ firstn ] 2bi ; inline + +M: sequence [undo-xml] ( sequence -- quot: ( seq -- ) ) + remove-blanks [ length ] [ [ [undo-xml] ] { } map-as ] bi + '[ remove-blanks _ firstn-strong _ spread ] ; + +M: string [undo-xml] ( string -- quot: ( string -- ) ) + '[ _ =/fail ] ; + +M: xml-data [undo-xml] ( datum -- quot: ( datum -- ) ) + '[ _ =/fail ] ; + +M: interpolated [undo-xml] + var>> '[ _ set ] ; + +: >enum ( assoc -- enum ) + ! Assumes keys are 0..n + >alist sort-keys values ; + +: undo-xml ( xml -- quot ) + [undo-xml] '[ H{ } clone [ _ bind ] keep >enum ] ; + +\ interpolate-xml 1 [ undo-xml ] define-pop-inverse diff --git a/basis/xml/dispatch/tags.txt b/basis/xml/syntax/tags.txt similarity index 100% rename from basis/xml/dispatch/tags.txt rename to basis/xml/syntax/tags.txt diff --git a/basis/xml/tests/encodings.factor b/basis/xml/tests/encodings.factor index 35076d2930..aec3e40a52 100644 --- a/basis/xml/tests/encodings.factor +++ b/basis/xml/tests/encodings.factor @@ -1,4 +1,4 @@ -USING: xml xml.data xml.utilities tools.test accessors kernel +USING: xml xml.data xml.traversal tools.test accessors kernel io.encodings.8-bit ; [ "\u000131" ] [ "resource:basis/xml/tests/latin5.xml" file>xml children>string ] unit-test diff --git a/basis/xml/tests/soap.factor b/basis/xml/tests/soap.factor index d2568a24e1..3d1ac2379e 100644 --- a/basis/xml/tests/soap.factor +++ b/basis/xml/tests/soap.factor @@ -1,4 +1,4 @@ -USING: sequences xml kernel arrays xml.utilities io.files tools.test ; +USING: sequences xml kernel arrays xml.traversal io.files tools.test ; IN: xml.tests : assemble-data ( tag -- 3array ) diff --git a/basis/xml/tests/templating.factor b/basis/xml/tests/templating.factor index 618e785d05..4861f86d7b 100644 --- a/basis/xml/tests/templating.factor +++ b/basis/xml/tests/templating.factor @@ -1,5 +1,5 @@ USING: kernel xml sequences assocs tools.test io arrays namespaces fry -accessors xml.data xml.utilities xml.writer generic sequences.deep multiline ; +accessors xml.data xml.traversal xml.writer generic sequences.deep multiline ; IN: xml.tests : sub-tag diff --git a/basis/xml/tests/test.factor b/basis/xml/tests/test.factor index 337c19bfe1..b1f6cf002f 100644 --- a/basis/xml/tests/test.factor +++ b/basis/xml/tests/test.factor @@ -3,7 +3,7 @@ IN: xml.tests USING: kernel xml tools.test io namespaces make sequences xml.errors xml.entities.html parser strings xml.data io.files -xml.utilities continuations assocs +xml.traversal continuations assocs sequences.deep accessors io.streams.string ; ! This is insufficient @@ -67,3 +67,4 @@ SYMBOL: xml-file [ "x" "<" ] [ "" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test [ "foo" ] [ "]>&bar;" string>xml children>string ] unit-test [ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test +[ "1.1" ] [ "" string>xml prolog>> version>> ] unit-test diff --git a/basis/xml/tests/xmltest.factor b/basis/xml/tests/xmltest.factor index a8024ce151..80472fc788 100644 --- a/basis/xml/tests/xmltest.factor +++ b/basis/xml/tests/xmltest.factor @@ -1,6 +1,6 @@ USING: accessors assocs combinators continuations fry generalizations io.pathnames kernel macros sequences stack-checker tools.test xml -xml.utilities xml.writer arrays xml.data ; +xml.traversal xml.writer arrays xml.data ; IN: xml.tests.suite TUPLE: xml-test id uri sections description type ; diff --git a/basis/xml/utilities/authors.txt b/basis/xml/traversal/authors.txt similarity index 100% rename from basis/xml/utilities/authors.txt rename to basis/xml/traversal/authors.txt diff --git a/basis/xml/traversal/summary.txt b/basis/xml/traversal/summary.txt new file mode 100644 index 0000000000..365ec87864 --- /dev/null +++ b/basis/xml/traversal/summary.txt @@ -0,0 +1 @@ +Utilities for traversing an XML DOM tree diff --git a/basis/xml/utilities/tags.txt b/basis/xml/traversal/tags.txt similarity index 100% rename from basis/xml/utilities/tags.txt rename to basis/xml/traversal/tags.txt diff --git a/basis/xml/utilities/utilities-docs.factor b/basis/xml/traversal/traversal-docs.factor similarity index 91% rename from basis/xml/utilities/utilities-docs.factor rename to basis/xml/traversal/traversal-docs.factor index 161ca824c3..1329c4975e 100644 --- a/basis/xml/utilities/utilities-docs.factor +++ b/basis/xml/traversal/traversal-docs.factor @@ -1,12 +1,12 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: help.markup help.syntax xml.data sequences strings ; -IN: xml.utilities +IN: xml.traversal -ABOUT: "xml.utilities" +ABOUT: "xml.traversal" -ARTICLE: "xml.utilities" "Utilities for processing XML" - "Getting parts of an XML document or tag:" +ARTICLE: "xml.traversal" "Utilities for traversing XML" + "The " { $vocab-link "xml.traversal" } " vocabulary provides utilities for traversing an XML DOM tree and viewing the contents of a single tag. The following words are defined:" $nl "Note: the difference between deep-tag-named and tag-named is that the former searches recursively among all children and children of children of the tag, while the latter only looks at the direct children, and is therefore more efficient." { $subsection tag-named } diff --git a/basis/xml/utilities/utilities-tests.factor b/basis/xml/traversal/traversal-tests.factor similarity index 73% rename from basis/xml/utilities/utilities-tests.factor rename to basis/xml/traversal/traversal-tests.factor index 673bf47f6e..165ca34adf 100644 --- a/basis/xml/utilities/utilities-tests.factor +++ b/basis/xml/traversal/traversal-tests.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: xml xml.utilities tools.test xml.data sequences ; -IN: xml.utilities.tests +USING: xml xml.traversal tools.test xml.data sequences ; +IN: xml.traversal.tests [ "bar" ] [ "bar" string>xml children>string ] unit-test @@ -9,14 +9,10 @@ IN: xml.utilities.tests [ "" ] [ "" string>xml children>string ] unit-test -XML-NS: foo http://blah.com - -[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test - [ "blah" ] [ "" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test [ { "blah" } ] [ "" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test [ "blah" ] [ "" string>xml "foo" deep-tag-named "attr" attr ] unit-test -[ { "blah" } ] [ "" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test \ No newline at end of file +[ { "blah" } ] [ "" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test diff --git a/basis/xml/utilities/utilities.factor b/basis/xml/traversal/traversal.factor similarity index 86% rename from basis/xml/utilities/utilities.factor rename to basis/xml/traversal/traversal.factor index 1249da8c36..b337ea1472 100755 --- a/basis/xml/utilities/utilities.factor +++ b/basis/xml/traversal/traversal.factor @@ -3,7 +3,7 @@ USING: accessors kernel namespaces sequences words io assocs quotations strings parser lexer arrays xml.data xml.writer debugger splitting vectors sequences.deep combinators fry memoize ; -IN: xml.utilities +IN: xml.traversal : children>string ( tag -- string ) children>> { @@ -66,14 +66,3 @@ PRIVATE> : assert-tag ( name name -- ) names-match? [ "Unexpected XML tag found" throw ] unless ; - -: insert-children ( children tag -- ) - dup children>> [ push-all ] - [ swap V{ } like >>children drop ] if ; - -: insert-child ( child tag -- ) - [ 1vector ] dip insert-children ; - -: XML-NS: - CREATE-WORD (( string -- name )) over set-stack-effect - scan '[ f swap _ ] define-memoized ; parsing diff --git a/basis/xml/utilities/summary.txt b/basis/xml/utilities/summary.txt deleted file mode 100644 index a671132945..0000000000 --- a/basis/xml/utilities/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Utilities for manipulating an XML DOM tree diff --git a/basis/xml/writer/writer-docs.factor b/basis/xml/writer/writer-docs.factor index cc45528cec..9971abcdf1 100644 --- a/basis/xml/writer/writer-docs.factor +++ b/basis/xml/writer/writer-docs.factor @@ -41,7 +41,7 @@ HELP: pprint-xml HELP: indenter { $var-description "Contains the string which is used for indenting in the XML prettyprinter. For example, to print an XML document using " { $snippet "%%%%" } " for indentation, you can use the following:" } -{ $example {" USING: xml.literals xml.writer namespaces ; +{ $example {" USING: xml.syntax xml.writer namespaces ; [XML bar XML] "%%%%" indenter [ pprint-xml ] with-variable "} {" %%%%bar @@ -49,7 +49,7 @@ HELP: indenter HELP: sensitive-tags { $var-description "Contains a sequence of " { $link name } "s where whitespace should be considered significant for prettyprinting purposes. The sequence can contain " { $link string } "s in place of names. For example, to preserve whitespace inside a " { $snippet "pre" } " tag:" } -{ $example {" USING: xml.literals xml.writer namespaces ; +{ $example {" USING: xml.syntax xml.writer namespaces ; [XML something
bing
 bang
    bong
XML] { "pre" } sensitive-tags [ pprint-xml ] with-variable "} {" diff --git a/basis/xml/writer/writer-tests.factor b/basis/xml/writer/writer-tests.factor index d09ae08b3f..23fb7a5074 100644 --- a/basis/xml/writer/writer-tests.factor +++ b/basis/xml/writer/writer-tests.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2009 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. USING: xml.data xml.writer tools.test fry xml kernel multiline -xml.writer.private io.streams.string xml.utilities sequences ; +xml.writer.private io.streams.string xml.traversal sequences +io.encodings.utf8 io.files accessors io.directories ; IN: xml.writer.tests \ write-xml must-infer @@ -59,3 +60,9 @@ IN: xml.writer.tests [ "\n\n bar\n" ] [ " bar " string>xml pprint-xml>string ] unit-test [ "" ] [ "" xml>string ] unit-test + +: test-file "resource:basis/xml/writer/test.xml" ; + +[ ] [ "" string>xml test-file utf8 [ write-xml ] with-file-writer ] unit-test +[ "x" ] [ test-file file>xml body>> name>> main>> ] unit-test +[ ] [ test-file delete-file ] unit-test diff --git a/basis/xml/writer/writer.factor b/basis/xml/writer/writer.factor index a713790973..4f5bad1aa5 100755 --- a/basis/xml/writer/writer.factor +++ b/basis/xml/writer/writer.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: hashtables kernel math namespaces sequences strings assocs combinators io io.streams.string accessors -xml.data wrap xml.entities unicode.categories fry ; +xml.data wrap.strings xml.entities unicode.categories fry ; IN: xml.writer SYMBOL: sensitive-tags @@ -164,7 +164,7 @@ M: sequence write-xml M: prolog write-xml "> write-quoted ] - [ " encoding=" write encoding>> write-quoted ] + [ drop " encoding=\"UTF-8\"" write ] [ standalone>> [ " standalone=\"yes\"" write ] when ] tri "?>" write ; diff --git a/basis/xml/xml-docs.factor b/basis/xml/xml-docs.factor index 901fce2dd4..024b086ef9 100644 --- a/basis/xml/xml-docs.factor +++ b/basis/xml/xml-docs.factor @@ -93,7 +93,7 @@ ARTICLE: "xml" "XML parser" { $vocab-subsection "XML parsing errors" "xml.errors" } { $vocab-subsection "XML entities" "xml.entities" } { $vocab-subsection "XML data types" "xml.data" } - { $vocab-subsection "Utilities for processing XML" "xml.utilities" } - { $vocab-subsection "Dispatch on XML tag names" "xml.dispatch" } ; + { $vocab-subsection "Utilities for traversing XML" "xml.traversal" } + { $vocab-subsection "Syntax extensions for XML" "xml.syntax" } ; ABOUT: "xml" diff --git a/basis/xml/xml.factor b/basis/xml/xml.factor index 5ca486a57f..57c1b6dbd3 100755 --- a/basis/xml/xml.factor +++ b/basis/xml/xml.factor @@ -4,7 +4,7 @@ USING: accessors arrays io io.encodings.binary io.files 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 ; +combinators.short-circuit xml.name splitting ; IN: xml ; + dup [ tag? ] find [ + assure-tags cut + [ cut-prolog ] [ rest ] bi* + no-pre/post no-post-tags + ] dip swap ; ! * Views of XML diff --git a/basis/xmode/code2html/code2html.factor b/basis/xmode/code2html/code2html.factor index 2f35cd6d76..3fb5a532c9 100644 --- a/basis/xmode/code2html/code2html.factor +++ b/basis/xmode/code2html/code2html.factor @@ -1,6 +1,6 @@ USING: xmode.tokens xmode.marker xmode.catalog kernel locals io io.files sequences words io.encodings.utf8 -namespaces xml.entities accessors xml.literals locals xml.writer ; +namespaces xml.entities accessors xml.syntax locals xml.writer ; IN: xmode.code2html : htmlize-tokens ( tokens -- xml ) diff --git a/basis/xmode/loader/loader.factor b/basis/xmode/loader/loader.factor index b661f4eb3f..70466913a0 100644 --- a/basis/xmode/loader/loader.factor +++ b/basis/xmode/loader/loader.factor @@ -1,5 +1,5 @@ USING: xmode.loader.syntax xmode.tokens xmode.rules -xmode.keyword-map xml.data xml.utilities xml assocs kernel +xmode.keyword-map xml.data xml.traversal xml assocs kernel combinators sequences math.parser namespaces parser xmode.utilities parser-combinators.regexp io.files accessors ; IN: xmode.loader diff --git a/basis/xmode/loader/syntax/syntax.factor b/basis/xmode/loader/syntax/syntax.factor index b546969a37..0e7293da97 100644 --- a/basis/xmode/loader/syntax/syntax.factor +++ b/basis/xmode/loader/syntax/syntax.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors xmode.tokens xmode.rules xmode.keyword-map -xml.data xml.utilities xml assocs kernel combinators sequences +xml.data xml.traversal xml assocs kernel combinators sequences math.parser namespaces make parser lexer xmode.utilities parser-combinators.regexp io.files splitting arrays ; IN: xmode.loader.syntax diff --git a/basis/xmode/utilities/utilities.factor b/basis/xmode/utilities/utilities.factor index d6407d8180..2423fb0d86 100644 --- a/basis/xmode/utilities/utilities.factor +++ b/basis/xmode/utilities/utilities.factor @@ -1,5 +1,5 @@ USING: accessors sequences assocs kernel quotations namespaces -xml.data xml.utilities combinators macros parser lexer words fry ; +xml.data xml.traversal combinators macros parser lexer words fry ; IN: xmode.utilities : implies ( x y -- z ) [ not ] dip or ; inline diff --git a/extra/graphics/bitmap/authors.txt b/basis/zlib/authors.txt similarity index 100% rename from extra/graphics/bitmap/authors.txt rename to basis/zlib/authors.txt diff --git a/extra/graphics/viewer/authors.txt b/basis/zlib/ffi/authors.txt similarity index 100% rename from extra/graphics/viewer/authors.txt rename to basis/zlib/ffi/authors.txt diff --git a/basis/zlib/ffi/ffi.factor b/basis/zlib/ffi/ffi.factor new file mode 100755 index 0000000000..bda2809f56 --- /dev/null +++ b/basis/zlib/ffi/ffi.factor @@ -0,0 +1,30 @@ +! 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 ) ; diff --git a/basis/zlib/zlib-tests.factor b/basis/zlib/zlib-tests.factor new file mode 100755 index 0000000000..0ac77277dc --- /dev/null +++ b/basis/zlib/zlib-tests.factor @@ -0,0 +1,9 @@ +! 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 diff --git a/basis/zlib/zlib.factor b/basis/zlib/zlib.factor new file mode 100755 index 0000000000..b40d9c2a98 --- /dev/null +++ b/basis/zlib/zlib.factor @@ -0,0 +1,48 @@ +! 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 ; + +: ( 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 dup length ] keep [ + dup length zlib.ffi:compress zlib-error + ] 3keep drop *ulong head + ] keep length ; + +: uncompress ( compressed -- byte-array ) + [ + length>> [ ] keep 2dup + ] [ + data>> dup length + zlib.ffi:uncompress zlib-error + ] bi *ulong head ; diff --git a/build-support/factor.sh b/build-support/factor.sh index 36d52601a5..3517d8f4ba 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -295,9 +295,6 @@ set_build_info() { elif [[ $OS == winnt && $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=winnt-x86.64 MAKE_TARGET=winnt-x86-64 - elif [[ $OS == winnt && $ARCH == x86 && $WORD == 32 ]] ; then - MAKE_IMAGE_TARGET=winnt-x86.32 - MAKE_TARGET=winnt-x86-32 elif [[ $ARCH == x86 && $WORD == 64 ]] ; then MAKE_IMAGE_TARGET=unix-x86.64 MAKE_TARGET=$OS-x86-64 diff --git a/core/alien/alien.factor b/core/alien/alien.factor index c97e36e889..52e9cd0f30 100644 --- a/core/alien/alien.factor +++ b/core/alien/alien.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2008 Slava Pestov. +! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs kernel math namespaces sequences system kernel.private byte-arrays arrays init ; @@ -18,6 +18,14 @@ PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ; UNION: pinned-c-ptr pinned-alien POSTPONE: f ; +GENERIC: >c-ptr ( obj -- c-ptr ) + +M: c-ptr >c-ptr ; + +SLOT: underlying + +M: object >c-ptr underlying>> ; + GENERIC: expired? ( c-ptr -- ? ) flushable M: alien expired? expired>> ; @@ -43,7 +51,7 @@ M: alien equal? SYMBOL: libraries -libraries global [ H{ } assoc-like ] change-at +libraries [ H{ } clone ] initialize TUPLE: library path abi dll ; diff --git a/core/combinators/combinators-tests.factor b/core/combinators/combinators-tests.factor index 1a73e22e31..beb50f1162 100644 --- a/core/combinators/combinators-tests.factor +++ b/core/combinators/combinators-tests.factor @@ -323,4 +323,18 @@ DEFER: corner-case-1 [ 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 diff --git a/core/combinators/combinators.factor b/core/combinators/combinators.factor index e356a6d246..daf247d678 100755 --- a/core/combinators/combinators.factor +++ b/core/combinators/combinators.factor @@ -49,7 +49,7 @@ ERROR: no-cond ; reverse [ no-cond ] swap alist>quot ; ! case -ERROR: no-case ; +ERROR: no-case object ; : case-find ( obj assoc -- obj' ) [ @@ -66,7 +66,7 @@ ERROR: no-case ; 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 ) diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 999b783c48..ac3e99e24c 100644 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -178,6 +178,4 @@ SYMBOL: remake-generics-hook : default-recompile-hook ( words -- alist ) [ f ] { } map>assoc ; -recompile-hook global -[ [ default-recompile-hook ] or ] -change-at +recompile-hook [ [ default-recompile-hook ] ] initialize diff --git a/core/io/backend/backend.factor b/core/io/backend/backend.factor index fd5567cfa2..2f0bb1063f 100644 --- a/core/io/backend/backend.factor +++ b/core/io/backend/backend.factor @@ -8,7 +8,7 @@ SYMBOL: io-backend SINGLETON: c-io-backend -io-backend global [ c-io-backend or ] change-at +io-backend [ c-io-backend ] initialize HOOK: init-io io-backend ( -- ) diff --git a/core/io/files/files-tests.factor b/core/io/files/files-tests.factor index f9702fd133..152d1bb85d 100644 --- a/core/io/files/files-tests.factor +++ b/core/io/files/files-tests.factor @@ -1,8 +1,7 @@ -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 @@ -75,3 +74,73 @@ USE: debugger.threads [ 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 diff --git a/core/io/io-docs.factor b/core/io/io-docs.factor index d7534ddb50..5d8aa6a88f 100644 --- a/core/io/io-docs.factor +++ b/core/io/io-docs.factor @@ -68,6 +68,51 @@ HELP: stream-copy { $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* } "." } ; @@ -196,6 +241,8 @@ $nl { $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" } ; @@ -249,6 +296,8 @@ $nl { $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* } @@ -256,7 +305,7 @@ $nl { $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 } @@ -265,6 +314,8 @@ $nl { $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* } diff --git a/core/io/io-tests.factor b/core/io/io-tests.factor index 009ba3a9e7..cf6b935215 100644 --- a/core/io/io-tests.factor +++ b/core/io/io-tests.factor @@ -1,6 +1,4 @@ -USING: arrays io io.files kernel math parser strings system -tools.test words namespaces make io.encodings.8-bit -io.encodings.binary sequences ; +USING: io parser tools.test words ; IN: io.tests [ f ] [ diff --git a/core/io/io.factor b/core/io/io.factor index 55cc336ef8..11a2a6d1a8 100644 --- a/core/io/io.factor +++ b/core/io/io.factor @@ -15,6 +15,10 @@ GENERIC: stream-write ( seq stream -- ) GENERIC: stream-flush ( stream -- ) GENERIC: stream-nl ( stream -- ) +ERROR: bad-seek-type type ; +SINGLETONS: seek-absolute seek-relative seek-end ; +GENERIC: stream-seek ( n seek-type stream -- ) + : stream-print ( str stream -- ) [ stream-write ] keep stream-nl ; ! Default streams @@ -27,6 +31,8 @@ SYMBOL: error-stream : read ( n -- seq ) input-stream get stream-read ; : read-until ( seps -- seq sep/f ) input-stream get stream-read-until ; : read-partial ( n -- seq ) input-stream get stream-read-partial ; +: seek-input ( n seek-type -- ) input-stream get stream-seek ; +: seek-output ( n seek-type -- ) output-stream get stream-seek ; : write1 ( elt -- ) output-stream get stream-write1 ; : write ( seq -- ) output-stream get stream-write ; @@ -82,4 +88,4 @@ PRIVATE> : stream-copy ( in out -- ) [ [ [ write ] each-block ] with-output-stream ] - curry with-input-stream ; \ No newline at end of file + curry with-input-stream ; diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index d85a51edff..b8191004db 100644 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -658,7 +658,7 @@ HELP: loop "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" } } ; @@ -949,6 +949,13 @@ ARTICLE: "assertions" "Assertions" { $subsection assert } { $subsection assert= } ; +ARTICLE: "dataflow-combinators" "Data flow combinators" +"Data flow combinators pass values between quotations:" +{ $subsection "slip-keep-combinators" } +{ $subsection "cleave-combinators" } +{ $subsection "spread-combinators" } +{ $subsection "apply-combinators" } ; + ARTICLE: "dataflow" "Data and control flow" { $subsection "evaluator" } { $subsection "words" } @@ -956,16 +963,9 @@ ARTICLE: "dataflow" "Data and control flow" { $subsection "booleans" } { $subsection "shuffle-words" } "A central concept in Factor is that of a " { $emphasis "combinator" } ", which is a word taking code as input." -$nl -"Data flow combinators:" -{ $subsection "slip-keep-combinators" } -{ $subsection "cleave-combinators" } -{ $subsection "spread-combinators" } -{ $subsection "apply-combinators" } -"Control flow combinators:" +{ $subsection "dataflow-combinators" } { $subsection "conditionals" } { $subsection "looping-combinators" } -"Additional combinators:" { $subsection "compositional-combinators" } { $subsection "combinators" } "More combinators are defined for working on data structures, such as " { $link "sequences-combinators" } " and " { $link "assocs-combinators" } "." @@ -973,6 +973,7 @@ $nl "Advanced topics:" { $subsection "assertions" } { $subsection "implementing-combinators" } +{ $subsection "macros" } { $subsection "errors" } { $subsection "continuations" } ; diff --git a/core/math/math-docs.factor b/core/math/math-docs.factor index 7d0666328f..94ff2c1f29 100644 --- a/core/math/math-docs.factor +++ b/core/math/math-docs.factor @@ -254,7 +254,7 @@ HELP: fp-infinity? { $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 diff --git a/core/namespaces/namespaces-docs.factor b/core/namespaces/namespaces-docs.factor index 1cc3d86e98..ff0542a7b8 100644 --- a/core/namespaces/namespaces-docs.factor +++ b/core/namespaces/namespaces-docs.factor @@ -1,6 +1,6 @@ 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" @@ -20,7 +20,8 @@ ARTICLE: "namespaces-global" "Global variables" { $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." @@ -159,3 +160,7 @@ HELP: ndrop 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." } ; diff --git a/core/namespaces/namespaces-tests.factor b/core/namespaces/namespaces-tests.factor index 4c11e2389f..616ddef7fc 100644 --- a/core/namespaces/namespaces-tests.factor +++ b/core/namespaces/namespaces-tests.factor @@ -12,3 +12,14 @@ H{ } clone "test-namespace" set [ 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 diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor index 36559095cb..24095fd382 100644 --- a/core/namespaces/namespaces.factor +++ b/core/namespaces/namespaces.factor @@ -37,4 +37,7 @@ PRIVATE> 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 ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 4be7cfa891..971ba245dd 100644 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -200,7 +200,7 @@ SYMBOL: interactive-vocabs SYMBOL: print-use-hook -print-use-hook global [ [ ] or ] change-at +print-use-hook [ [ ] ] initialize : parse-fresh ( lines -- quot ) [ diff --git a/core/slots/slots.factor b/core/slots/slots.factor old mode 100644 new mode 100755 index f166378d9d..24ff1b0f8b --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -151,6 +151,7 @@ M: class initial-value* no-initial-value ; { [ array bootstrap-word over class<= ] [ { } ] } { [ byte-array bootstrap-word over class<= ] [ B{ } ] } { [ simple-alien bootstrap-word over class<= ] [ ] } + { [ quotation bootstrap-word over class<= ] [ [ ] ] } [ dup initial-value* ] } cond nip ; diff --git a/core/strings/parser/parser.factor b/core/strings/parser/parser.factor index 4062e16e3d..8c9d0b5557 100644 --- a/core/strings/parser/parser.factor +++ b/core/strings/parser/parser.factor @@ -22,9 +22,9 @@ ERROR: bad-escape ; 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 [ diff --git a/core/strings/strings-docs.factor b/core/strings/strings-docs.factor index d40cd982d8..9a1671b126 100644 --- a/core/strings/strings-docs.factor +++ b/core/strings/strings-docs.factor @@ -53,8 +53,9 @@ HELP: 1string HELP: >string { $values { "seq" "a sequence of characters" } { "str" string } } -{ $description "Outputs a freshly-allocated string with the same elements as a given sequence." } -{ $errors "Throws an error if the sequence contains elements other than real numbers." } ; +{ $description "Outputs a freshly-allocated string with the same elements as a given sequence, by interpreting the sequence elements as Unicode code points." } +{ $notes "This operation is only appropriate if the underlying sequence holds Unicode code points, which is rare unless it is a " { $link slice } " of another string. To convert a sequence of bytes to a string, use the words documented in " { $link "io.encodings.string" } "." } +{ $errors "Throws an error if the sequence contains elements other than integers." } ; HELP: resize-string ( n str -- newstr ) { $values { "n" "a non-negative integer" } { "str" string } { "newstr" string } } diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index e08821bddd..035622454f 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -551,12 +551,12 @@ HELP: BIN: { $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 @@ -571,7 +571,7 @@ HELP: MATH: { $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 diff --git a/core/words/words-docs.factor b/core/words/words-docs.factor index 764df9924c..4dfa2d49bc 100644 --- a/core/words/words-docs.factor +++ b/core/words/words-docs.factor @@ -107,7 +107,7 @@ $nl { { { $snippet "\"help\"" } ", " { $snippet "\"help-loc\"" } ", " { $snippet "\"help-parent\"" } } { "Where word help is stored - " { $link "writing-help" } } } - { { $snippet "\"infer\"" } { $link "compiler-transforms" } } + { { $snippet "\"infer\"" } { $link "macros" } } { { { $snippet "\"inferred-effect\"" } } { $link "inference" } } diff --git a/core/words/words.factor b/core/words/words.factor index 3197d0a6f6..8648664031 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -96,11 +96,11 @@ M: word uses ( word -- seq ) 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 ] diff --git a/extra/24-game/24-game.factor b/extra/24-game/24-game.factor index 126215ab13..f842d5f4cb 100644 --- a/extra/24-game/24-game.factor +++ b/extra/24-game/24-game.factor @@ -15,7 +15,8 @@ SYMBOL: commands { nop rot -rot swap spin swapd } amb-execute ; : makes-24? ( a b c d -- ? ) [ - 2 [ some-rots do-something ] times + some-rots do-something + some-rots do-something maybe-swap do-something 24 = ] @@ -60,4 +61,4 @@ DEFER: check-status : 24-able ( -- vector ) build-quad dup 24-able? [ drop build-quad ] unless ; : set-commands ( -- ) { + - * / rot swap q } commands set ; : play-game ( -- ) set-commands 24-able repeat ; -MAIN: play-game \ No newline at end of file +MAIN: play-game diff --git a/extra/4DNav/space-file-decoder/space-file-decoder.factor b/extra/4DNav/space-file-decoder/space-file-decoder.factor index 872ddbcee3..e85830de52 100755 --- a/extra/4DNav/space-file-decoder/space-file-decoder.factor +++ b/extra/4DNav/space-file-decoder/space-file-decoder.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Jeff Bigot ! See http://factorcode.org/license.txt for BSD license. -USING: adsoda xml xml.utilities xml.dispatch accessors +USING: adsoda xml xml.traversal xml.syntax accessors combinators sequences math.parser kernel splitting values continuations ; IN: 4DNav.space-file-decoder @@ -8,7 +8,7 @@ IN: 4DNav.space-file-decoder : decode-number-array ( x -- y ) "," split [ string>number ] map ; -PROCESS: adsoda-read-model ( tag -- ) +TAGS: adsoda-read-model ( tag -- model ) TAG: dimension adsoda-read-model children>> first string>number ; @@ -56,11 +56,9 @@ TAG: space adsoda-read-model ; : read-model-file ( path -- x ) - dup - [ - [ file>xml "space" tags-named first adsoda-read-model ] - [ drop ] recover - ] [ drop ] if - + [ + [ file>xml "space" tag-named adsoda-read-model ] + [ 2drop ] recover + ] [ ] if* ; diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor index 716435775d..1f62441028 100644 --- a/extra/cap/cap.factor +++ b/extra/cap/cap.factor @@ -1,7 +1,7 @@ ! 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 @@ -27,4 +27,4 @@ IN: cap [ screenshot ] dip save-bitmap ; : screenshot. ( window -- ) - [ screenshot ] [ title>> ] bi open-window ; + [ screenshot ] [ title>> ] bi open-window ; diff --git a/extra/graphics/bitmap/bitmap.factor b/extra/graphics/bitmap/bitmap.factor deleted file mode 100755 index a0212e47de..0000000000 --- a/extra/graphics/bitmap/bitmap.factor +++ /dev/null @@ -1,165 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. - -USING: alien arrays byte-arrays combinators summary -graphics.viewer io io.binary io.files kernel libc math -math.functions math.bitwise namespaces opengl opengl.gl -prettyprint sequences strings ui ui.gadgets.panes fry -io.encodings.binary accessors grouping macros alien.c-types ; -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 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 [ 3 head-slice ] map ] - [ color-index>> >array ] bi [ swap nth ] with map concat ; - -: 4bit>array ( bitmap -- array ) - [ rgb-quads>> 4 [ 3 head-slice ] map ] - [ color-index>> >array ] bi [ swap nth ] with map concat ; - -: raw-bitmap>array ( bitmap -- array ) - dup bit-count>> - { - { 32 [ "32bit" throw ] } - { 24 [ color-index>> ] } - { 16 [ "16bit" throw ] } - { 8 [ 8bit>array ] } - { 4 [ 4bit>array ] } - { 2 [ "2bit" throw ] } - { 1 [ "1bit" throw ] } - } case >byte-array ; - -ERROR: bitmap-magic ; - -M: bitmap-magic summary - drop "First two bytes of bitmap stream must be 'BM'" ; - -: parse-file-header ( bitmap -- ) - 2 read >string dup "BM" = [ bitmap-magic ] unless >>magic - 4 read le> >>size - 4 read le> >>reserved - 4 read le> >>offset drop ; - -: parse-bitmap-header ( bitmap -- ) - 4 read le> >>header-length - 4 read signed-le> >>width - 4 read signed-le> >>height - 2 read le> >>planes - 2 read le> >>bit-count - 4 read le> >>compression - 4 read le> >>size-image - 4 read le> >>x-pels - 4 read le> >>y-pels - 4 read le> >>color-used - 4 read le> >>color-important drop ; - -: rgb-quads-length ( bitmap -- n ) - [ offset>> 14 - ] keep header-length>> - ; - -: color-index-length ( bitmap -- n ) - [ width>> ] keep [ planes>> * ] keep - [ bit-count>> * 31 + 32 /i 4 * ] keep - height>> abs * ; - -: parse-bitmap ( bitmap -- ) - dup rgb-quads-length read >>rgb-quads - dup color-index-length read >>color-index drop ; - -: load-bitmap ( path -- bitmap ) - binary [ - bitmap new - dup parse-file-header - dup parse-bitmap-header - dup parse-bitmap - ] with-file-reader - dup raw-bitmap>array >>array ; - -: save-bitmap ( bitmap path -- ) - binary [ - "BM" >byte-array write - dup array>> length 14 + 40 + 4 >le write - 0 4 >le write - 54 4 >le write - - 40 4 >le write - { - [ width>> 4 >le write ] - [ height>> 4 >le write ] - [ planes>> 1 or 2 >le write ] - [ bit-count>> 24 or 2 >le write ] - [ compression>> 0 or 4 >le write ] - [ size-image>> 4 >le write ] - [ x-pels>> 0 or 4 >le write ] - [ y-pels>> 0 or 4 >le write ] - [ color-used>> 0 or 4 >le write ] - [ color-important>> 0 or 4 >le write ] - [ rgb-quads>> write ] - [ color-index>> write ] - } cleave - ] with-file-writer ; - -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 gadget. ; - -: bitmap-window ( path -- gadget ) - load-bitmap [ "bitmap" open-window ] keep ; - -: test-bitmap24 ( -- ) - "resource:extra/graphics/bitmap/test-images/thiswayup24.bmp" bitmap. ; - -: test-bitmap8 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb8bit.bmp" bitmap. ; - -: test-bitmap4 ( -- ) - "resource:extra/graphics/bitmap/test-images/rgb4bit.bmp" bitmap. ; - -: test-bitmap1 ( -- ) - "resource:extra/graphics/bitmap/test-images/1bit.bmp" bitmap. ; - diff --git a/extra/graphics/viewer/viewer.factor b/extra/graphics/viewer/viewer.factor deleted file mode 100644 index 0533ffaf5d..0000000000 --- a/extra/graphics/viewer/viewer.factor +++ /dev/null @@ -1,21 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: arrays kernel math math.functions namespaces opengl -ui.gadgets ui.render accessors ; -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 ; - -: ( bitmap -- gadget ) - \ graphics-gadget new-gadget - swap >>image ; diff --git a/basis/html/elements/authors.txt b/extra/html/elements/authors.txt similarity index 100% rename from basis/html/elements/authors.txt rename to extra/html/elements/authors.txt diff --git a/basis/html/elements/elements-docs.factor b/extra/html/elements/elements-docs.factor similarity index 100% rename from basis/html/elements/elements-docs.factor rename to extra/html/elements/elements-docs.factor diff --git a/basis/html/elements/elements-tests.factor b/extra/html/elements/elements-tests.factor similarity index 100% rename from basis/html/elements/elements-tests.factor rename to extra/html/elements/elements-tests.factor diff --git a/basis/html/elements/elements.factor b/extra/html/elements/elements.factor similarity index 98% rename from basis/html/elements/elements.factor rename to extra/html/elements/elements.factor index e23d929d6d..85df4f7b27 100644 --- a/basis/html/elements/elements.factor +++ b/extra/html/elements/elements.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: io io.styles kernel namespaces prettyprint quotations sequences strings words xml.entities compiler.units effects -xml.data xml.literals urls math math.parser combinators +xml.data urls math math.parser combinators present fry io.streams.string xml.writer html ; IN: html.elements diff --git a/basis/html/elements/summary.txt b/extra/html/elements/summary.txt similarity index 100% rename from basis/html/elements/summary.txt rename to extra/html/elements/summary.txt diff --git a/basis/html/elements/tags.txt b/extra/html/elements/tags.txt similarity index 100% rename from basis/html/elements/tags.txt rename to extra/html/elements/tags.txt diff --git a/extra/id3/authors.txt b/extra/id3/authors.txt new file mode 100644 index 0000000000..ece617b969 --- /dev/null +++ b/extra/id3/authors.txt @@ -0,0 +1,2 @@ +Tim Wawrzynczak + diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor new file mode 100644 index 0000000000..da69c2ced3 --- /dev/null +++ b/extra/id3/id3-docs.factor @@ -0,0 +1,17 @@ +! 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" diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor new file mode 100644 index 0000000000..b9d45b1b04 --- /dev/null +++ b/extra/id3/id3-tests.factor @@ -0,0 +1,182 @@ +! 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 + diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor new file mode 100644 index 0000000000..64e1ff1d10 --- /dev/null +++ b/extra/id3/id3.factor @@ -0,0 +1,154 @@ +! 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 ; + +: ( -- object ) mp3v1-file new ; + +: ( header frames -- object ) mp3v2-file boa ; + +:
( -- object ) header new ; + +: ( -- object ) frame new ; + +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 filter-text-data ; + +! read whole frames + +: (read-frame) ( mmap -- 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 >28bitword ; + +: read-v2-header ( mmap -- id3header ) + [
] 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 ; + +! 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 ) + [ ] 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 diff --git a/extra/id3/tests/blah.mp3 b/extra/id3/tests/blah.mp3 new file mode 100644 index 0000000000..3a60bffd34 Binary files /dev/null and b/extra/id3/tests/blah.mp3 differ diff --git a/extra/id3/tests/blah2.mp3 b/extra/id3/tests/blah2.mp3 new file mode 100644 index 0000000000..5d27429982 Binary files /dev/null and b/extra/id3/tests/blah2.mp3 differ diff --git a/extra/id3/tests/blah3.mp3 b/extra/id3/tests/blah3.mp3 new file mode 100644 index 0000000000..19aaa94dc6 Binary files /dev/null and b/extra/id3/tests/blah3.mp3 differ diff --git a/extra/images/authors.txt b/extra/images/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/images/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/images/backend/authors.txt b/extra/images/backend/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/extra/images/backend/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/extra/images/backend/backend.factor b/extra/images/backend/backend.factor new file mode 100644 index 0000000000..756b98efee --- /dev/null +++ b/extra/images/backend/backend.factor @@ -0,0 +1,51 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel grouping fry sequences combinators +math ; +IN: images.backend + +SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ; + +TUPLE: image dim component-order bitmap ; + +TUPLE: normalized-image < image ; + +GENERIC: load-image* ( path tuple -- image ) + +GENERIC: >image ( object -- image ) + +: no-op ( -- ) ; + +: normalize-component-order ( image -- image ) + dup component-order>> + { + { RGBA [ no-op ] } + { BGRA [ + [ + [ 4 [ [ 0 3 ] dip reverse-here ] each ] + [ RGBA >>component-order ] bi + ] change-bitmap + ] } + { RGB [ + [ 3 [ 255 suffix ] map concat ] change-bitmap + ] } + { BGR [ + [ + 3 dup [ [ 0 3 ] dip reverse-here ] each + [ 255 suffix ] map concat + ] change-bitmap + ] } + } case RGBA >>component-order ; + +GENERIC: normalize-scan-line-order ( image -- image ) + +M: image normalize-scan-line-order ; +: normalize-image ( image -- image ) + normalize-component-order + normalize-scan-line-order ; + +: new-image ( dim component-order bitmap class -- image ) + new + swap >>bitmap + swap >>component-order + swap >>dim ; inline diff --git a/extra/images/bitmap/authors.txt b/extra/images/bitmap/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/images/bitmap/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/images/bitmap/bitmap-tests.factor b/extra/images/bitmap/bitmap-tests.factor new file mode 100644 index 0000000000..a7deae3178 --- /dev/null +++ b/extra/images/bitmap/bitmap-tests.factor @@ -0,0 +1,24 @@ +USING: images.bitmap images.viewer io.encodings.binary +io.files io.files.unique kernel tools.test ; +IN: images.bitmap.tests + +: test-bitmap24 ( -- path ) + "resource:extra/images/test-images/thiswayup24.bmp" ; + +: test-bitmap8 ( -- path ) + "resource:extra/images/test-images/rgb8bit.bmp" ; + +: test-bitmap4 ( -- path ) + "resource:extra/images/test-images/rgb4bit.bmp" ; + +: test-bitmap1 ( -- path ) + "resource:extra/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 diff --git a/extra/images/bitmap/bitmap.factor b/extra/images/bitmap/bitmap.factor new file mode 100755 index 0000000000..46f90e33f8 --- /dev/null +++ b/extra/images/bitmap/bitmap.factor @@ -0,0 +1,163 @@ +! 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 images.backend ; +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 [ 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 ; + +M: bitmap >image ( bitmap -- bitmap-image ) + { + [ [ width>> ] [ height>> ] bi 2array ] + [ bitmap>component-order ] + [ buffer>> ] + } cleave bitmap-image new-image ; + +M: bitmap-image load-image* ( path bitmap -- bitmap-image ) + drop load-bitmap >image ; + +M: bitmap-image normalize-scan-line-order + dup dim>> '[ + _ first 4 * 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 ; diff --git a/extra/images/images.factor b/extra/images/images.factor new file mode 100644 index 0000000000..3df7b5d2d1 --- /dev/null +++ b/extra/images/images.factor @@ -0,0 +1,21 @@ +! 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.backend io.backend +io.pathnames ; +IN: images + +ERROR: unknown-image-extension extension ; + +: image-class ( path -- class ) + file-extension >lower { + { "bmp" [ bitmap-image ] } + { "tiff" [ tiff-image ] } + [ unknown-image-extension ] + } case ; + +: load-image ( path -- image ) + dup image-class new load-image* ; + +: ( path -- image ) + load-image normalize-image ; diff --git a/extra/graphics/tags.txt b/extra/images/tags.txt similarity index 100% rename from extra/graphics/tags.txt rename to extra/images/tags.txt diff --git a/extra/graphics/bitmap/test-images/1bit.bmp b/extra/images/test-images/1bit.bmp similarity index 100% rename from extra/graphics/bitmap/test-images/1bit.bmp rename to extra/images/test-images/1bit.bmp diff --git a/extra/images/test-images/octagon.tiff b/extra/images/test-images/octagon.tiff new file mode 100644 index 0000000000..2b4ba3950d Binary files /dev/null and b/extra/images/test-images/octagon.tiff differ diff --git a/extra/images/test-images/rgb.tiff b/extra/images/test-images/rgb.tiff new file mode 100755 index 0000000000..71cbaa9d6e Binary files /dev/null and b/extra/images/test-images/rgb.tiff differ diff --git a/extra/graphics/bitmap/test-images/rgb4bit.bmp b/extra/images/test-images/rgb4bit.bmp similarity index 100% rename from extra/graphics/bitmap/test-images/rgb4bit.bmp rename to extra/images/test-images/rgb4bit.bmp diff --git a/extra/graphics/bitmap/test-images/rgb8bit.bmp b/extra/images/test-images/rgb8bit.bmp similarity index 100% rename from extra/graphics/bitmap/test-images/rgb8bit.bmp rename to extra/images/test-images/rgb8bit.bmp diff --git a/extra/graphics/bitmap/test-images/thiswayup24.bmp b/extra/images/test-images/thiswayup24.bmp similarity index 100% rename from extra/graphics/bitmap/test-images/thiswayup24.bmp rename to extra/images/test-images/thiswayup24.bmp diff --git a/extra/images/tiff/authors.txt b/extra/images/tiff/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/images/tiff/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/images/tiff/tiff-tests.factor b/extra/images/tiff/tiff-tests.factor new file mode 100755 index 0000000000..9905e7ad79 --- /dev/null +++ b/extra/images/tiff/tiff-tests.factor @@ -0,0 +1,10 @@ +! Copyright (C) 2009 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: tools.test images.tiff ; +IN: images.tiff.tests + +: tiff-test-path ( -- path ) + "resource:extra/images/test-images/rgb.tiff" ; + +: tiff-test-path2 ( -- path ) + "resource:extra/images/test-images/octagon.tiff" ; diff --git a/extra/images/tiff/tiff.factor b/extra/images/tiff/tiff.factor new file mode 100755 index 0000000000..dc40f648cc --- /dev/null +++ b/extra/images/tiff/tiff.factor @@ -0,0 +1,293 @@ +! 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 constructors sequences arrays +sorting.slots math.order math.parser prettyprint classes +io.binary assocs math math.bitwise byte-arrays grouping +images.backend ; +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 +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> ; + +: read-ifds ( tiff -- tiff ) + dup ifd-offset>> seek-absolute seek-input + 2 read endian> + dup [ read-ifd ] replicate + 4 read endian> + [ 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 * ] } + [ 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 ] } + [ bad-small-ifd-type ] + } case ; + +: offset-bytes>obj ( bytes type -- obj ) + { + { 1 [ ] } ! blank + { 2 [ ] } ! read c strings here + { 3 [ 2 [ endian> ] map ] } + { 4 [ 4 [ endian> ] map ] } + { 5 [ 8 [ "II" unpack first2 / ] map ] } + { 6 [ [ 8 >signed ] map ] } + { 7 [ ] } ! blank + { 8 [ 2 [ endian> 16 >signed ] map ] } + { 9 [ 4 [ 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 [ x-resolution ] } + { 283 [ y-resolution ] } + { 284 [ planar-configuration ] } + { 296 [ lookup-resolution-unit resolution-unit ] } + { 317 [ lookup-predictor predictor ] } + { 338 [ lookup-extra-samples extra-samples ] } + { 339 [ lookup-sample-format sample-format ] } + [ nip unhandled-ifd-entry ] + } case ; + +: process-ifd ( ifd -- ifd ) + dup ifd-entries>> + [ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ; + +: strips>bitmap ( ifd -- ifd ) + dup strips>> concat >>bitmap ; + +ERROR: unknown-component-order ifd ; + +: ifd-component-order ( ifd -- byte-order ) + bits-per-sample find-tag sum { + { 32 [ RGBA ] } + { 24 [ RGB ] } + [ unknown-component-order ] + } case ; + +M: ifd >image ( ifd -- image ) + { + [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] + [ ifd-component-order ] + [ bitmap>> ] + } cleave tiff-image new-image ; + +M: parsed-tiff >image ( image -- image ) + ifds>> [ >image ] map first ; + +: load-tiff ( path -- parsed-tiff ) + binary [ + + read-header dup endianness>> [ + read-ifds + dup ifds>> [ process-ifd read-strips strips>bitmap 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 >image ; diff --git a/extra/images/viewer/authors.txt b/extra/images/viewer/authors.txt new file mode 100755 index 0000000000..7c1b2f2279 --- /dev/null +++ b/extra/images/viewer/authors.txt @@ -0,0 +1 @@ +Doug Coleman diff --git a/extra/images/viewer/viewer.factor b/extra/images/viewer/viewer.factor new file mode 100644 index 0000000000..92277dfdef --- /dev/null +++ b/extra/images/viewer/viewer.factor @@ -0,0 +1,37 @@ +! Copyright (C) 2007 Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors images images.backend 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 new-gadget + swap >>image ; + +: image-window ( path -- gadget ) + [ dup ] [ open-window ] bi ; + +GENERIC: image. ( object -- ) + +: default-image. ( path -- ) + gadget. ; + +M: string image. ( image -- ) default-image. ; + +M: pathname image. ( image -- ) default-image. ; + +M: image image. ( image -- ) default-image. ; diff --git a/extra/infix/ast/ast.factor b/extra/infix/ast/ast.factor new file mode 100644 index 0000000000..0bc22feeb7 --- /dev/null +++ b/extra/infix/ast/ast.factor @@ -0,0 +1,8 @@ +IN: infix.ast + +TUPLE: ast-number value ; +TUPLE: ast-local name ; +TUPLE: ast-array name index ; +TUPLE: ast-function name arguments ; +TUPLE: ast-op left right op ; +TUPLE: ast-negation term ; diff --git a/extra/infix/infix-docs.factor b/extra/infix/infix-docs.factor new file mode 100644 index 0000000000..7a4febb514 --- /dev/null +++ b/extra/infix/infix-docs.factor @@ -0,0 +1,38 @@ +USING: help.syntax help.markup prettyprint locals ; +IN: infix + +HELP: [infix +{ $syntax "[infix ... infix]" } +{ $description "Parses the infix code inside the brackets, converts it to stack code and executes it." } +{ $examples + { $example + "USING: infix prettyprint ;" + "IN: scratchpad" + "[infix 8+2*3 infix] ." + "14" + } $nl + { $link POSTPONE: [infix } " isn't that useful by itself, as it can only access literal numbers and no variables. It is designed to be used together with locals; for example with " { $link POSTPONE: :: } " :" + { $example + "USING: infix locals math.functions prettyprint ;" + "IN: scratchpad" + ":: quadratic-equation ( a b c -- z- z+ )" + " [infix (-b-sqrt(b*b-4*a*c)) / (2*a) infix]" + " [infix (-b+sqrt(b*b-4*a*c)) / (2*a) infix] ;" + "1 0 -1 quadratic-equation . ." + "1.0\n-1.0" + } +} ; + +HELP: [infix| +{ $syntax "[infix| binding1 [ value1... ]\n binding2 [ value2... ]\n ... |\n infix-expression infix]" } +{ $description "Introduces a set of lexical bindings and evaluates the body as a snippet of infix code. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [infix| } " form, as it is based on " { $link POSTPONE: [let } "." } +{ $examples + { $example + "USING: infix prettyprint ;" + "IN: scratchpad" + "[infix| pi [ 3.14 ] r [ 12 ] | r*r*pi infix] ." + "452.16" + } +} ; + +{ POSTPONE: [infix POSTPONE: [infix| } related-words diff --git a/extra/infix/infix-tests.factor b/extra/infix/infix-tests.factor new file mode 100644 index 0000000000..5ee6468131 --- /dev/null +++ b/extra/infix/infix-tests.factor @@ -0,0 +1,45 @@ +USING: infix infix.private kernel locals math math.functions +tools.test ; +IN: infix.tests + +[ 0 ] [ [infix 0 infix] ] unit-test +[ 0.5 ] [ [infix 3.0/6 infix] ] unit-test +[ 1+2/3 ] [ [infix 5/3 infix] ] unit-test +[ 3 ] [ [infix 2*7%3+1 infix] ] unit-test +[ 1 ] [ [infix 2- + 1 + -5* + 0 infix] ] unit-test + +[ 452.16 ] [ [infix| r [ 12 ] pi [ 3.14 ] | + r*r*pi infix] ] unit-test +[ 0 ] [ [infix| a [ 3 ] | 0 infix] ] unit-test +[ 4/5 ] [ [infix| x [ 3 ] f [ 12 ] | f/(f+x) infix] ] unit-test +[ 144 ] [ [infix| a [ 0 ] b [ 12 ] | b*b-a infix] ] unit-test + +[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | a[0] infix] ] unit-test +[ 0 ] [ [infix| a [ { 0 1 2 3 } ] | 3*a[0]*2*a[1] infix] ] unit-test +[ 6 ] [ [infix| a [ { 0 1 2 3 } ] | a[0]+a[10%3]+a[3-1]+a[18/6] infix] ] unit-test +[ -1 ] [ [infix| a [ { 0 1 2 3 } ] | -a[+1] infix] ] unit-test + +[ 0.0 ] [ [infix sin(0) infix] ] unit-test +[ 10 ] [ [infix lcm(2,5) infix] ] unit-test +[ 1.0 ] [ [infix +cos(-0*+3) infix] ] unit-test + +[ f ] [ 2 \ gcd check-word ] unit-test ! multiple return values +[ f ] [ 1 \ drop check-word ] unit-test ! no return value +[ f ] [ 1 \ lcm check-word ] unit-test ! takes 2 args +: no-stack-effect-declared + ; +[ 0 \ no-stack-effect-declared check-word ] must-fail + +: qux ( -- x ) 2 ; +[ t ] [ 0 \ qux check-word ] unit-test +[ 8 ] [ [infix qux()*3+2 infix] ] unit-test +: foobar ( x -- y ) 1 + ; +[ t ] [ 1 \ foobar check-word ] unit-test +[ 4 ] [ [infix foobar(3*5%12) infix] ] unit-test +: stupid_function ( x x x x x -- y ) + + + + ; +[ t ] [ 5 \ stupid_function check-word ] unit-test +[ 10 ] [ [infix stupid_function (0, 1, 2, 3, 4) infix] ] unit-test + +[ -1 ] [ [let | a [ 1 ] | [infix -a infix] ] ] unit-test diff --git a/extra/infix/infix.factor b/extra/infix/infix.factor new file mode 100644 index 0000000000..31cd1cbe1f --- /dev/null +++ b/extra/infix/infix.factor @@ -0,0 +1,99 @@ +USING: accessors assocs combinators combinators.short-circuit +effects fry infix.parser infix.ast kernel locals.parser +locals.types math multiline namespaces parser quotations +sequences summary words ; +IN: infix + +local-word ( string -- word ) + locals get at? [ local-not-defined ] unless ; + +: select-op ( string -- word ) + { + { "+" [ [ + ] ] } + { "-" [ [ - ] ] } + { "*" [ [ * ] ] } + { "/" [ [ / ] ] } + [ drop [ mod ] ] + } case ; + +GENERIC: infix-codegen ( ast -- quot/number ) + +M: ast-number infix-codegen value>> ; + +M: ast-local infix-codegen + name>> >local-word ; + +M: ast-array infix-codegen + [ index>> infix-codegen prepare-operand ] + [ name>> >local-word ] bi '[ @ _ nth ] ; + +M: ast-op infix-codegen + [ left>> infix-codegen ] [ right>> infix-codegen ] + [ op>> select-op ] tri + 2over [ number? ] both? [ call ] [ + [ [ prepare-operand ] bi@ ] dip '[ @ @ @ ] + ] if ; + +M: ast-negation infix-codegen + term>> infix-codegen + { + { [ dup number? ] [ neg ] } + { [ dup callable? ] [ '[ @ neg ] ] } + [ '[ _ neg ] ] ! local word + } cond ; + +ERROR: bad-stack-effect word ; +M: bad-stack-effect summary + drop "Words used in infix must declare a stack effect and return exactly one value" ; + +: check-word ( argcount word -- ? ) + dup stack-effect [ ] [ bad-stack-effect ] ?if + [ in>> length ] [ out>> length ] bi + [ = ] dip 1 = and ; + +: find-and-check ( args argcount string -- quot ) + dup search [ ] [ no-word ] ?if + [ nip ] [ check-word ] 2bi + [ 1quotation compose ] [ bad-stack-effect ] if ; + +: arguments-codegen ( seq -- quot ) + dup empty? [ drop [ ] ] [ + [ infix-codegen prepare-operand ] + [ compose ] map-reduce + ] if ; + +M: ast-function infix-codegen + [ arguments>> [ arguments-codegen ] [ length ] bi ] + [ name>> ] bi find-and-check ; + +: [infix-parse ( end -- result/quot ) + parse-multiline-string build-infix-ast + infix-codegen prepare-operand ; +PRIVATE> + +: [infix + "infix]" [infix-parse parsed \ call parsed ; parsing + + + +: [infix| + "|" parse-bindings "infix]" parse-infix-locals + parsed-lambda ; parsing diff --git a/extra/infix/parser/parser-tests.factor b/extra/infix/parser/parser-tests.factor new file mode 100644 index 0000000000..0a0288c41b --- /dev/null +++ b/extra/infix/parser/parser-tests.factor @@ -0,0 +1,175 @@ +USING: infix.ast infix.parser infix.tokenizer tools.test ; +IN: infix.parser.tests + +\ parse-infix must-infer +\ build-infix-ast must-infer + +[ T{ ast-number { value 1 } } ] [ "1" build-infix-ast ] unit-test +[ T{ ast-negation f T{ ast-number { value 1 } } } ] +[ "-1" build-infix-ast ] unit-test +[ T{ ast-op + { left + T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } + } + } + { right T{ ast-number { value 4 } } } + { op "+" } +} ] [ "1+2+4" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "*" } + } + } + { op "+" } +} ] [ "1+2*3" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } +} ] [ "(1+2)" build-infix-ast ] unit-test + +[ T{ ast-local { name "foo" } } ] [ "foo" build-infix-ast ] unit-test +[ "-" build-infix-ast ] must-fail + +[ T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-op + { left T{ ast-number { value 1 } } } + { right T{ ast-number { value 2 } } } + { op "+" } + } + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "%" } + } + } + } +} ] [ "foo (1+ 2,2%3) " build-infix-ast ] unit-test + +[ T{ ast-op + { left + T{ ast-op + { left + T{ ast-function + { name "bar" } + { arguments V{ } } + } + } + { right + T{ ast-array + { name "baz" } + { index + T{ ast-op + { left + T{ ast-op + { left + T{ ast-number + { value 2 } + } + } + { right + T{ ast-number + { value 3 } + } + } + { op "/" } + } + } + { right + T{ ast-number { value 4 } } + } + { op "+" } + } + } + } + } + { op "+" } + } + } + { right T{ ast-number { value 2 } } } + { op "/" } +} ] [ "(bar() + baz[2/ 3+4 ] )/2" build-infix-ast ] unit-test + +[ T{ ast-op + { left T{ ast-number { value 1 } } } + { right + T{ ast-op + { left T{ ast-number { value 2 } } } + { right T{ ast-number { value 3 } } } + { op "/" } + } + } + { op "+" } +} ] [ "1\n+\n2\r/\t3" build-infix-ast ] unit-test + +[ T{ ast-negation + { term + T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-number { value 2 } } + T{ ast-negation + { term T{ ast-number { value 3 } } } + } + } + } + } + } +} ] [ "-foo(+2,-3)" build-infix-ast ] unit-test + +[ T{ ast-array + { name "arr" } + { index + T{ ast-op + { left + T{ ast-negation + { term + T{ ast-op + { left + T{ ast-function + { name "foo" } + { arguments + V{ + T{ ast-number + { value 2 } + } + } + } + } + } + { right + T{ ast-negation + { term + T{ ast-number + { value 1 } + } + } + } + } + { op "+" } + } + } + } + } + { right T{ ast-number { value 3 } } } + { op "/" } + } + } +} ] [ "+arr[-(foo(2)+-1)/3]" build-infix-ast ] unit-test + +[ "foo bar baz" build-infix-ast ] must-fail +[ "1+2/4+" build-infix-ast ] must-fail +[ "quaz(2/3,)" build-infix-ast ] must-fail diff --git a/extra/infix/parser/parser.factor b/extra/infix/parser/parser.factor new file mode 100644 index 0000000000..beaf3c335d --- /dev/null +++ b/extra/infix/parser/parser.factor @@ -0,0 +1,30 @@ +USING: infix.ast infix.tokenizer kernel math peg.ebnf sequences +strings vectors ; +IN: infix.parser + +EBNF: parse-infix +Number = . ?[ ast-number? ]? +Identifier = . ?[ string? ]? +Array = Identifier:i "[" Sum:s "]" => [[ i s ast-array boa ]] +Function = Identifier:i "(" FunArgs?:a ")" => [[ i a [ V{ } ] unless* ast-function boa ]] + +FunArgs = FunArgs:a "," Sum:s => [[ s a push a ]] + | Sum:s => [[ s 1vector ]] + +Terminal = ("-"|"+"):op Terminal:term => [[ term op "-" = [ ast-negation boa ] when ]] + | "(" Sum:s ")" => [[ s ]] + | Number | Array | Function + | Identifier => [[ ast-local boa ]] + +Product = Product:p ("*"|"/"|"%"):op Terminal:term => [[ p term op ast-op boa ]] + | Terminal + +Sum = Sum:s ("+"|"-"):op Product:p => [[ s p op ast-op boa ]] + | Product + +End = !(.) +Expression = Sum End +;EBNF + +: build-infix-ast ( string -- ast ) + tokenize-infix parse-infix ; diff --git a/extra/infix/tokenizer/tokenizer-tests.factor b/extra/infix/tokenizer/tokenizer-tests.factor new file mode 100644 index 0000000000..7e1fb005ef --- /dev/null +++ b/extra/infix/tokenizer/tokenizer-tests.factor @@ -0,0 +1,20 @@ +USING: infix.ast infix.tokenizer tools.test ; +IN: infix.tokenizer.tests + +\ tokenize-infix must-infer +[ V{ T{ ast-number f 1 } } ] [ "1" tokenize-infix ] unit-test +[ V{ T{ ast-number f 1.02 } CHAR: * T{ ast-number f 3 } } ] [ "1.02*3" tokenize-infix ] unit-test +[ V{ T{ ast-number f 3 } CHAR: / CHAR: ( T{ ast-number f 3 } CHAR: + T{ ast-number f 4 } CHAR: ) } ] +[ "3/(3+4)" tokenize-infix ] unit-test +[ V{ "foo" CHAR: ( "x" CHAR: , "y" CHAR: , "z" CHAR: ) } ] [ "foo(x,y,z)" tokenize-infix ] unit-test +[ V{ "arr" CHAR: [ "x" CHAR: + T{ ast-number f 3 } CHAR: ] } ] +[ "arr[x+3]" tokenize-infix ] unit-test +[ "1.0.4" tokenize-infix ] must-fail +[ V{ CHAR: + CHAR: ] T{ ast-number f 3.4 } CHAR: , "bar" } ] +[ "+]3.4,bar" tokenize-infix ] unit-test +[ V{ "baz_34c" } ] [ "baz_34c" tokenize-infix ] unit-test +[ V{ T{ ast-number f 34 } "c_baz" } ] [ "34c_baz" tokenize-infix ] unit-test +[ V{ CHAR: ( T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: ) } ] +[ "(1+2)" tokenize-infix ] unit-test +[ V{ T{ ast-number f 1 } CHAR: + T{ ast-number f 2 } CHAR: / T{ ast-number f 3 } } ] +[ "1\n+\r2\t/ 3" tokenize-infix ] unit-test diff --git a/extra/infix/tokenizer/tokenizer.factor b/extra/infix/tokenizer/tokenizer.factor new file mode 100644 index 0000000000..8c1a1b4a18 --- /dev/null +++ b/extra/infix/tokenizer/tokenizer.factor @@ -0,0 +1,21 @@ +USING: infix.ast kernel peg peg.ebnf math.parser sequences +strings ; +IN: infix.tokenizer + +EBNF: tokenize-infix +Letter = [a-zA-Z] +Digit = [0-9] +Digits = Digit+ +Number = Digits '.' Digits => [[ concat >string string>number ast-number boa ]] + | Digits => [[ >string string>number ast-number boa ]] +Space = " " | "\n" | "\r" | "\t" +Spaces = Space* => [[ ignore ]] +NameFirst = Letter | "_" => [[ CHAR: _ ]] +NameRest = NameFirst | Digit +Name = NameFirst NameRest* => [[ first2 swap prefix >string ]] +Special = [+*/%(),] | "-" => [[ CHAR: - ]] + | "[" => [[ CHAR: [ ]] | "]" => [[ CHAR: ] ]] +Tok = Spaces (Name | Number | Special ) +End = !(.) +Toks = Tok* Spaces End +;EBNF diff --git a/extra/inverse/authors.txt b/extra/inverse/authors.txt deleted file mode 100644 index f990dd0ed2..0000000000 --- a/extra/inverse/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Daniel Ehrenberg diff --git a/extra/lists/lists-docs.factor b/extra/lists/lists-docs.factor deleted file mode 100644 index 8807c8cf8a..0000000000 --- a/extra/lists/lists-docs.factor +++ /dev/null @@ -1,104 +0,0 @@ -! 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." } ; - diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor deleted file mode 100644 index bf822889e3..0000000000 --- a/extra/lists/lists.factor +++ /dev/null @@ -1,112 +0,0 @@ -! 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 ) - nil [ swap cons ] reduce ; - -: same? ( obj1 obj2 -- ? ) - [ class ] bi@ = ; - -: seq>cons ( seq -- cons ) - [ ] 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 diff --git a/extra/lists/tags.txt b/extra/lists/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/extra/lists/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/extra/mason/config/config.factor b/extra/mason/config/config.factor index b1739d85fa..51b09543f4 100644 --- a/extra/mason/config/config.factor +++ b/extra/mason/config/config.factor @@ -81,7 +81,7 @@ SYMBOL: upload-directory ! 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 diff --git a/extra/msxml-to-csv/msxml-to-csv.factor b/extra/msxml-to-csv/msxml-to-csv.factor index 855275efcc..cab28c14ca 100644 --- a/extra/msxml-to-csv/msxml-to-csv.factor +++ b/extra/msxml-to-csv/msxml-to-csv.factor @@ -1,4 +1,4 @@ -USING: io io.files sequences xml xml.utilities +USING: io io.files sequences xml xml.traversal io.encodings.ascii kernel ; IN: msxml-to-csv diff --git a/extra/parser-combinators/parser-combinators.factor b/extra/parser-combinators/parser-combinators.factor index 8afbb2d03b..99e8099f38 100755 --- a/extra/parser-combinators/parser-combinators.factor +++ b/extra/parser-combinators/parser-combinators.factor @@ -17,7 +17,7 @@ ERROR: cannot-parse input ; : parse-1 ( input parser -- result ) dupd parse dup nil? [ - rot cannot-parse + swap cannot-parse ] [ nip car parsed>> ] if ; @@ -149,8 +149,8 @@ TUPLE: and-parser parsers ; [ parsed>> ] dip [ parsed>> 2array ] keep unparsed>> - ] 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 @@ -173,7 +173,7 @@ M: or-parser parse ( input parser1 -- list ) #! 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 @@ -218,7 +218,7 @@ M: apply-parser parse ( input parser -- result ) -rot parse [ [ parsed>> swap call ] keep unparsed>> - ] lazy-map-with ; + ] with lazy-map ; TUPLE: some-parser p1 ; diff --git a/extra/project-euler/002/002.factor b/extra/project-euler/002/002.factor index da20c874b5..9c462b6b2e 100644 --- a/extra/project-euler/002/002.factor +++ b/extra/project-euler/002/002.factor @@ -1,6 +1,6 @@ ! 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 @@ -41,7 +41,7 @@ PRIVATE> ! ------------------- : 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 ) diff --git a/extra/project-euler/134/134.factor b/extra/project-euler/134/134.factor index e00e86865d..0f009919d9 100644 --- a/extra/project-euler/134/134.factor +++ b/extra/project-euler/134/134.factor @@ -39,7 +39,7 @@ IN: project-euler.134 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 diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor index 38366697ea..bec2761e53 100755 --- a/extra/promises/promises.factor +++ b/extra/promises/promises.factor @@ -1,10 +1,6 @@ -! 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 @@ -24,7 +20,7 @@ TUPLE: promise quot forced? value ; #! 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>> ; diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 3e47adac0b..89e00f88c5 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -25,7 +25,6 @@ IN: reports.noise { 3drop 1 } { 3dup 2 } { 3keep 3 } - { 3nip 4 } { 3slip 3 } { 4drop 2 } { 4dup 3 } @@ -50,7 +49,6 @@ IN: reports.noise { ndrop 2 } { ndup 3 } { nip 2 } - { nipd 3 } { nkeep 5 } { npick 6 } { nrot 5 } @@ -66,7 +64,6 @@ IN: reports.noise { swap 1 } { swapd 3 } { tuck 2 } - { tuckd 4 } { with 1/2 } { bi 1/2 } diff --git a/extra/svg/svg-tests.factor b/extra/svg/svg-tests.factor index 3a28310d71..0f0c349b8e 100644 --- a/extra/svg/svg-tests.factor +++ b/extra/svg/svg-tests.factor @@ -1,6 +1,6 @@ ! (c)2009 Joe Groff, see BSD license USING: accessors arrays literals math math.affine-transforms -math.functions multiline sequences svg tools.test xml xml.utilities ; +math.functions multiline sequences svg tools.test xml xml.traversal ; IN: svg.tests { 1.0 2.25 } { -3.0 4.0 } { 5.5 0.000001 } 1array [ diff --git a/extra/svg/svg.factor b/extra/svg/svg.factor index 4d8a6e6a17..2ed5d21707 100644 --- a/extra/svg/svg.factor +++ b/extra/svg/svg.factor @@ -1,7 +1,7 @@ ! (c)2009 Joe Groff, see BSD license USING: accessors arrays assocs fry kernel math math.affine-transforms math.constants math.functions math.parser math.vectors memoize peg.ebnf sequences sequences.squish -splitting strings xml.data xml.utilities ; +splitting strings xml.data xml.syntax ; IN: svg XML-NS: svg-name http://www.w3.org/2000/svg diff --git a/extra/taxes/usa/futa/futa.factor b/extra/taxes/usa/futa/futa.factor index 7368aef825..9b862a8960 100644 --- a/extra/taxes/usa/futa/futa.factor +++ b/extra/taxes/usa/futa/futa.factor @@ -11,5 +11,4 @@ IN: taxes.usa.futa : futa-tax ( salary w4 -- x ) drop futa-base-rate min - futa-tax-rate futa-tax-offset-credit - - * ; + futa-tax-rate futa-tax-offset-credit - * ; diff --git a/extra/taxes/usa/usa.factor b/extra/taxes/usa/usa.factor index 27ff4aef98..bbfc332868 100644 --- a/extra/taxes/usa/usa.factor +++ b/extra/taxes/usa/usa.factor @@ -1,7 +1,8 @@ ! 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) diff --git a/extra/ui/offscreen/offscreen-docs.factor b/extra/ui/offscreen/offscreen-docs.factor index 5d800981bf..4123a83675 100644 --- a/extra/ui/offscreen/offscreen-docs.factor +++ b/extra/ui/offscreen/offscreen-docs.factor @@ -1,7 +1,7 @@ ! 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: diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor index 89c1c7f860..cf9370ed7f 100755 --- a/extra/ui/offscreen/offscreen.factor +++ b/extra/ui/offscreen/offscreen.factor @@ -1,5 +1,5 @@ ! (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 diff --git a/extra/ui/render/test/test.factor b/extra/ui/render/test/test.factor index 2267c22a20..dcbc5b9600 100755 --- a/extra/ui/render/test/test.factor +++ b/extra/ui/render/test/test.factor @@ -1,10 +1,10 @@ ! 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 ; IN: ui.render.test SINGLETON: line-test @@ -30,7 +30,7 @@ SYMBOL: render-output : bitmap= ( bitmap1 bitmap2 -- ? ) [ - [ [ array>> ] [ stride 4 align ] bi group ] [ stride ] bi + [ [ buffer>> ] [ stride 4 align ] bi group ] [ stride ] bi '[ _ head twiddle ] map ] bi@ = ; @@ -38,7 +38,7 @@ SYMBOL: render-output screenshot [ render-output set-global ] [ - "resource:extra/ui/render/test/reference.bmp" load-bitmap + "resource:extra/ui/render/test/reference.bmp" bitmap= "is perfect" "needs work" ? "Your UI rendering " prepend message-window diff --git a/extra/webapps/user-admin/user-admin.factor b/extra/webapps/user-admin/user-admin.factor index 9d4e348596..c0cd601af5 100644 --- a/extra/webapps/user-admin/user-admin.factor +++ b/extra/webapps/user-admin/user-admin.factor @@ -3,7 +3,6 @@ USING: kernel sequences accessors namespaces combinators words assocs db.tuples arrays splitting strings validators urls html.forms -html.elements html.components furnace furnace.boilerplate diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index c1d62c6cda..35a1129338 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -65,7 +65,7 @@ SYMBOL: dh-file "concatenative.org" 25 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 ( -- ) diff --git a/extra/yahoo/yahoo.factor b/extra/yahoo/yahoo.factor index d163c8f1ac..b58a11747f 100755 --- a/extra/yahoo/yahoo.factor +++ b/extra/yahoo/yahoo.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2006 Daniel Ehrenberg, Walton Chan ! See http://factorcode.org/license.txt for BSD license. -USING: http.client xml xml.utilities kernel sequences +USING: http.client xml xml.traversal kernel sequences math.parser urls accessors locals ; IN: yahoo diff --git a/misc/fuel/fuel-completion.el b/misc/fuel/fuel-completion.el index e6ec8b2dc9..c21d25901f 100644 --- a/misc/fuel/fuel-completion.el +++ b/misc/fuel/fuel-completion.el @@ -18,6 +18,15 @@ (require 'fuel-eval) (require 'fuel-log) + +;;; 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)) + ;;; Vocabs dictionary: @@ -33,7 +42,8 @@ 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) @@ -170,12 +180,23 @@ terminates a current completion." (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. diff --git a/misc/fuel/fuel-connection.el b/misc/fuel/fuel-connection.el index 14c4d0b36f..f180d0f2b4 100644 --- a/misc/fuel/fuel-connection.el +++ b/misc/fuel/fuel-connection.el @@ -144,8 +144,12 @@ (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) diff --git a/misc/fuel/fuel-edit.el b/misc/fuel/fuel-edit.el index e5f0ffd26f..941f57140e 100644 --- a/misc/fuel/fuel-edit.el +++ b/misc/fuel/fuel-edit.el @@ -57,13 +57,6 @@ (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)))) @@ -72,7 +65,6 @@ ;;; 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) @@ -80,7 +72,7 @@ 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)))) diff --git a/misc/fuel/fuel-help.el b/misc/fuel/fuel-help.el index a82de388da..cfc8cab7f1 100644 --- a/misc/fuel/fuel-help.el +++ b/misc/fuel/fuel-help.el @@ -257,7 +257,7 @@ buffer." (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) diff --git a/misc/fuel/fuel-listener.el b/misc/fuel/fuel-listener.el index d0898de04f..b8bf4d4b7f 100644 --- a/misc/fuel/fuel-listener.el +++ b/misc/fuel/fuel-listener.el @@ -32,7 +32,7 @@ (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")) diff --git a/misc/fuel/fuel-markup.el b/misc/fuel/fuel-markup.el index 4844233ae7..980ea111a6 100644 --- a/misc/fuel/fuel-markup.el +++ b/misc/fuel/fuel-markup.el @@ -282,7 +282,8 @@ (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) diff --git a/misc/fuel/fuel-scaffold.el b/misc/fuel/fuel-scaffold.el index 05d825593c..ac400c5622 100644 --- a/misc/fuel/fuel-scaffold.el +++ b/misc/fuel/fuel-scaffold.el @@ -71,7 +71,7 @@ You can configure `fuel-scaffold-developer-name' (set by default to `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)) diff --git a/misc/fuel/fuel-xref.el b/misc/fuel/fuel-xref.el index 4d444ebe3e..faf1897304 100644 --- a/misc/fuel/fuel-xref.el +++ b/misc/fuel/fuel-xref.el @@ -244,7 +244,7 @@ With prefix argument, force reload of vocabulary list." 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))))) diff --git a/unmaintained/openal/macosx/macosx.factor b/unmaintained/openal/macosx/macosx.factor index d2a0422d8d..abc0d65fb9 100644 --- a/unmaintained/openal/macosx/macosx.factor +++ b/unmaintained/openal/macosx/macosx.factor @@ -9,6 +9,6 @@ LIBRARY: alut FUNCTION: void alutLoadWAVFile ( ALbyte* fileName, ALenum* format, void** data, ALsizei* size, ALsizei* frequency ) ; M: macosx load-wav-file ( path -- format data size frequency ) - 0 f 0 0 - [ alutLoadWAVFile ] 4keep - >r >r >r *int r> *void* r> *int r> *int ; + 0 f 0 0 + [ alutLoadWAVFile ] 4keep + [ [ [ *int ] dip *void* ] dip *int ] dip *int ; diff --git a/unmaintained/openal/openal.factor b/unmaintained/openal/openal.factor index 40593d1e8d..8533308f26 100644 --- a/unmaintained/openal/openal.factor +++ b/unmaintained/openal/openal.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: kernel arrays alien system combinators alien.syntax namespaces - alien.c-types sequences vocabs.loader shuffle combinators.lib + alien.c-types sequences vocabs.loader shuffle openal.backend specialized-arrays.uint ; IN: openal @@ -36,75 +36,75 @@ TYPEDEF: int ALenum TYPEDEF: float ALfloat TYPEDEF: double ALdouble -: AL_INVALID ( -- number ) -1 ; inline -: AL_NONE ( -- number ) 0 ; inline -: AL_FALSE ( -- number ) 0 ; inline -: AL_TRUE ( -- number ) 1 ; inline -: AL_SOURCE_RELATIVE ( -- number ) HEX: 202 ; inline -: AL_CONE_INNER_ANGLE ( -- nmber ) HEX: 1001 ; inline -: AL_CONE_OUTER_ANGLE ( -- number ) HEX: 1002 ; inline -: AL_PITCH ( -- number ) HEX: 1003 ; inline -: AL_POSITION ( -- number ) HEX: 1004 ; inline -: AL_DIRECTION ( -- number ) HEX: 1005 ; inline -: AL_VELOCITY ( -- number ) HEX: 1006 ; inline -: AL_LOOPING ( -- number ) HEX: 1007 ; inline -: AL_BUFFER ( -- number ) HEX: 1009 ; inline -: AL_GAIN ( -- number ) HEX: 100A ; inline -: AL_MIN_GAIN ( -- number ) HEX: 100D ; inline -: AL_MAX_GAIN ( -- number ) HEX: 100E ; inline -: AL_ORIENTATION ( -- number ) HEX: 100F ; inline -: AL_CHANNEL_MASK ( -- number ) HEX: 3000 ; inline -: AL_SOURCE_STATE ( -- number ) HEX: 1010 ; inline -: AL_INITIAL ( -- number ) HEX: 1011 ; inline -: AL_PLAYING ( -- number ) HEX: 1012 ; inline -: AL_PAUSED ( -- number ) HEX: 1013 ; inline -: AL_STOPPED ( -- number ) HEX: 1014 ; inline -: AL_BUFFERS_QUEUED ( -- number ) HEX: 1015 ; inline -: AL_BUFFERS_PROCESSED ( -- number ) HEX: 1016 ; inline -: AL_SEC_OFFSET ( -- number ) HEX: 1024 ; inline -: AL_SAMPLE_OFFSET ( -- number ) HEX: 1025 ; inline -: AL_BYTE_OFFSET ( -- number ) HEX: 1026 ; inline -: AL_SOURCE_TYPE ( -- number ) HEX: 1027 ; inline -: AL_STATIC ( -- number ) HEX: 1028 ; inline -: AL_STREAMING ( -- number ) HEX: 1029 ; inline -: AL_UNDETERMINED ( -- number ) HEX: 1030 ; inline -: AL_FORMAT_MONO8 ( -- number ) HEX: 1100 ; inline -: AL_FORMAT_MONO16 ( -- number ) HEX: 1101 ; inline -: AL_FORMAT_STEREO8 ( -- number ) HEX: 1102 ; inline -: AL_FORMAT_STEREO16 ( -- number ) HEX: 1103 ; inline -: AL_REFERENCE_DISTANCE ( -- number ) HEX: 1020 ; inline -: AL_ROLLOFF_FACTOR ( -- number ) HEX: 1021 ; inline -: AL_CONE_OUTER_GAIN ( -- number ) HEX: 1022 ; inline -: AL_MAX_DISTANCE ( -- number ) HEX: 1023 ; inline -: AL_FREQUENCY ( -- number ) HEX: 2001 ; inline -: AL_BITS ( -- number ) HEX: 2002 ; inline -: AL_CHANNELS ( -- number ) HEX: 2003 ; inline -: AL_SIZE ( -- number ) HEX: 2004 ; inline -: AL_UNUSED ( -- number ) HEX: 2010 ; inline -: AL_PENDING ( -- number ) HEX: 2011 ; inline -: AL_PROCESSED ( -- number ) HEX: 2012 ; inline -: AL_NO_ERROR ( -- number ) AL_FALSE ; inline -: AL_INVALID_NAME ( -- number ) HEX: A001 ; inline -: AL_ILLEGAL_ENUM ( -- number ) HEX: A002 ; inline -: AL_INVALID_ENUM ( -- number ) HEX: A002 ; inline -: AL_INVALID_VALUE ( -- number ) HEX: A003 ; inline -: AL_ILLEGAL_COMMAND ( -- number ) HEX: A004 ; inline -: AL_INVALID_OPERATION ( -- number ) HEX: A004 ; inline -: AL_OUT_OF_MEMORY ( -- number ) HEX: A005 ; inline -: AL_VENDOR ( -- number ) HEX: B001 ; inline -: AL_VERSION ( -- number ) HEX: B002 ; inline -: AL_RENDERER ( -- number ) HEX: B003 ; inline -: AL_EXTENSIONS ( -- number ) HEX: B004 ; inline -: AL_DOPPLER_FACTOR ( -- number ) HEX: C000 ; inline -: AL_DOPPLER_VELOCITY ( -- number ) HEX: C001 ; inline -: AL_SPEED_OF_SOUND ( -- number ) HEX: C003 ; inline -: AL_DISTANCE_MODEL ( -- number ) HEX: D000 ; inline -: AL_INVERSE_DISTANCE ( -- number ) HEX: D001 ; inline -: AL_INVERSE_DISTANCE_CLAMPED ( -- number ) HEX: D002 ; inline -: AL_LINEAR_DISTANCE ( -- number ) HEX: D003 ; inline -: AL_LINEAR_DISTANCE_CLAMPED ( -- number ) HEX: D004 ; inline -: AL_EXPONENT_DISTANCE ( -- number ) HEX: D005 ; inline -: AL_EXPONENT_DISTANCE_CLAMPED ( -- number ) HEX: D006 ; inline +CONSTANT: AL_INVALID -1 +CONSTANT: AL_NONE 0 +CONSTANT: AL_FALSE 0 +CONSTANT: AL_TRUE 1 +CONSTANT: AL_SOURCE_RELATIVE HEX: 202 +CONSTANT: AL_CONE_INNER_ANGLE HEX: 1001 +CONSTANT: AL_CONE_OUTER_ANGLE HEX: 1002 +CONSTANT: AL_PITCH HEX: 1003 +CONSTANT: AL_POSITION HEX: 1004 +CONSTANT: AL_DIRECTION HEX: 1005 +CONSTANT: AL_VELOCITY HEX: 1006 +CONSTANT: AL_LOOPING HEX: 1007 +CONSTANT: AL_BUFFER HEX: 1009 +CONSTANT: AL_GAIN HEX: 100A +CONSTANT: AL_MIN_GAIN HEX: 100D +CONSTANT: AL_MAX_GAIN HEX: 100E +CONSTANT: AL_ORIENTATION HEX: 100F +CONSTANT: AL_CHANNEL_MASK HEX: 3000 +CONSTANT: AL_SOURCE_STATE HEX: 1010 +CONSTANT: AL_INITIAL HEX: 1011 +CONSTANT: AL_PLAYING HEX: 1012 +CONSTANT: AL_PAUSED HEX: 1013 +CONSTANT: AL_STOPPED HEX: 1014 +CONSTANT: AL_BUFFERS_QUEUED HEX: 1015 +CONSTANT: AL_BUFFERS_PROCESSED HEX: 1016 +CONSTANT: AL_SEC_OFFSET HEX: 1024 +CONSTANT: AL_SAMPLE_OFFSET HEX: 1025 +CONSTANT: AL_BYTE_OFFSET HEX: 1026 +CONSTANT: AL_SOURCE_TYPE HEX: 1027 +CONSTANT: AL_STATIC HEX: 1028 +CONSTANT: AL_STREAMING HEX: 1029 +CONSTANT: AL_UNDETERMINED HEX: 1030 +CONSTANT: AL_FORMAT_MONO8 HEX: 1100 +CONSTANT: AL_FORMAT_MONO16 HEX: 1101 +CONSTANT: AL_FORMAT_STEREO8 HEX: 1102 +CONSTANT: AL_FORMAT_STEREO16 HEX: 1103 +CONSTANT: AL_REFERENCE_DISTANCE HEX: 1020 +CONSTANT: AL_ROLLOFF_FACTOR HEX: 1021 +CONSTANT: AL_CONE_OUTER_GAIN HEX: 1022 +CONSTANT: AL_MAX_DISTANCE HEX: 1023 +CONSTANT: AL_FREQUENCY HEX: 2001 +CONSTANT: AL_BITS HEX: 2002 +CONSTANT: AL_CHANNELS HEX: 2003 +CONSTANT: AL_SIZE HEX: 2004 +CONSTANT: AL_UNUSED HEX: 2010 +CONSTANT: AL_PENDING HEX: 2011 +CONSTANT: AL_PROCESSED HEX: 2012 +CONSTANT: AL_NO_ERROR AL_FALSE +CONSTANT: AL_INVALID_NAME HEX: A001 +CONSTANT: AL_ILLEGAL_ENUM HEX: A002 +CONSTANT: AL_INVALID_ENUM HEX: A002 +CONSTANT: AL_INVALID_VALUE HEX: A003 +CONSTANT: AL_ILLEGAL_COMMAND HEX: A004 +CONSTANT: AL_INVALID_OPERATION HEX: A004 +CONSTANT: AL_OUT_OF_MEMORY HEX: A005 +CONSTANT: AL_VENDOR HEX: B001 +CONSTANT: AL_VERSION HEX: B002 +CONSTANT: AL_RENDERER HEX: B003 +CONSTANT: AL_EXTENSIONS HEX: B004 +CONSTANT: AL_DOPPLER_FACTOR HEX: C000 +CONSTANT: AL_DOPPLER_VELOCITY HEX: C001 +CONSTANT: AL_SPEED_OF_SOUND HEX: C003 +CONSTANT: AL_DISTANCE_MODEL HEX: D000 +CONSTANT: AL_INVERSE_DISTANCE HEX: D001 +CONSTANT: AL_INVERSE_DISTANCE_CLAMPED HEX: D002 +CONSTANT: AL_LINEAR_DISTANCE HEX: D003 +CONSTANT: AL_LINEAR_DISTANCE_CLAMPED HEX: D004 +CONSTANT: AL_EXPONENT_DISTANCE HEX: D005 +CONSTANT: AL_EXPONENT_DISTANCE_CLAMPED HEX: D006 FUNCTION: void alEnable ( ALenum capability ) ; FUNCTION: void alDisable ( ALenum capability ) ; @@ -182,34 +182,34 @@ FUNCTION: void alDistanceModel ( ALenum distanceModel ) ; LIBRARY: alut -: ALUT_API_MAJOR_VERSION ( -- number ) 1 ; inline -: ALUT_API_MINOR_VERSION ( -- number ) 1 ; inline -: ALUT_ERROR_NO_ERROR ( -- number ) 0 ; inline -: ALUT_ERROR_OUT_OF_MEMORY ( -- number ) HEX: 200 ; inline -: ALUT_ERROR_INVALID_ENUM ( -- number ) HEX: 201 ; inline -: ALUT_ERROR_INVALID_VALUE ( -- number ) HEX: 202 ; inline -: ALUT_ERROR_INVALID_OPERATION ( -- number ) HEX: 203 ; inline -: ALUT_ERROR_NO_CURRENT_CONTEXT ( -- number ) HEX: 204 ; inline -: ALUT_ERROR_AL_ERROR_ON_ENTRY ( -- number ) HEX: 205 ; inline -: ALUT_ERROR_ALC_ERROR_ON_ENTRY ( -- number ) HEX: 206 ; inline -: ALUT_ERROR_OPEN_DEVICE ( -- number ) HEX: 207 ; inline -: ALUT_ERROR_CLOSE_DEVICE ( -- number ) HEX: 208 ; inline -: ALUT_ERROR_CREATE_CONTEXT ( -- number ) HEX: 209 ; inline -: ALUT_ERROR_MAKE_CONTEXT_CURRENT ( -- number ) HEX: 20A ; inline -: ALUT_ERROR_DESTRY_CONTEXT ( -- number ) HEX: 20B ; inline -: ALUT_ERROR_GEN_BUFFERS ( -- number ) HEX: 20C ; inline -: ALUT_ERROR_BUFFER_DATA ( -- number ) HEX: 20D ; inline -: ALUT_ERROR_IO_ERROR ( -- number ) HEX: 20E ; inline -: ALUT_ERROR_UNSUPPORTED_FILE_TYPE ( -- number ) HEX: 20F ; inline -: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE ( -- number ) HEX: 210 ; inline -: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA ( -- number ) HEX: 211 ; inline -: ALUT_WAVEFORM_SINE ( -- number ) HEX: 100 ; inline -: ALUT_WAVEFORM_SQUARE ( -- number ) HEX: 101 ; inline -: ALUT_WAVEFORM_SAWTOOTH ( -- number ) HEX: 102 ; inline -: ALUT_WAVEFORM_WHITENOISE ( -- number ) HEX: 103 ; inline -: ALUT_WAVEFORM_IMPULSE ( -- number ) HEX: 104 ; inline -: ALUT_LOADER_BUFFER ( -- number ) HEX: 300 ; inline -: ALUT_LOADER_MEMORY ( -- number ) HEX: 301 ; inline +CONSTANT: ALUT_API_MAJOR_VERSION 1 +CONSTANT: ALUT_API_MINOR_VERSION 1 +CONSTANT: ALUT_ERROR_NO_ERROR 0 +CONSTANT: ALUT_ERROR_OUT_OF_MEMORY HEX: 200 +CONSTANT: ALUT_ERROR_INVALID_ENUM HEX: 201 +CONSTANT: ALUT_ERROR_INVALID_VALUE HEX: 202 +CONSTANT: ALUT_ERROR_INVALID_OPERATION HEX: 203 +CONSTANT: ALUT_ERROR_NO_CURRENT_CONTEXT HEX: 204 +CONSTANT: ALUT_ERROR_AL_ERROR_ON_ENTRY HEX: 205 +CONSTANT: ALUT_ERROR_ALC_ERROR_ON_ENTRY HEX: 206 +CONSTANT: ALUT_ERROR_OPEN_DEVICE HEX: 207 +CONSTANT: ALUT_ERROR_CLOSE_DEVICE HEX: 208 +CONSTANT: ALUT_ERROR_CREATE_CONTEXT HEX: 209 +CONSTANT: ALUT_ERROR_MAKE_CONTEXT_CURRENT HEX: 20A +CONSTANT: ALUT_ERROR_DESTRY_CONTEXT HEX: 20B +CONSTANT: ALUT_ERROR_GEN_BUFFERS HEX: 20C +CONSTANT: ALUT_ERROR_BUFFER_DATA HEX: 20D +CONSTANT: ALUT_ERROR_IO_ERROR HEX: 20E +CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_TYPE HEX: 20F +CONSTANT: ALUT_ERROR_UNSUPPORTED_FILE_SUBTYPE HEX: 210 +CONSTANT: ALUT_ERROR_CORRUPT_OR_TRUNCATED_DATA HEX: 211 +CONSTANT: ALUT_WAVEFORM_SINE HEX: 100 +CONSTANT: ALUT_WAVEFORM_SQUARE HEX: 101 +CONSTANT: ALUT_WAVEFORM_SAWTOOTH HEX: 102 +CONSTANT: ALUT_WAVEFORM_WHITENOISE HEX: 103 +CONSTANT: ALUT_WAVEFORM_IMPULSE HEX: 104 +CONSTANT: ALUT_LOADER_BUFFER HEX: 300 +CONSTANT: ALUT_LOADER_MEMORY HEX: 301 FUNCTION: ALboolean alutInit ( int* argcp, char** argv ) ; FUNCTION: ALboolean alutInitWithoutContext ( int* argcp, char** argv ) ; @@ -234,37 +234,37 @@ FUNCTION: void alutUnloadWAV ( ALenum format, void* data, ALsizei size, ALsizei SYMBOL: init : init-openal ( -- ) - init get-global expired? [ - f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when - 1337 init set-global - ] when ; + init get-global expired? [ + f f alutInit 0 = [ "Could not initialize OpenAL" throw ] when + 1337 init set-global + ] when ; : exit-openal ( -- ) - init get-global expired? [ - alutExit 0 = [ "Could not close OpenAL" throw ] when - f init set-global - ] unless ; + init get-global expired? [ + alutExit 0 = [ "Could not close OpenAL" throw ] when + f init set-global + ] unless ; : ( n -- byte-array ) "ALuint" ; : gen-sources ( size -- seq ) - dup 2dup underlying>> alGenSources swap ; + dup 2dup underlying>> alGenSources swap ; : gen-buffers ( size -- seq ) - dup 2dup underlying>> alGenBuffers swap ; + dup 2dup underlying>> alGenBuffers swap ; : gen-buffer ( -- buffer ) 1 gen-buffers first ; : create-buffer-from-file ( filename -- buffer ) - alutCreateBufferFromFile dup AL_NONE = [ - "create-buffer-from-file failed" throw - ] when ; + alutCreateBufferFromFile dup AL_NONE = [ + "create-buffer-from-file failed" throw + ] when ; os macosx? "openal.macosx" "openal.other" ? require : create-buffer-from-wav ( filename -- buffer ) - gen-buffer dup rot load-wav-file - [ alBufferData ] 4keep alutUnloadWAV ; + gen-buffer dup rot load-wav-file + [ alBufferData ] 4keep alutUnloadWAV ; : queue-buffers ( source buffers -- ) [ length ] [ >uint-array underlying>> ] bi alSourceQueueBuffers ; @@ -273,29 +273,27 @@ os macosx? "openal.macosx" "openal.other" ? require 1array queue-buffers ; : set-source-param ( source param value -- ) - alSourcei ; + alSourcei ; : get-source-param ( source param -- value ) - 0 dup >r alGetSourcei r> *uint ; + 0 dup [ alGetSourcei ] dip *uint ; : set-buffer-param ( source param value -- ) - alBufferi ; + alBufferi ; : get-buffer-param ( source param -- value ) - 0 dup >r alGetBufferi r> *uint ; + 0 dup [ alGetBufferi ] dip *uint ; -: source-play ( source -- ) - alSourcePlay ; +: source-play ( source -- ) alSourcePlay ; -: source-stop ( source -- ) - alSourceStop ; +: source-stop ( source -- ) alSourceStop ; : check-error ( -- ) - alGetError dup ALUT_ERROR_NO_ERROR = [ - drop - ] [ - alGetString throw - ] if ; + alGetError dup ALUT_ERROR_NO_ERROR = [ + drop + ] [ + alGetString throw + ] if ; : source-playing? ( source -- bool ) - AL_SOURCE_STATE get-source-param AL_PLAYING = ; + AL_SOURCE_STATE get-source-param AL_PLAYING = ; diff --git a/vm/ffi_test.c b/vm/ffi_test.c index 1ec41ac2b9..a5a43cf2ae 100755 --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -1,6 +1,5 @@ /* This file is linked into the runtime for the sole purpose * of testing FFI code. */ -#include #include "master.h" #include "ffi_test.h" @@ -303,3 +302,18 @@ struct test_struct_14 ffi_test_44(void) retval.x2 = 2.0; return retval; } + +_Complex float ffi_test_45(int x) +{ + return x; +} + +_Complex double ffi_test_46(int x) +{ + return x; +} + +_Complex float ffi_test_47(_Complex float x, _Complex double y) +{ + return x + 2 * y; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h index 7c51261157..f8634b304e 100755 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -88,3 +88,9 @@ struct test_struct_16 { float x; int a; }; DLLEXPORT struct test_struct_16 ffi_test_43(float x, int a); DLLEXPORT struct test_struct_14 ffi_test_44(); + +DLLEXPORT _Complex float ffi_test_45(int x); + +DLLEXPORT _Complex double ffi_test_46(int x); + +DLLEXPORT _Complex float ffi_test_47(_Complex float x, _Complex double y); diff --git a/vm/io.h b/vm/io.h index 08c9dd7807..dc7d69edee 100755 --- a/vm/io.h +++ b/vm/io.h @@ -1,7 +1,7 @@ void init_c_io(void); void io_error(void); -int err_no(void); -void clear_err_no(void); +DLLEXPORT int err_no(void); +DLLEXPORT void clear_err_no(void); void primitive_fopen(void); void primitive_fgetc(void); diff --git a/vm/math.c b/vm/math.c index f0aa874886..7bff0de387 100644 --- a/vm/math.c +++ b/vm/math.c @@ -530,8 +530,8 @@ void box_double(double flo) void primitive_from_rect(void) { - F_COMPLEX* complex = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); - complex->imaginary = dpop(); - complex->real = dpop(); - dpush(RETAG(complex,COMPLEX_TYPE)); + F_COMPLEX* z = allot_object(COMPLEX_TYPE,sizeof(F_COMPLEX)); + z->imaginary = dpop(); + z->real = dpop(); + dpush(RETAG(z,COMPLEX_TYPE)); } diff --git a/vm/os-unix.c b/vm/os-unix.c index b49f7637af..97c29d8c6e 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -36,7 +36,7 @@ void init_ffi(void) 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)