From 5a01439038ecc070090f01fa824275eca215f2e9 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Mon, 30 Jun 2008 19:11:43 -0700 Subject: [PATCH 01/77] Fix integer>bit-array to work with zero as argument --- core/bit-arrays/bit-arrays-tests.factor | 2 ++ core/bit-arrays/bit-arrays.factor | 14 ++++++++------ 2 files changed, 10 insertions(+), 6 deletions(-) diff --git a/core/bit-arrays/bit-arrays-tests.factor b/core/bit-arrays/bit-arrays-tests.factor index b41cf9c4a5..dfad9d951a 100755 --- a/core/bit-arrays/bit-arrays-tests.factor +++ b/core/bit-arrays/bit-arrays-tests.factor @@ -54,6 +54,7 @@ IN: bit-arrays.tests [ -10 ?{ } resize-bit-array ] must-fail [ -1 integer>bit-array ] must-fail +[ ?{ } ] [ 0 integer>bit-array ] unit-test [ ?{ f t } ] [ 2 integer>bit-array ] unit-test [ ?{ t t t t t t t t t } ] [ 511 integer>bit-array ] unit-test [ ?{ @@ -66,6 +67,7 @@ IN: bit-arrays.tests ] unit-test [ 14 ] [ ?{ f t t t } bit-array>integer ] unit-test +[ 0 ] [ ?{ } bit-array>integer ] unit-test [ HEX: ffffffffffffffffffffffffffffffff ] [ ?{ t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t diff --git a/core/bit-arrays/bit-arrays.factor b/core/bit-arrays/bit-arrays.factor index 4446bb5556..adbd91e66a 100755 --- a/core/bit-arrays/bit-arrays.factor +++ b/core/bit-arrays/bit-arrays.factor @@ -52,12 +52,14 @@ M: bit-array resize resize-bit-array ; : integer>bit-array ( int -- bit-array ) - [ log2 1+ 0 ] keep - [ dup zero? not ] [ - [ -8 shift ] [ 255 bitand ] bi - -roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip - ] [ ] while - 2drop ; + dup zero? [ drop ?{ } ] [ + [ log2 1+ 0 ] keep + [ dup zero? not ] [ + [ -8 shift ] [ 255 bitand ] bi + -roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip + ] [ ] while + 2drop + ] if ; : bit-array>integer ( bit-array -- int ) dup >r length 7 + n>byte 0 r> [ From 11b721c90c9eb185d83e5a4cde94f33e63f3c292 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Tue, 1 Jul 2008 22:00:22 -0700 Subject: [PATCH 02/77] CBLAS library bindings. Factor-ish bindings to better part of level 1 BLAS in math.blas.vectors. Syntax for building BLAS vectors in math.blas.syntax --- extra/math/blas/cblas/authors.txt | 1 + extra/math/blas/cblas/cblas.factor | 557 +++++++++++++++++++ extra/math/blas/cblas/summary.txt | 1 + extra/math/blas/cblas/tags.txt | 2 + extra/math/blas/syntax/authors.txt | 1 + extra/math/blas/syntax/summary.txt | 1 + extra/math/blas/syntax/syntax.factor | 12 + extra/math/blas/syntax/tags.txt | 1 + extra/math/blas/vectors/authors.txt | 1 + extra/math/blas/vectors/summary.txt | 1 + extra/math/blas/vectors/tags.txt | 1 + extra/math/blas/vectors/vectors-tests.factor | 173 ++++++ extra/math/blas/vectors/vectors.factor | 273 +++++++++ 13 files changed, 1025 insertions(+) create mode 100644 extra/math/blas/cblas/authors.txt create mode 100644 extra/math/blas/cblas/cblas.factor create mode 100644 extra/math/blas/cblas/summary.txt create mode 100644 extra/math/blas/cblas/tags.txt create mode 100644 extra/math/blas/syntax/authors.txt create mode 100644 extra/math/blas/syntax/summary.txt create mode 100644 extra/math/blas/syntax/syntax.factor create mode 100644 extra/math/blas/syntax/tags.txt create mode 100644 extra/math/blas/vectors/authors.txt create mode 100644 extra/math/blas/vectors/summary.txt create mode 100644 extra/math/blas/vectors/tags.txt create mode 100644 extra/math/blas/vectors/vectors-tests.factor create mode 100644 extra/math/blas/vectors/vectors.factor diff --git a/extra/math/blas/cblas/authors.txt b/extra/math/blas/cblas/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/math/blas/cblas/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/math/blas/cblas/cblas.factor b/extra/math/blas/cblas/cblas.factor new file mode 100644 index 0000000000..266972fc99 --- /dev/null +++ b/extra/math/blas/cblas/cblas.factor @@ -0,0 +1,557 @@ +USING: alien alien.c-types alien.syntax kernel system combinators ; +IN: math.blas.cblas + +<< "cblas" { + { [ os macosx? ] [ "libcblas.dylib" "cdecl" add-library ] } + { [ os windows? ] [ "cblas.dll" "cdecl" add-library ] } + [ drop "libcblas.so" "cdecl" add-library ] +} cond >> + +LIBRARY: cblas + +TYPEDEF: int CBLAS_ORDER +: CblasRowMajor 101 ; inline +: CblasColMajor 102 ; inline + +TYPEDEF: int CBLAS_TRANSPOSE +: CblasNoTrans 111 ; inline +: CblasTrans 112 ; inline +: CblasConjTrans 113 ; inline + +TYPEDEF: int CBLAS_UPLO +: CblasUpper 121 ; inline +: CblasLower 122 ; inline + +TYPEDEF: int CBLAS_DIAG +: CblasNonUnit 131 ; inline +: CblasUnit 132 ; inline + +TYPEDEF: int CBLAS_SIDE +: CblasLeft 141 ; inline +: CblasRight 142 ; inline + +TYPEDEF: int CBLAS_INDEX + +C-STRUCT: CBLAS_C + { "float" "real" } + { "float" "imag" } ; +C-STRUCT: CBLAS_Z + { "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, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotu ) ; +FUNCTION: void cblas_cdotc_sub + ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY, CBLAS_C* dotc ) ; + +FUNCTION: void cblas_zdotu_sub + ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* dotu ) ; +FUNCTION: void cblas_zdotc_sub + ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY, CBLAS_Z* 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, CBLAS_C* X, int incX ) ; +FUNCTION: float cblas_scasum + ( int N, CBLAS_C* X, int incX ) ; + +FUNCTION: double cblas_dznrm2 + ( int N, CBLAS_Z* X, int incX ) ; +FUNCTION: double cblas_dzasum + ( int N, CBLAS_Z* 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, CBLAS_C* X, int incX ) ; +FUNCTION: CBLAS_INDEX cblas_izamax + ( int N, CBLAS_Z* 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, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ; +FUNCTION: void cblas_ccopy + ( int N, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ; +FUNCTION: void cblas_caxpy + ( int N, CBLAS_C* alpha, CBLAS_C* X, int incX, CBLAS_C* Y, int incY ) ; + +FUNCTION: void cblas_zswap + ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ; +FUNCTION: void cblas_zcopy + ( int N, CBLAS_Z* X, int incX, CBLAS_Z* Y, int incY ) ; +FUNCTION: void cblas_zaxpy + ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX, CBLAS_Z* 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, CBLAS_C* alpha, CBLAS_C* X, int incX ) ; +FUNCTION: void cblas_zscal + ( int N, CBLAS_Z* alpha, CBLAS_Z* X, int incX ) ; +FUNCTION: void cblas_csscal + ( int N, float alpha, CBLAS_C* X, int incX ) ; +FUNCTION: void cblas_zdscal + ( int N, double alpha, CBLAS_Z* 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/extra/math/blas/cblas/summary.txt b/extra/math/blas/cblas/summary.txt new file mode 100644 index 0000000000..c72e78eb0d --- /dev/null +++ b/extra/math/blas/cblas/summary.txt @@ -0,0 +1 @@ +Low-level bindings to the C Basic Linear Algebra Subroutines (BLAS) library diff --git a/extra/math/blas/cblas/tags.txt b/extra/math/blas/cblas/tags.txt new file mode 100644 index 0000000000..241ec1ecda --- /dev/null +++ b/extra/math/blas/cblas/tags.txt @@ -0,0 +1,2 @@ +math +bindings diff --git a/extra/math/blas/syntax/authors.txt b/extra/math/blas/syntax/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/math/blas/syntax/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/math/blas/syntax/summary.txt b/extra/math/blas/syntax/summary.txt new file mode 100644 index 0000000000..a71bebb50f --- /dev/null +++ b/extra/math/blas/syntax/summary.txt @@ -0,0 +1 @@ +Literal syntax for BLAS vectors and matrices diff --git a/extra/math/blas/syntax/syntax.factor b/extra/math/blas/syntax/syntax.factor new file mode 100644 index 0000000000..d161739d80 --- /dev/null +++ b/extra/math/blas/syntax/syntax.factor @@ -0,0 +1,12 @@ +USING: kernel math.blas.vectors parser prettyprint.backend ; +IN: math.blas.syntax + +: svector{ ( accum -- accum ) + \ } [ >float-blas-vector ] parse-literal ; parsing +: dvector{ ( accum -- accum ) + \ } [ >double-blas-vector ] parse-literal ; parsing +: cvector{ ( accum -- accum ) + \ } [ >float-complex-blas-vector ] parse-literal ; parsing +: zvector{ ( accum -- accum ) + \ } [ >double-complex-blas-vector ] parse-literal ; parsing + diff --git a/extra/math/blas/syntax/tags.txt b/extra/math/blas/syntax/tags.txt new file mode 100644 index 0000000000..ede10ab61b --- /dev/null +++ b/extra/math/blas/syntax/tags.txt @@ -0,0 +1 @@ +math diff --git a/extra/math/blas/vectors/authors.txt b/extra/math/blas/vectors/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/math/blas/vectors/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/math/blas/vectors/summary.txt b/extra/math/blas/vectors/summary.txt new file mode 100644 index 0000000000..91653e0938 --- /dev/null +++ b/extra/math/blas/vectors/summary.txt @@ -0,0 +1 @@ +Basic Linear Algebra words for accelerated vector and matrix math diff --git a/extra/math/blas/vectors/tags.txt b/extra/math/blas/vectors/tags.txt new file mode 100644 index 0000000000..ede10ab61b --- /dev/null +++ b/extra/math/blas/vectors/tags.txt @@ -0,0 +1 @@ +math diff --git a/extra/math/blas/vectors/vectors-tests.factor b/extra/math/blas/vectors/vectors-tests.factor new file mode 100644 index 0000000000..e059d2943d --- /dev/null +++ b/extra/math/blas/vectors/vectors-tests.factor @@ -0,0 +1,173 @@ +USING: kernel math.blas.vectors math.blas.syntax sequences tools.test ; +IN: math.blas.vectors.tests + +! clone + +[ svector{ 1.0 2.0 3.0 } ] [ svector{ 1.0 2.0 3.0 } clone ] unit-test +[ f ] [ svector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test +[ dvector{ 1.0 2.0 3.0 } ] [ dvector{ 1.0 2.0 3.0 } clone ] unit-test +[ f ] [ dvector{ 1.0 2.0 3.0 } dup clone eq? ] unit-test +[ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test +[ f ] [ cvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test +[ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } clone ] unit-test +[ f ] [ zvector{ 1.0 C{ 2.0 3.0 } 4.0 } dup clone eq? ] unit-test + +! nth + +[ 1.0 ] [ 2 svector{ 3.0 2.0 1.0 } nth ] unit-test +[ 1.0 ] [ 2 dvector{ 3.0 2.0 1.0 } nth ] unit-test + +[ C{ 1.0 2.0 } ] +[ 2 cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test + +[ C{ 1.0 2.0 } ] +[ 2 zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } nth ] unit-test + +! set-nth + +[ svector{ 3.0 2.0 0.0 } ] [ 0.0 2 svector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test +[ dvector{ 3.0 2.0 0.0 } ] [ 0.0 2 dvector{ 3.0 2.0 1.0 } [ set-nth ] keep ] unit-test + +[ cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [ + C{ 3.0 4.0 } 2 + cvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } + [ set-nth ] keep +] unit-test +[ zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 3.0 4.0 } } ] [ + C{ 3.0 4.0 } 2 + zvector{ C{ -3.0 -2.0 } C{ -1.0 0.0 } C{ 1.0 2.0 } } + [ set-nth ] keep +] unit-test + +! V+ + +[ svector{ 11.0 22.0 } ] [ svector{ 1.0 2.0 } svector{ 10.0 20.0 } V+ ] unit-test +[ dvector{ 11.0 22.0 } ] [ dvector{ 1.0 2.0 } dvector{ 10.0 20.0 } V+ ] unit-test + +[ cvector{ 11.0 C{ 22.0 33.0 } } ] +[ cvector{ 1.0 C{ 2.0 3.0 } } cvector{ 10.0 C{ 20.0 30.0 } } V+ ] +unit-test + +[ zvector{ 11.0 C{ 22.0 33.0 } } ] +[ zvector{ 1.0 C{ 2.0 3.0 } } zvector{ 10.0 C{ 20.0 30.0 } } V+ ] +unit-test + +! V- + +[ svector{ 9.0 18.0 } ] [ svector{ 10.0 20.0 } svector{ 1.0 2.0 } V- ] unit-test +[ dvector{ 9.0 18.0 } ] [ dvector{ 10.0 20.0 } dvector{ 1.0 2.0 } V- ] unit-test + +[ cvector{ 9.0 C{ 18.0 27.0 } } ] +[ cvector{ 10.0 C{ 20.0 30.0 } } cvector{ 1.0 C{ 2.0 3.0 } } V- ] +unit-test + +[ zvector{ 9.0 C{ 18.0 27.0 } } ] +[ zvector{ 10.0 C{ 20.0 30.0 } } zvector{ 1.0 C{ 2.0 3.0 } } V- ] +unit-test + +! Vneg + +[ svector{ 1.0 -2.0 } ] [ svector{ -1.0 2.0 } Vneg ] unit-test +[ dvector{ 1.0 -2.0 } ] [ dvector{ -1.0 2.0 } Vneg ] unit-test + +[ cvector{ 1.0 C{ -2.0 3.0 } } ] [ cvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test +[ zvector{ 1.0 C{ -2.0 3.0 } } ] [ zvector{ -1.0 C{ 2.0 -3.0 } } Vneg ] unit-test + +! n*V + +[ svector{ 100.0 200.0 } ] [ 10.0 svector{ 10.0 20.0 } n*V ] unit-test +[ dvector{ 100.0 200.0 } ] [ 10.0 dvector{ 10.0 20.0 } n*V ] unit-test + +[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ] +[ C{ 10.0 2.0 } cvector{ 2.0 C{ 1.0 1.0 } } n*V ] +unit-test + +[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ] +[ C{ 10.0 2.0 } zvector{ 2.0 C{ 1.0 1.0 } } n*V ] +unit-test + +! V*n + +[ svector{ 100.0 200.0 } ] [ svector{ 10.0 20.0 } 10.0 V*n ] unit-test +[ dvector{ 100.0 200.0 } ] [ dvector{ 10.0 20.0 } 10.0 V*n ] unit-test + +[ cvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ] +[ cvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ] +unit-test + +[ zvector{ C{ 20.0 4.0 } C{ 8.0 12.0 } } ] +[ zvector{ 2.0 C{ 1.0 1.0 } } C{ 10.0 2.0 } V*n ] +unit-test + +! V/n + +[ svector{ 1.0 2.0 } ] [ svector{ 4.0 8.0 } 4.0 V/n ] unit-test +[ dvector{ 1.0 2.0 } ] [ dvector{ 4.0 8.0 } 4.0 V/n ] unit-test + +[ cvector{ 2.0 1.0 } ] +[ cvector{ C{ 16.0 4.0 } C{ 8.0 2.0 } } C{ 8.0 2.0 } V/n ] +unit-test + +[ cvector{ 2.0 1.0 } ] +[ cvector{ C{ 16.0 4.0 } C{ 8.0 2.0 } } C{ 8.0 2.0 } V/n ] +unit-test + +! V. + +[ 7.0 ] [ svector{ 1.0 2.5 } svector{ 2.0 2.0 } V. ] unit-test +[ 7.0 ] [ dvector{ 1.0 2.5 } dvector{ 2.0 2.0 } V. ] unit-test +[ C{ 7.0 7.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test +[ C{ 7.0 7.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V. ] unit-test + +! V.conj + +[ C{ 7.0 3.0 } ] [ cvector{ C{ 1.0 1.0 } 2.5 } cvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test +[ C{ 7.0 3.0 } ] [ zvector{ C{ 1.0 1.0 } 2.5 } zvector{ 2.0 C{ 2.0 2.0 } } V.conj ] unit-test + +! Vnorm + +[ 5.0 ] [ svector{ 3.0 4.0 } Vnorm ] unit-test +[ 5.0 ] [ dvector{ 3.0 4.0 } Vnorm ] unit-test + +[ 13.0 ] [ cvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test +[ 13.0 ] [ zvector{ C{ 3.0 4.0 } 12.0 } Vnorm ] unit-test + +! Vasum + +[ 6.0 ] [ svector{ 1.0 2.0 -3.0 } Vasum ] unit-test +[ 6.0 ] [ dvector{ 1.0 2.0 -3.0 } Vasum ] unit-test + +[ 15.0 ] [ cvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test +[ 15.0 ] [ zvector{ 1.0 C{ -2.0 3.0 } C{ 4.0 -5.0 } } Vasum ] unit-test + +! Vswap + +[ svector{ 2.0 2.0 } svector{ 1.0 1.0 } ] +[ svector{ 1.0 1.0 } svector{ 2.0 2.0 } Vswap ] +unit-test + +[ dvector{ 2.0 2.0 } dvector{ 1.0 1.0 } ] +[ dvector{ 1.0 1.0 } dvector{ 2.0 2.0 } Vswap ] +unit-test + +[ cvector{ 2.0 C{ 2.0 2.0 } } cvector{ C{ 1.0 1.0 } 1.0 } ] +[ cvector{ C{ 1.0 1.0 } 1.0 } cvector{ 2.0 C{ 2.0 2.0 } } Vswap ] +unit-test + +[ zvector{ 2.0 C{ 2.0 2.0 } } zvector{ C{ 1.0 1.0 } 1.0 } ] +[ zvector{ C{ 1.0 1.0 } 1.0 } zvector{ 2.0 C{ 2.0 2.0 } } Vswap ] +unit-test + +! Viamax + +[ 3 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test +[ 3 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Viamax ] unit-test +[ 0 ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test +[ 0 ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Viamax ] unit-test + +! Vamax + +[ -6.0 ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test +[ -6.0 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test +[ C{ 2.0 -5.0 } ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test +[ C{ 2.0 -5.0 } ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor new file mode 100644 index 0000000000..bec1daa855 --- /dev/null +++ b/extra/math/blas/vectors/vectors.factor @@ -0,0 +1,273 @@ +USING: accessors alien alien.c-types arrays byte-arrays fry +kernel macros math math.blas.cblas math.complex math.functions +math.order multi-methods qualified sequences sequences.private +shuffle ; +QUALIFIED: syntax +IN: math.blas.vectors + +TUPLE: blas-vector-base data length inc ; +TUPLE: float-blas-vector < blas-vector-base ; +TUPLE: double-blas-vector < blas-vector-base ; +TUPLE: float-complex-blas-vector < blas-vector-base ; +TUPLE: double-complex-blas-vector < blas-vector-base ; + +INSTANCE: float-blas-vector sequence +INSTANCE: double-blas-vector sequence +INSTANCE: float-complex-blas-vector sequence +INSTANCE: double-complex-blas-vector sequence + +C: float-blas-vector +C: double-blas-vector +C: float-complex-blas-vector +C: double-complex-blas-vector + +GENERIC: zero-vector ( v -- zero ) + +GENERIC: n*V+V-in-place ( n v1 v2 -- v2=n*v1+v2 ) +GENERIC: n*V-in-place ( n v -- v=n*v ) + +GENERIC: V. ( v1 v2 -- v1.v2 ) +GENERIC: V.conj ( v1 v2 -- v1^H.v2 ) +GENERIC: Vnorm ( v -- norm ) +GENERIC: Vasum ( v -- abs-sum ) +GENERIC: Vswap ( v1 v2 -- v1=v2 v2=v1 ) + +GENERIC: Viamax ( v -- abs-max-index ) + +> ] [ data>> ] [ inc>> ] tri ] dip + 4 npick * + 1 ; + +MACRO: (do-copy) ( copy make-vector -- ) + '[ over 6 npick , 2dip 1 @ ] ; + +: (prepare-swap) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc v1 v2 ) + [ + [ [ length>> ] bi@ min ] + [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi + ] 2keep ; + +: (prepare-axpy) ( n v1 v2 -- length n v1-data v1-inc v2-data v2-inc v2 ) + [ + [ [ length>> ] bi@ min swap ] + [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi + ] keep ; + +: (prepare-scal) ( n v -- length n v-data v-inc v ) + [ [ length>> swap ] [ data>> ] [ inc>> ] tri ] keep ; + +: (prepare-dot) ( v1 v2 -- length v1-data v1-inc v2-data v2-inc ) + [ [ length>> ] bi@ min ] + [ [ [ data>> ] [ inc>> ] bi ] bi@ ] 2bi ; + +: (prepare-nrm2) ( v -- length v1-data v1-inc ) + [ length>> ] [ data>> ] [ inc>> ] tri ; + +: (flatten-complex-sequence) ( seq -- seq' ) + [ [ real-part ] [ imaginary-part ] bi 2array ] map concat ; + +: (>c-complex) ( complex -- alien ) + [ real-part ] [ imaginary-part ] bi 2array >c-float-array ; +: (>z-complex) ( complex -- alien ) + [ real-part ] [ imaginary-part ] bi 2array >c-double-array ; + +: (c-complex>) ( alien -- complex ) + 2 c-float-array> first2 rect> ; +: (z-complex>) ( alien -- complex ) + 2 c-double-array> first2 rect> ; + +: (prepare-nth) ( n v -- n*inc v-data ) + [ inc>> ] [ data>> ] bi [ * ] dip ; + +MACRO: (complex-nth) ( nth-quot -- ) + '[ + [ 2 * dup 1+ ] dip + , curry bi@ rect> + ] ; + +: (c-complex-nth) ( n alien -- complex ) + [ float-nth ] (complex-nth) ; +: (z-complex-nth) ( n alien -- complex ) + [ double-nth ] (complex-nth) ; + +MACRO: (set-complex-nth) ( set-nth-quot -- ) + '[ + [ + [ [ real-part ] [ imaginary-part ] bi ] + [ 2 * dup 1+ ] bi* + swapd + ] dip + , curry 2bi@ + ] ; + +: (set-c-complex-nth) ( complex n alien -- ) + [ set-float-nth ] (set-complex-nth) ; +: (set-z-complex-nth) ( complex n alien -- ) + [ set-double-nth ] (set-complex-nth) ; + +PRIVATE> + +METHOD: zero-vector { float-blas-vector } + length>> 0.0 swap 0 ; +METHOD: zero-vector { double-blas-vector } + length>> 0.0 swap 0 ; +METHOD: zero-vector { float-complex-blas-vector } + length>> "CBLAS_C" swap 0 ; +METHOD: zero-vector { double-complex-blas-vector } + length>> "CBLAS_Z" swap 0 ; + +syntax:M: blas-vector-base length + length>> ; + +syntax:M: float-blas-vector nth-unsafe + (prepare-nth) float-nth ; +syntax:M: float-blas-vector set-nth-unsafe + (prepare-nth) set-float-nth ; + +syntax:M: double-blas-vector nth-unsafe + (prepare-nth) double-nth ; +syntax:M: double-blas-vector set-nth-unsafe + (prepare-nth) set-double-nth ; + +syntax:M: float-complex-blas-vector nth-unsafe + (prepare-nth) (c-complex-nth) ; +syntax:M: float-complex-blas-vector set-nth-unsafe + (prepare-nth) (set-c-complex-nth) ; + +syntax:M: double-complex-blas-vector nth-unsafe + (prepare-nth) (z-complex-nth) ; +syntax:M: double-complex-blas-vector set-nth-unsafe + (prepare-nth) (set-z-complex-nth) ; + +: >float-blas-vector ( seq -- v ) + [ >c-float-array ] [ length ] bi 1 ; +: >double-blas-vector ( seq -- v ) + [ >c-double-array ] [ length ] bi 1 ; +: >float-complex-blas-vector ( seq -- v ) + [ (flatten-complex-sequence) >c-float-array ] [ length ] bi 1 ; +: >double-complex-blas-vector ( seq -- v ) + [ (flatten-complex-sequence) >c-double-array ] [ length ] bi 1 ; + +syntax:M: float-blas-vector clone + "float" heap-size (prepare-copy) + [ cblas_scopy ] [ ] (do-copy) ; +syntax:M: double-blas-vector clone + "double" heap-size (prepare-copy) + [ cblas_dcopy ] [ ] (do-copy) ; +syntax:M: float-complex-blas-vector clone + "CBLAS_C" heap-size (prepare-copy) + [ cblas_ccopy ] [ ] (do-copy) ; +syntax:M: double-complex-blas-vector clone + "CBLAS_Z" heap-size (prepare-copy) + [ cblas_zcopy ] [ ] (do-copy) ; + +METHOD: Vswap { float-blas-vector float-blas-vector } + (prepare-swap) [ cblas_sswap ] 2dip ; +METHOD: Vswap { double-blas-vector double-blas-vector } + (prepare-swap) [ cblas_dswap ] 2dip ; +METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector } + (prepare-swap) [ cblas_cswap ] 2dip ; +METHOD: Vswap { double-complex-blas-vector double-complex-blas-vector } + (prepare-swap) [ cblas_zswap ] 2dip ; + +METHOD: n*V+V-in-place { real float-blas-vector float-blas-vector } + (prepare-axpy) [ cblas_saxpy ] dip ; +METHOD: n*V+V-in-place { real double-blas-vector double-blas-vector } + (prepare-axpy) [ cblas_daxpy ] dip ; +METHOD: n*V+V-in-place { number float-complex-blas-vector float-complex-blas-vector } + [ (>c-complex) ] 2dip + (prepare-axpy) [ cblas_caxpy ] dip ; +METHOD: n*V+V-in-place { number double-complex-blas-vector double-complex-blas-vector } + [ (>z-complex) ] 2dip + (prepare-axpy) [ cblas_zaxpy ] dip ; + +METHOD: n*V-in-place { real float-blas-vector } + (prepare-scal) [ cblas_sscal ] dip ; +METHOD: n*V-in-place { real double-blas-vector } + (prepare-scal) [ cblas_dscal ] dip ; +METHOD: n*V-in-place { number float-complex-blas-vector } + [ (>c-complex) ] dip + (prepare-scal) [ cblas_cscal ] dip ; +METHOD: n*V-in-place { number double-complex-blas-vector } + [ (>z-complex) ] dip + (prepare-scal) [ cblas_zscal ] dip ; + + + +: n*V+V ( n v1 v2 -- n*v1+v2 ) clone n*V+V-in-place ; +: n*V ( n v1 -- n*v1 ) clone n*V-in-place ; + +: V+ ( v1 v2 -- v1+v2 ) + 1.0 -rot n*V+V ; +: V- ( v1 v2 -- v1+v2 ) + -1.0 spin n*V+V ; + +: Vneg ( v1 -- -v1 ) + [ zero-vector ] keep V- ; + +: V*n ( v n -- v*n ) + swap n*V ; +: V/n ( v n -- v*n ) + recip swap n*V ; + +METHOD: V. { float-blas-vector float-blas-vector } + (prepare-dot) cblas_sdot ; +METHOD: V. { double-blas-vector double-blas-vector } + (prepare-dot) cblas_ddot ; +METHOD: V. { float-complex-blas-vector float-complex-blas-vector } + (prepare-dot) + "CBLAS_C" [ cblas_cdotu_sub ] keep (c-complex>) ; +METHOD: V. { double-complex-blas-vector double-complex-blas-vector } + (prepare-dot) + "CBLAS_Z" [ cblas_zdotu_sub ] keep (z-complex>) ; + +METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector } + (prepare-dot) + "CBLAS_C" [ cblas_cdotc_sub ] keep (c-complex>) ; +METHOD: V.conj { double-complex-blas-vector double-complex-blas-vector } + (prepare-dot) + "CBLAS_Z" [ cblas_zdotc_sub ] keep (z-complex>) ; + +METHOD: Vnorm { float-blas-vector } + (prepare-nrm2) cblas_snrm2 ; +METHOD: Vnorm { double-blas-vector } + (prepare-nrm2) cblas_dnrm2 ; +METHOD: Vnorm { float-complex-blas-vector } + (prepare-nrm2) cblas_scnrm2 ; +METHOD: Vnorm { double-complex-blas-vector } + (prepare-nrm2) cblas_dznrm2 ; + +METHOD: Vasum { float-blas-vector } + (prepare-nrm2) cblas_sasum ; +METHOD: Vasum { double-blas-vector } + (prepare-nrm2) cblas_dasum ; +METHOD: Vasum { float-complex-blas-vector } + (prepare-nrm2) cblas_scasum ; +METHOD: Vasum { double-complex-blas-vector } + (prepare-nrm2) cblas_dzasum ; + +METHOD: Viamax { float-blas-vector } + (prepare-nrm2) cblas_isamax ; +METHOD: Viamax { double-blas-vector } + (prepare-nrm2) cblas_idamax ; +METHOD: Viamax { float-complex-blas-vector } + (prepare-nrm2) cblas_icamax ; +METHOD: Viamax { double-complex-blas-vector } + (prepare-nrm2) cblas_izamax ; + +: Vamax ( v -- max ) + [ Viamax ] keep nth ; From 340abc119a0bc073785b2546406780c1f22c5657 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 3 Jul 2008 21:13:10 -0700 Subject: [PATCH 03/77] Shorthand syntax for arrays-of-arrays, arrays-of-quotations, and hashtables --- extra/arrays/nested-syntax/authors.txt | 1 + .../nested-syntax/nested-syntax-docs.factor | 29 +++++++++++++++++++ .../nested-syntax/nested-syntax-tests.factor | 11 +++++++ .../arrays/nested-syntax/nested-syntax.factor | 10 +++++++ extra/arrays/nested-syntax/summary.txt | 1 + extra/arrays/nested-syntax/tags.txt | 1 + 6 files changed, 53 insertions(+) create mode 100644 extra/arrays/nested-syntax/authors.txt create mode 100644 extra/arrays/nested-syntax/nested-syntax-docs.factor create mode 100644 extra/arrays/nested-syntax/nested-syntax-tests.factor create mode 100644 extra/arrays/nested-syntax/nested-syntax.factor create mode 100644 extra/arrays/nested-syntax/summary.txt create mode 100644 extra/arrays/nested-syntax/tags.txt diff --git a/extra/arrays/nested-syntax/authors.txt b/extra/arrays/nested-syntax/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/arrays/nested-syntax/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/arrays/nested-syntax/nested-syntax-docs.factor b/extra/arrays/nested-syntax/nested-syntax-docs.factor new file mode 100644 index 0000000000..7933aa0882 --- /dev/null +++ b/extra/arrays/nested-syntax/nested-syntax-docs.factor @@ -0,0 +1,29 @@ +USING: help.markup help.syntax ; +IN: arrays.nested-syntax + +HELP: {{ +{ $syntax "{{ zim zang ;; zoop ;; zidilly zam ;; ... }}" } +{ $description "Shorthand for a literal array of arrays. Subarrays are separated by the " { $link POSTPONE: ;; } " token." } +{ $examples "The following blocks of code push an equivalent array onto the stack:" { $example "{{ 1 ;; 2 3 ;; 4 5 6 }}" } { $example "{ { 1 } { 2 3 } { 4 5 6 } }" } } ; + +HELP: H{{ +{ $syntax "H{{ zim zang ;; zoop zidilly ;; zam zung ;; ... }}" } +{ $description "Shorthand for a literal hashtable. Key-value pairs are separated by the " { $link POSTPONE: ;; } " token." } +{ $examples "The following blocks of code push an equivalent hash table onto the stack:" { $example "H{{ \"Monday\" 1 ;; \"Tuesday\" 2 ;; \"Wednesday\" 3 ;; \"Thursday\" 4 }}" } { $example "H{ { \"Monday\" 1 } { \"Tuesday\" 2 } { \"Wednesday\" 3 } { \"Thursday\" 4 } }" } } ; + +HELP: [[ +{ $syntax "[[ foo ;; bar bas ;; qux quux quuuux ;; ... ]]" } +{ $description "Shorthand for a literal array of quotations. Each quotation is separated by the " { $link POSTPONE: ;; } " token." } +{ $examples "The following blocks of code are equivalent:" { $example "[[ 1+ ;; 2 + ]] cleave" } { $example "{ [ 1+ ] [ 2 + ] } cleave" } } ; + +{ POSTPONE: {{ POSTPONE: H{{ POSTPONE: [[ } related-words + +HELP: ;; +{ $description "Separator token used in the " { $link POSTPONE: {{ } ", " { $link POSTPONE: H{{ } ", and " { $link POSTPONE: [[ } " literal syntaxes." } ; + +HELP: }} +{ $description "Delimiter token used to close the " { $link POSTPONE: {{ } " and " { $link POSTPONE: H{{ } " literal syntaxes." } ; + +HELP: ]] +{ $description "Delimiter token used to close the " { $link POSTPONE: [[ } " literal syntax." } ; + diff --git a/extra/arrays/nested-syntax/nested-syntax-tests.factor b/extra/arrays/nested-syntax/nested-syntax-tests.factor new file mode 100644 index 0000000000..a709840be4 --- /dev/null +++ b/extra/arrays/nested-syntax/nested-syntax-tests.factor @@ -0,0 +1,11 @@ +USING: arrays.nested-syntax kernel tools.test ; +IN: arrays.nested-syntax.tests + +[ { { 1 } { 2 3 } { 4 5 6 } } ] +[ {{ 1 ;; 2 3 ;; 4 5 6 }} ] unit-test + +[ H{ { "foo" 1 } { "bar" 2 } { "bas" 3 } } ] +[ H{{ "foo" 1 ;; "bar" 2 ;; "bas" 3 }} ] unit-test + +[ { [ drop ] [ nip ] } ] +[ [[ drop ;; nip ]] ] unit-test diff --git a/extra/arrays/nested-syntax/nested-syntax.factor b/extra/arrays/nested-syntax/nested-syntax.factor new file mode 100644 index 0000000000..9fae0fba9f --- /dev/null +++ b/extra/arrays/nested-syntax/nested-syntax.factor @@ -0,0 +1,10 @@ +USING: arrays hashtables kernel parser quotations sequences splitting ; +IN: arrays.nested-syntax + +: ;; ( -- * ) ";; can only be used in [[ ]] , {{ }} , or H{{ }} blocks" throw ; +DEFER: ]] delimiter +DEFER: }} delimiter + +: [[ \ ]] [ { POSTPONE: ;; } split [ >quotation ] map ] parse-literal ; parsing +: {{ \ }} [ { POSTPONE: ;; } split [ >array ] map ] parse-literal ; parsing +: H{{ \ }} [ { POSTPONE: ;; } split >hashtable ] parse-literal ; parsing diff --git a/extra/arrays/nested-syntax/summary.txt b/extra/arrays/nested-syntax/summary.txt new file mode 100644 index 0000000000..a8d507f2ca --- /dev/null +++ b/extra/arrays/nested-syntax/summary.txt @@ -0,0 +1 @@ +Shorthand syntax for defining arrays of quotations or arrays of arrays diff --git a/extra/arrays/nested-syntax/tags.txt b/extra/arrays/nested-syntax/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/extra/arrays/nested-syntax/tags.txt @@ -0,0 +1 @@ +extensions From ac6f3d1777849b58ff8fea55eb196367a0096ec7 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 3 Jul 2008 21:14:22 -0700 Subject: [PATCH 04/77] small clarifications to COM docs --- extra/windows/com/wrapper/wrapper-docs.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/windows/com/wrapper/wrapper-docs.factor b/extra/windows/com/wrapper/wrapper-docs.factor index 89b199a38b..c863bb2762 100755 --- a/extra/windows/com/wrapper/wrapper-docs.factor +++ b/extra/windows/com/wrapper/wrapper-docs.factor @@ -5,7 +5,7 @@ IN: windows.com.wrapper HELP: { $values { "implementations" "an assoc relating COM interface names to arrays of quotations implementing that interface" } { "wrapper" "a " { $link com-wrapper } " tuple" } } -{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper objects and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" } +{ $description "Constructs a " { $link com-wrapper } " tuple. Each key in the " { $snippet "implementations" } " assoc must be the name of an interface defined with " { $link POSTPONE: COM-INTERFACE: } ". The corresponding value must be an array of quotations implementing the methods of that interface in order, including those of its parent interfaces. The " { $snippet "IUnknown" } " methods (" { $link IUnknown::QueryInterface } ", " { $link IUnknown::AddRef } ", and " { $link IUnknown::Release } ") will be defined automatically and must not be specified in the array. These quotations should have stack effects mirroring those of the interface methods being implemented; for example, a method " { $snippet "void foobar ( int foo, int bar )" } " should be implemented with a quotation of effect " { $snippet "( this foo bar -- )" } ". The " { $snippet "this" } " parameter (that is, the leftmost parameter of any COM method) will be automatically converted from an alien pointer to the underlying Factor object before the quotation is invoked.\n\nThe resulting wrapper can be applied to a Factor object using the " { $link com-wrap } " word. The COM interface pointer returned by " { $snippet "com-wrap" } " can then be passed to C functions requiring a COM object as a parameter. The vtables constructed by " { $snippet "" } " are stored on the non-GC heap in order to be accessible to C functions; when the wrapper object and its vtables are no longer needed, the object's resources must be freed using " { $link dispose } ".\n\nExample:" } { $code <" COM-INTERFACE: ISimple IUnknown {216fb341-0eb2-44b1-8edb-60b76e353abc} HRESULT returnOK ( ) @@ -38,4 +38,4 @@ HELP: com-wrap { $description "Allocates a COM object using the implementations in the " { $snippet "wrapper" } " object for the vtables and " { $snippet "object" } " for the \"this\" parameter. The COM object is allocated on the heap with an initial reference count of 1. The object will automatically deallocate itself when its reference count reaches 0 as a result of calling " { $link IUnknown::Release } " or " { $link com-release } " on it.\n\nNote that if " { $snippet "wrapper" } " implements multiple interfaces, you cannot count on the returned COM object pointer implementing any particular interface beyond " { $snippet "IUnknown" } ". You will need to use " { $link com-query-interface } " or " { $link IUnknown::QueryInterface } " to ask the object for the particular interface you need." } ; HELP: com-wrapper -{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link } " constructor and applied to a Factor object using " { $link com-wrap } "." } ; +{ $class-description "The tuple class used to store COM wrapper information. Objects of this class should be treated as opaque by user code. A com-wrapper can be constructed using the " { $link } " constructor and applied to a Factor object using " { $link com-wrap } ". When no longer needed, release the com-wrapper's internally allocated data with " { $link dispose } "." } ; From f3bcb7b77b21987a28586d0ab44d6175926872a0 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 3 Jul 2008 21:14:42 -0700 Subject: [PATCH 05/77] Add 3&& and 3|| words --- extra/combinators/short-circuit/short-circuit.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/combinators/short-circuit/short-circuit.factor b/extra/combinators/short-circuit/short-circuit.factor index 3301633d7d..c74a2ca4fb 100644 --- a/extra/combinators/short-circuit/short-circuit.factor +++ b/extra/combinators/short-circuit/short-circuit.factor @@ -16,6 +16,7 @@ IN: combinators.short-circuit MACRO: 0&& ( quots -- quot ) 0 n&&-rewrite ; MACRO: 1&& ( quots -- quot ) 1 n&&-rewrite ; MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ; +MACRO: 3&& ( quots -- quot ) 3 n&&-rewrite ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -29,5 +30,6 @@ MACRO: 2&& ( quots -- quot ) 2 n&&-rewrite ; MACRO: 0|| ( quots -- quot ) 0 n||-rewrite ; MACRO: 1|| ( quots -- quot ) 1 n||-rewrite ; MACRO: 2|| ( quots -- quot ) 2 n||-rewrite ; +MACRO: 3|| ( quots -- quot ) 3 n||-rewrite ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From bd2841deea654c34894c3313eda2fa589ada2e03 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Thu, 3 Jul 2008 21:16:09 -0700 Subject: [PATCH 06/77] refactor math.blas.vectors a bit --- extra/math/blas/syntax/syntax.factor | 2 +- extra/math/blas/vectors/summary.txt | 2 +- extra/math/blas/vectors/vectors.factor | 63 +++++++++++++++----------- 3 files changed, 39 insertions(+), 28 deletions(-) diff --git a/extra/math/blas/syntax/syntax.factor b/extra/math/blas/syntax/syntax.factor index d161739d80..e0fc9e5bc7 100644 --- a/extra/math/blas/syntax/syntax.factor +++ b/extra/math/blas/syntax/syntax.factor @@ -1,4 +1,4 @@ -USING: kernel math.blas.vectors parser prettyprint.backend ; +USING: kernel math.blas.vectors parser ; IN: math.blas.syntax : svector{ ( accum -- accum ) diff --git a/extra/math/blas/vectors/summary.txt b/extra/math/blas/vectors/summary.txt index 91653e0938..f983e855a4 100644 --- a/extra/math/blas/vectors/summary.txt +++ b/extra/math/blas/vectors/summary.txt @@ -1 +1 @@ -Basic Linear Algebra words for accelerated vector and matrix math +BLAS level 1 vector operations diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor index bec1daa855..acb28aca62 100644 --- a/extra/math/blas/vectors/vectors.factor +++ b/extra/math/blas/vectors/vectors.factor @@ -1,5 +1,5 @@ -USING: accessors alien alien.c-types arrays byte-arrays fry -kernel macros math math.blas.cblas math.complex math.functions +USING: accessors alien alien.c-types arrays byte-arrays combinators +fry kernel macros math math.blas.cblas math.complex math.functions math.order multi-methods qualified sequences sequences.private shuffle ; QUALIFIED: syntax @@ -21,8 +21,6 @@ C: double-blas-vector C: float-complex-blas-vector C: double-complex-blas-vector -GENERIC: zero-vector ( v -- zero ) - GENERIC: n*V+V-in-place ( n v1 v2 -- v2=n*v1+v2 ) GENERIC: n*V-in-place ( n v -- v=n*v ) @@ -34,18 +32,29 @@ GENERIC: Vswap ( v1 v2 -- v1=v2 v2=v1 ) GENERIC: Viamax ( v -- abs-max-index ) +GENERIC: element-type ( v -- type ) + +METHOD: element-type { float-blas-vector } + drop "float" ; +METHOD: element-type { double-blas-vector } + drop "double" ; +METHOD: element-type { float-complex-blas-vector } + drop "CBLAS_C" ; +METHOD: element-type { double-complex-blas-vector } + drop "CBLAS_Z" ; + ; +METHOD: (blas-vector-like) { object object object double-blas-vector } + drop ; +METHOD: (blas-vector-like) { object object object float-complex-blas-vector } + drop ; +METHOD: (blas-vector-like) { object object object double-complex-blas-vector } + drop ; : (prepare-copy) ( v element-size -- length v-data v-inc v-dest-data v-dest-inc ) [ [ length>> ] [ data>> ] [ inc>> ] tri ] dip @@ -121,14 +130,15 @@ MACRO: (set-complex-nth) ( set-nth-quot -- ) PRIVATE> -METHOD: zero-vector { float-blas-vector } - length>> 0.0 swap 0 ; -METHOD: zero-vector { double-blas-vector } - length>> 0.0 swap 0 ; -METHOD: zero-vector { float-complex-blas-vector } - length>> "CBLAS_C" swap 0 ; -METHOD: zero-vector { double-complex-blas-vector } - length>> "CBLAS_Z" swap 0 ; +: zero-vector ( exemplar -- zero ) + [ element-type ] + [ length>> 0 ] + [ (blas-vector-like) ] tri ; + +: empty-vector ( exemplar -- empty-vector ) + [ [ length>> ] [ element-type ] bi ] + [ length>> 1 ] + [ (blas-vector-like) ] tri ; syntax:M: blas-vector-base length length>> ; @@ -158,9 +168,11 @@ syntax:M: double-complex-blas-vector set-nth-unsafe : >double-blas-vector ( seq -- v ) [ >c-double-array ] [ length ] bi 1 ; : >float-complex-blas-vector ( seq -- v ) - [ (flatten-complex-sequence) >c-float-array ] [ length ] bi 1 ; + [ (flatten-complex-sequence) >c-float-array ] [ length ] bi + 1 ; : >double-complex-blas-vector ( seq -- v ) - [ (flatten-complex-sequence) >c-double-array ] [ length ] bi 1 ; + [ (flatten-complex-sequence) >c-double-array ] [ length ] bi + 1 ; syntax:M: float-blas-vector clone "float" heap-size (prepare-copy) @@ -206,14 +218,13 @@ METHOD: n*V-in-place { number double-complex-blas-vector } [ (>z-complex) ] dip (prepare-scal) [ cblas_zscal ] dip ; - - : n*V+V ( n v1 v2 -- n*v1+v2 ) clone n*V+V-in-place ; : n*V ( n v1 -- n*v1 ) clone n*V-in-place ; +! : n*V ( n v1 -- n*v1 ) dup empty-vector n*V+V-in-place ; ! XXX which is faster? : V+ ( v1 v2 -- v1+v2 ) 1.0 -rot n*V+V ; -: V- ( v1 v2 -- v1+v2 ) +: V- ( v1 v2 -- v1-v2 ) -1.0 spin n*V+V ; : Vneg ( v1 -- -v1 ) From 0b2300cedf4ac808fe6bfdcdac1ce33d0f427fb6 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Fri, 4 Jul 2008 17:58:37 -0500 Subject: [PATCH 07/77] Split up models vocabulary --- extra/models/compose/compose-docs.factor | 31 +++ extra/models/compose/compose-tests.factor | 24 +++ extra/models/compose/compose.factor | 49 +++++ extra/models/delay/delay-docs.factor | 29 +++ extra/models/delay/delay.factor | 25 +++ extra/models/filter/filter-docs.factor | 27 +++ extra/models/filter/filter-tests.factor | 24 +++ extra/models/filter/filter.factor | 16 ++ extra/models/history/history-docs.factor | 36 ++++ extra/models/history/history-tests.factor | 37 ++++ extra/models/history/history.factor | 29 +++ extra/models/mapping/mapping-tests.factor | 34 ++++ extra/models/mapping/mapping.factor | 20 ++ extra/models/models-docs.factor | 172 +---------------- extra/models/models-tests.factor | 141 -------------- extra/models/models.factor | 180 +----------------- extra/models/range/range-docs.factor | 58 ++++++ extra/models/range/range-tests.factor | 36 ++++ extra/models/range/range.factor | 41 ++++ extra/tools/walker/walker.factor | 2 +- extra/ui/gadgets/scrollers/scrollers.factor | 3 +- extra/ui/gadgets/sliders/sliders-docs.factor | 2 +- extra/ui/gadgets/sliders/sliders.factor | 3 +- extra/ui/gadgets/status-bar/status-bar.factor | 6 +- extra/ui/tools/browser/browser.factor | 2 +- extra/ui/tools/deploy/deploy.factor | 2 +- extra/ui/tools/interactor/interactor.factor | 12 +- extra/ui/tools/search/search.factor | 13 +- extra/ui/tools/walker/walker.factor | 2 +- extra/ui/windows/windows.factor | 6 +- 30 files changed, 559 insertions(+), 503 deletions(-) create mode 100755 extra/models/compose/compose-docs.factor create mode 100755 extra/models/compose/compose-tests.factor create mode 100755 extra/models/compose/compose.factor create mode 100755 extra/models/delay/delay-docs.factor create mode 100755 extra/models/delay/delay.factor create mode 100755 extra/models/filter/filter-docs.factor create mode 100755 extra/models/filter/filter-tests.factor create mode 100755 extra/models/filter/filter.factor create mode 100755 extra/models/history/history-docs.factor create mode 100755 extra/models/history/history-tests.factor create mode 100755 extra/models/history/history.factor create mode 100755 extra/models/mapping/mapping-tests.factor create mode 100755 extra/models/mapping/mapping.factor create mode 100755 extra/models/range/range-docs.factor create mode 100755 extra/models/range/range-tests.factor create mode 100755 extra/models/range/range.factor diff --git a/extra/models/compose/compose-docs.factor b/extra/models/compose/compose-docs.factor new file mode 100755 index 0000000000..8c07b2f09e --- /dev/null +++ b/extra/models/compose/compose-docs.factor @@ -0,0 +1,31 @@ +USING: help.syntax help.markup kernel math classes classes.tuple +calendar models ; +IN: models.compose + +HELP: compose +{ $class-description "Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence. Composed models are automatically updated when underlying models change. Composed models are constructed by " { $link } "." +$nl +"A composed model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." } +{ $examples + "The following code displays a pair of sliders, and an updating label showing their current values:" + { $code + "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;" + ": 100 over set-slider-max ;" + " 2array" + "dup make-pile gadget." + "dup [ gadget-model ] map [ unparse ] " + " gadget." + } +} ; + +HELP: +{ $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } } +{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." } +{ $examples "See the example in the documentation for " { $link compose } "." } ; + +ARTICLE: "models-compose" "Composed models" +"Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence." +{ $subsection compose } +{ $subsection } ; + +ABOUT: "models-compose" diff --git a/extra/models/compose/compose-tests.factor b/extra/models/compose/compose-tests.factor new file mode 100755 index 0000000000..25ba001d5d --- /dev/null +++ b/extra/models/compose/compose-tests.factor @@ -0,0 +1,24 @@ +IN: models.compose.tests +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.compose ; + +! Test compose +[ ] [ + 1 "a" set + 2 "b" set + "a" get "b" get 2array "c" set +] unit-test + +[ ] [ "c" get activate-model ] unit-test + +[ { 1 2 } ] [ "c" get model-value ] unit-test + +[ ] [ 3 "b" get set-model ] unit-test + +[ { 1 3 } ] [ "c" get model-value ] unit-test + +[ ] [ { 4 5 } "c" get set-model ] unit-test + +[ { 4 5 } ] [ "c" get model-value ] unit-test + +[ ] [ "c" get deactivate-model ] unit-test diff --git a/extra/models/compose/compose.factor b/extra/models/compose/compose.factor new file mode 100755 index 0000000000..0dfc65548d --- /dev/null +++ b/extra/models/compose/compose.factor @@ -0,0 +1,49 @@ +USING: models kernel sequences ; +IN: models.compose + +TUPLE: compose ; + +: ( models -- compose ) + f compose construct-model + swap clone over set-model-dependencies ; + +: composed-value >r model-dependencies r> map ; inline + +: set-composed-value >r model-dependencies r> 2each ; inline + +M: compose model-changed + nip + dup [ model-value ] composed-value swap delegate set-model ; + +M: compose model-activated dup model-changed ; + +M: compose update-model + dup model-value swap [ set-model ] set-composed-value ; + +M: compose range-value + [ range-value ] composed-value ; + +M: compose range-page-value + [ range-page-value ] composed-value ; + +M: compose range-min-value + [ range-min-value ] composed-value ; + +M: compose range-max-value + [ range-max-value ] composed-value ; + +M: compose range-max-value* + [ range-max-value* ] composed-value ; + +M: compose set-range-value + [ clamp-value ] keep + [ set-range-value ] set-composed-value ; + +M: compose set-range-page-value + [ set-range-page-value ] set-composed-value ; + +M: compose set-range-min-value + [ set-range-min-value ] set-composed-value ; + +M: compose set-range-max-value + [ set-range-max-value ] set-composed-value ; diff --git a/extra/models/delay/delay-docs.factor b/extra/models/delay/delay-docs.factor new file mode 100755 index 0000000000..1f7aff1286 --- /dev/null +++ b/extra/models/delay/delay-docs.factor @@ -0,0 +1,29 @@ +USING: help.syntax help.markup kernel math classes classes.tuple +calendar models ; +IN: models.delay + +HELP: delay +{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link } "." } +{ $examples + "The following code displays a sliders and a label which is updated half a second after the slider stops changing:" + { $code + "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;" + ": " + " 0 0 0 100 500 over set-slider-max ;" + " dup gadget." + "gadget-model 1/2 seconds [ number>string ] " + " gadget." + } +} ; + +HELP: +{ $values { "model" model } { "timeout" duration } { "delay" delay } } +{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } +{ $examples "See the example in the documentation for " { $link delay } "." } ; + +ARTICLE: "models-delay" "Delay models" +"Delay models are used to implement delayed updating of gadgets in response to user input." +{ $subsection delay } +{ $subsection } ; + +ABOUT: "models-delay" diff --git a/extra/models/delay/delay.factor b/extra/models/delay/delay.factor new file mode 100755 index 0000000000..40b669d915 --- /dev/null +++ b/extra/models/delay/delay.factor @@ -0,0 +1,25 @@ +USING: kernel models alarms ; +IN: models.delay + +TUPLE: delay model timeout alarm ; + +: update-delay-model ( delay -- ) + dup delay-model model-value swap set-model ; + +: ( model timeout -- delay ) + f delay construct-model + [ set-delay-timeout ] keep + [ set-delay-model ] 2keep + [ add-dependency ] keep ; + +: cancel-delay ( delay -- ) + delay-alarm [ cancel-alarm ] when* ; + +: start-delay ( delay -- ) + dup [ f over set-delay-alarm update-delay-model ] curry + over delay-timeout later + swap set-delay-alarm ; + +M: delay model-changed nip dup cancel-delay start-delay ; + +M: delay model-activated update-delay-model ; diff --git a/extra/models/filter/filter-docs.factor b/extra/models/filter/filter-docs.factor new file mode 100755 index 0000000000..8c50aac65b --- /dev/null +++ b/extra/models/filter/filter-docs.factor @@ -0,0 +1,27 @@ +USING: help.syntax help.markup kernel math classes classes.tuple +calendar models ; +IN: models.filter + +HELP: filter +{ $class-description "Filter model values are computed by applying a quotation to the value of another model. Filters are automatically updated when the underlying model changes. Filters are constructed by " { $link } "." } +{ $examples + "The following code displays a label showing the result of applying " { $link sq } " to the value 5:" + { $code + "USING: models ui.gadgets.labels ui.gadgets.panes ;" + "5 [ sq ] [ number>string ] " + " gadget." + } + "An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36." +} ; + +HELP: +{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } } +{ $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." } +{ $examples "See the example in the documentation for " { $link filter } "." } ; + +ARTICLE: "models-filter" "Filter models" +"Filter model values are computed by applying a quotation to the value of another model." +{ $subsection filter } +{ $subsection } ; + +ABOUT: "models-filter" diff --git a/extra/models/filter/filter-tests.factor b/extra/models/filter/filter-tests.factor new file mode 100755 index 0000000000..bdf3273fae --- /dev/null +++ b/extra/models/filter/filter-tests.factor @@ -0,0 +1,24 @@ +IN: models.filter.tests +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.filter ; + +! Test multiple filters +3 "x" set +"x" get [ 2 * ] dup "z" set +[ 1+ ] "y" set +[ ] [ "y" get activate-model ] unit-test +[ t ] [ "z" get "x" get model-connections memq? ] unit-test +[ 7 ] [ "y" get model-value ] unit-test +[ ] [ 4 "x" get set-model ] unit-test +[ 9 ] [ "y" get model-value ] unit-test +[ ] [ "y" get deactivate-model ] unit-test +[ f ] [ "z" get "x" get model-connections memq? ] unit-test + +3 "x" set +"x" get [ sq ] "y" set + +4 "x" get set-model + +"y" get activate-model +[ 16 ] [ "y" get model-value ] unit-test +"y" get deactivate-model diff --git a/extra/models/filter/filter.factor b/extra/models/filter/filter.factor new file mode 100755 index 0000000000..78b1ce09e5 --- /dev/null +++ b/extra/models/filter/filter.factor @@ -0,0 +1,16 @@ +USING: models kernel ; +IN: models.filter + +TUPLE: filter model quot ; + +: ( model quot -- filter ) + f filter construct-model + [ set-filter-quot ] keep + [ set-filter-model ] 2keep + [ add-dependency ] keep ; + +M: filter model-changed + swap model-value over filter-quot call + swap set-model ; + +M: filter model-activated dup filter-model swap model-changed ; diff --git a/extra/models/history/history-docs.factor b/extra/models/history/history-docs.factor new file mode 100755 index 0000000000..d1577298c2 --- /dev/null +++ b/extra/models/history/history-docs.factor @@ -0,0 +1,36 @@ +USING: help.syntax help.markup kernel math classes classes.tuple +calendar models ; +IN: models.history + +HELP: history +{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link } "." } ; + +HELP: +{ $values { "value" object } { "history" "a new " { $link history } } } +{ $description "Creates a new history model with an initial value." } ; + +{ add-history go-back go-forward } related-words + +HELP: go-back +{ $values { "history" history } } +{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ; + +HELP: go-forward +{ $values { "history" history } } +{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ; + +HELP: add-history +{ $values { "history" history } } +{ $description "Adds the current value to the history." } ; + +ARTICLE: "models-history" "History models" +"History models record previous values." +{ $subsection history } +{ $subsection } +"Recording history:" +{ $subsection add-history } +"Navigating the history:" +{ $subsection go-back } +{ $subsection go-forward } ; + +ABOUT: "models-history" diff --git a/extra/models/history/history-tests.factor b/extra/models/history/history-tests.factor new file mode 100755 index 0000000000..40d1176667 --- /dev/null +++ b/extra/models/history/history-tests.factor @@ -0,0 +1,37 @@ +IN: models.history.tests +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.history ; + +f "history" set + +"history" get add-history + +[ t ] [ "history" get history-back empty? ] unit-test +[ t ] [ "history" get history-forward empty? ] unit-test + +"history" get add-history +3 "history" get set-model + +[ t ] [ "history" get history-back empty? ] unit-test +[ t ] [ "history" get history-forward empty? ] unit-test + +"history" get add-history +4 "history" get set-model + +[ f ] [ "history" get history-back empty? ] unit-test +[ t ] [ "history" get history-forward empty? ] unit-test + +"history" get go-back + +[ 3 ] [ "history" get model-value ] unit-test + +[ t ] [ "history" get history-back empty? ] unit-test +[ f ] [ "history" get history-forward empty? ] unit-test + +"history" get go-forward + +[ 4 ] [ "history" get model-value ] unit-test + +[ f ] [ "history" get history-back empty? ] unit-test +[ t ] [ "history" get history-forward empty? ] unit-test + diff --git a/extra/models/history/history.factor b/extra/models/history/history.factor new file mode 100755 index 0000000000..067b76c2ec --- /dev/null +++ b/extra/models/history/history.factor @@ -0,0 +1,29 @@ +USING: kernel models sequences ; +IN: models.history + +TUPLE: history back forward ; + +: reset-history ( history -- ) + V{ } clone over set-history-back + V{ } clone swap set-history-forward ; + +: ( value -- history ) + history construct-model dup reset-history ; + +: (add-history) ( history to -- ) + swap model-value dup [ swap push ] [ 2drop ] if ; + +: go-back/forward ( history to from -- ) + dup empty? + [ 3drop ] + [ >r dupd (add-history) r> pop swap set-model ] if ; + +: go-back ( history -- ) + dup history-forward over history-back go-back/forward ; + +: go-forward ( history -- ) + dup history-back over history-forward go-back/forward ; + +: add-history ( history -- ) + dup history-forward delete-all + dup history-back (add-history) ; diff --git a/extra/models/mapping/mapping-tests.factor b/extra/models/mapping/mapping-tests.factor new file mode 100755 index 0000000000..43c1883bb1 --- /dev/null +++ b/extra/models/mapping/mapping-tests.factor @@ -0,0 +1,34 @@ +IN: models.mapping.tests +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.mapping ; + +! Test mapping +[ ] [ + [ + 1 "one" set + 2 "two" set + ] H{ } make-assoc + "m" set +] unit-test + +[ ] [ "m" get activate-model ] unit-test + +[ H{ { "one" 1 } { "two" 2 } } ] [ + "m" get model-value +] unit-test + +[ ] [ + H{ { "one" 3 } { "two" 4 } } + "m" get set-model +] unit-test + +[ H{ { "one" 3 } { "two" 4 } } ] [ + "m" get model-value +] unit-test + +[ H{ { "one" 5 } { "two" 4 } } ] [ + 5 "one" "m" get mapping-assoc at set-model + "m" get model-value +] unit-test + +[ ] [ "m" get deactivate-model ] unit-test diff --git a/extra/models/mapping/mapping.factor b/extra/models/mapping/mapping.factor new file mode 100755 index 0000000000..4e12dbccc1 --- /dev/null +++ b/extra/models/mapping/mapping.factor @@ -0,0 +1,20 @@ +USING: models kernel assocs ; +IN: models.mapping + +TUPLE: mapping assoc ; + +: ( models -- mapping ) + f mapping construct-model + over values over set-model-dependencies + tuck set-mapping-assoc ; + +M: mapping model-changed + nip + dup mapping-assoc [ model-value ] assoc-map + swap delegate set-model ; + +M: mapping model-activated dup model-changed ; + +M: mapping update-model + dup model-value swap mapping-assoc + [ swapd at set-model ] curry assoc-each ; diff --git a/extra/models/models-docs.factor b/extra/models/models-docs.factor index da275e934a..c31ae3e733 100755 --- a/extra/models/models-docs.factor +++ b/extra/models/models-docs.factor @@ -5,10 +5,10 @@ IN: models HELP: model { $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:" { $list - { { $link model-value } " - the value of the model. Use " { $link set-model } " to change the value." } - { { $link model-connections } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." } - { { $link model-dependencies } " - a sequence of models which should have this model added to their sequence of connections when activated." } - { { $link model-ref } " - a reference count tracking the number of models which depend on this one." } + { { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." } + { { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." } + { { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." } + { { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." } } "Other classes may delegate to " { $link model } "." } ; @@ -79,84 +79,6 @@ HELP: (change-model) { $description "Applies the quotation to the current value of the model to yield a new value, then changes the value of the model to the new value without notifying any observers registered with " { $link add-connection } "." } { $notes "There are very few reasons for user code to call this word. Instead, call " { $link change-model } ", which notifies observers." } ; -HELP: filter -{ $class-description "Filter model values are computed by applying a quotation to the value of another model. Filters are automatically updated when the underlying model changes. Filters are constructed by " { $link } "." } -{ $examples - "The following code displays a label showing the result of applying " { $link sq } " to the value 5:" - { $code - "USING: models ui.gadgets.labels ui.gadgets.panes ;" - "5 [ sq ] [ number>string ] " - " gadget." - } - "An exercise for the reader is to keep the original model around on the stack, and change its value to 6, observing that the label will immediately display 36." -} ; - -HELP: -{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } { "filter" "a new " { $link filter } } } -{ $description "Creates a new instance of " { $link filter } ". The value of the new filter model is computed by applying the quotation to the value." } -{ $examples "See the example in the documentation for " { $link filter } "." } ; - -HELP: compose -{ $class-description "Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence. Composed models are automatically updated when underlying models change. Composed models are constructed by " { $link } "." -$nl -"A composed model whose children are all " { $link "models-range" } " conforms to the " { $link "range-model-protocol" } " and represents a point in n-dimensional space which is bounded by a rectangle." } -{ $examples - "The following code displays a pair of sliders, and an updating label showing their current values:" - { $code - "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes ;" - ": 100 over set-slider-max ;" - " 2array" - "dup make-pile gadget." - "dup [ gadget-model ] map [ unparse ] " - " gadget." - } -} ; - -HELP: -{ $values { "models" "a sequence of models" } { "compose" "a new " { $link compose } } } -{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping " { $link model-value } " over the given sequence of models." } -{ $examples "See the example in the documentation for " { $link compose } "." } ; - -HELP: history -{ $class-description "History models record a timeline of previous values on calls to " { $link add-history } ", and can travel back and forth on the timeline with " { $link go-back } " and " { $link go-forward } ". History models are constructed by " { $link } "." } ; - -HELP: -{ $values { "value" object } { "history" "a new " { $link history } } } -{ $description "Creates a new history model with an initial value." } ; - -{ add-history go-back go-forward } related-words - -HELP: go-back -{ $values { "history" history } } -{ $description "Restores the previous value and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ; - -HELP: go-forward -{ $values { "history" history } } -{ $description "Restores the value set prior to the last call to " { $link go-back } " and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ; - -HELP: add-history -{ $values { "history" history } } -{ $description "Adds the current value to the history." } ; - -HELP: delay -{ $class-description "Delay models have the same value as their underlying model, however the value only changes after a timer expires. If the underlying model's value changes again before the timer expires, the timer restarts. Delay models are constructed by " { $link } "." } -{ $examples - "The following code displays a sliders and a label which is updated half a second after the slider stops changing:" - { $code - "USING: models ui.gadgets.labels ui.gadgets.sliders ui.gadgets.panes calendar ;" - ": " - " 0 0 0 100 500 over set-slider-max ;" - " dup gadget." - "gadget-model 1/2 seconds [ number>string ] " - " gadget." - } -} ; - -HELP: -{ $values { "model" model } { "timeout" duration } { "delay" delay } } -{ $description "Creates a new instance of " { $link delay } ". The timeout must elapse from the time the underlying model last changed to when the delay model value is changed and its connections are notified." } -{ $examples "See the example in the documentation for " { $link delay } "." } ; - HELP: range-value { $values { "model" model } { "value" object } } { $contract "Outputs the current value of a range model." } ; @@ -197,40 +119,6 @@ HELP: set-range-max-value { $description "Sets the maximum value of a range model." } { $side-effects "model" } ; -HELP: range -{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link } "." } -{ $notes { $link "ui.gadgets.sliders" } " use range models." } ; - -HELP: range-model -{ $values { "range" range } { "model" model } } -{ $description "Outputs a model holding a range model's current value." } -{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; - -HELP: range-min -{ $values { "range" range } { "model" model } } -{ $description "Outputs a model holding a range model's minimum value." } -{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; - -HELP: range-max -{ $values { "range" range } { "model" model } } -{ $description "Outputs a model holding a range model's maximum value." } -{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; - -HELP: range-page -{ $values { "range" range } { "model" model } } -{ $description "Outputs a model holding a range model's page size." } -{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; - -HELP: move-by -{ $values { "amount" real } { "range" range } } -{ $description "Adds a number to a range model's current value." } -{ $side-effects "range" } ; - -HELP: move-by-page -{ $values { "amount" real } { "range" range } } -{ $description "Adds a multiple of the page size to a range model's current value." } -{ $side-effects "range" } ; - ARTICLE: "models" "Models" "The " { $vocab-link "models" } " vocabulary provides basic support for dataflow programming. A model is an observable value. Changing a model's value notifies other objects which depend on the model automatically, and models may depend on each other's values." $nl @@ -246,60 +134,10 @@ $nl "When using models which are not associated with controls (or when unit testing controls), you must activate and deactivate models manually:" { $subsection activate-model } { $subsection deactivate-model } -"Special types of models:" -{ $subsection "models-filter" } -{ $subsection "models-compose" } -{ $subsection "models-history" } -{ $subsection "models-delay" } -{ $subsection "models-range" } { $subsection "models-impl" } ; -ARTICLE: "models-filter" "Filter models" -"Filter model values are computed by applying a quotation to the value of another model." -{ $subsection filter } -{ $subsection } ; - -ARTICLE: "models-compose" "Composed models" -"Composed model values are computed by collecting the values from a sequence of underlying models into a new sequence." -{ $subsection compose } -{ $subsection } ; - -ARTICLE: "models-history" "History models" -"History models record previous values." -{ $subsection history } -{ $subsection } -"Recording history:" -{ $subsection add-history } -"Navigating the history:" -{ $subsection go-back } -{ $subsection go-forward } ; - -ARTICLE: "models-delay" "Delay models" -"Delay models are used to implement delayed updating of gadgets in response to user input." -{ $subsection delay } -{ $subsection } ; - -ARTICLE: "models-range" "Range models" -"Range models ensure their value is a real number within a fixed range." -{ $subsection range } -{ $subsection } -"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range." -{ $subsection "range-model-protocol" } ; - -ARTICLE: "range-model-protocol" "Range model protocol" -"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too." -{ $subsection range-value } -{ $subsection range-page-value } -{ $subsection range-min-value } -{ $subsection range-max-value } -{ $subsection range-max-value* } -{ $subsection set-range-value } -{ $subsection set-range-page-value } -{ $subsection set-range-min-value } -{ $subsection set-range-max-value } ; - ARTICLE: "models-impl" "Implementing models" -"New types of models can be defined, along the lines of " { $link filter } " and such." +"New types of models can be defined, for example see " { $vocab-link "models.filter" } "." $nl "Models can execute hooks when activated:" { $subsection model-activated } diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor index 7964f8929e..637cb8f17a 100755 --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -31,144 +31,3 @@ T{ model-tester f f } "tester" set "tester" get "model-c" get model-value ] unit-test - -f "history" set - -"history" get add-history - -[ t ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test - -"history" get add-history -3 "history" get set-model - -[ t ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test - -"history" get add-history -4 "history" get set-model - -[ f ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test - -"history" get go-back - -[ 3 ] [ "history" get model-value ] unit-test - -[ t ] [ "history" get history-back empty? ] unit-test -[ f ] [ "history" get history-forward empty? ] unit-test - -"history" get go-forward - -[ 4 ] [ "history" get model-value ] unit-test - -[ f ] [ "history" get history-back empty? ] unit-test -[ t ] [ "history" get history-forward empty? ] unit-test - -! Test multiple filters -3 "x" set -"x" get [ 2 * ] dup "z" set -[ 1+ ] "y" set -[ ] [ "y" get activate-model ] unit-test -[ t ] [ "z" get "x" get model-connections memq? ] unit-test -[ 7 ] [ "y" get model-value ] unit-test -[ ] [ 4 "x" get set-model ] unit-test -[ 9 ] [ "y" get model-value ] unit-test -[ ] [ "y" get deactivate-model ] unit-test -[ f ] [ "z" get "x" get model-connections memq? ] unit-test - -3 "x" set -"x" get [ sq ] "y" set - -4 "x" get set-model - -"y" get activate-model -[ 16 ] [ "y" get model-value ] unit-test -"y" get deactivate-model - -! Test compose -[ ] [ - 1 "a" set - 2 "b" set - "a" get "b" get 2array "c" set -] unit-test - -[ ] [ "c" get activate-model ] unit-test - -[ { 1 2 } ] [ "c" get model-value ] unit-test - -[ ] [ 3 "b" get set-model ] unit-test - -[ { 1 3 } ] [ "c" get model-value ] unit-test - -[ ] [ { 4 5 } "c" get set-model ] unit-test - -[ { 4 5 } ] [ "c" get model-value ] unit-test - -[ ] [ "c" get deactivate-model ] unit-test - -! Test mapping -[ ] [ - [ - 1 "one" set - 2 "two" set - ] H{ } make-assoc - "m" set -] unit-test - -[ ] [ "m" get activate-model ] unit-test - -[ H{ { "one" 1 } { "two" 2 } } ] [ - "m" get model-value -] unit-test - -[ ] [ - H{ { "one" 3 } { "two" 4 } } - "m" get set-model -] unit-test - -[ H{ { "one" 3 } { "two" 4 } } ] [ - "m" get model-value -] unit-test - -[ H{ { "one" 5 } { "two" 4 } } ] [ - 5 "one" "m" get mapping-assoc at set-model - "m" get model-value -] unit-test - -[ ] [ "m" get deactivate-model ] unit-test - -! Test -: setup-range 0 0 0 255 ; - -! clamp-value should not go past range ends -[ 0 ] [ -10 setup-range clamp-value ] unit-test -[ 255 ] [ 2000 setup-range clamp-value ] unit-test -[ 14 ] [ 14 setup-range clamp-value ] unit-test - -! range min/max/page values should be correct -[ 0 ] [ setup-range range-page-value ] unit-test -[ 0 ] [ setup-range range-min-value ] unit-test -[ 255 ] [ setup-range range-max-value ] unit-test - -! should be able to set the value within the range and get back -[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test -[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test -[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test - -! should be able to change the range min/max/page value -[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test -[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test -[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test - -! should be able to move by positive and negative values -[ 30 ] [ setup-range 30 over move-by range-value ] unit-test -[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test - -! should be able to move by a page of 10 -[ 10 ] [ - setup-range 10 over set-range-page-value - 1 over move-by-page range-value -] unit-test - - diff --git a/extra/models/models.factor b/extra/models/models.factor index 2caf6e9940..48c43d9368 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -1,14 +1,21 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: generic kernel math sequences arrays assocs alarms -calendar math.order ; +USING: accessors generic kernel math sequences arrays assocs +alarms calendar math.order ; IN: models TUPLE: model < identity-tuple value connections dependencies ref locked? ; +: new-model ( value class -- model ) + new + swap >>value + V{ } clone >>connections + V{ } clone >>dependencies + 0 >>ref ; inline + : ( value -- model ) - V{ } clone V{ } clone 0 f model boa ; + model new-model ; M: model hashcode* drop model hashcode* ; @@ -96,107 +103,6 @@ M: model update-model drop ; : construct-model ( value class -- instance ) >r { set-delegate } r> construct ; inline -TUPLE: filter model quot ; - -: ( model quot -- filter ) - f filter construct-model - [ set-filter-quot ] keep - [ set-filter-model ] 2keep - [ add-dependency ] keep ; - -M: filter model-changed - swap model-value over filter-quot call - swap set-model ; - -M: filter model-activated dup filter-model swap model-changed ; - -TUPLE: compose ; - -: ( models -- compose ) - f compose construct-model - swap clone over set-model-dependencies ; - -: composed-value >r model-dependencies r> map ; inline - -: set-composed-value >r model-dependencies r> 2each ; inline - -M: compose model-changed - nip - dup [ model-value ] composed-value swap delegate set-model ; - -M: compose model-activated dup model-changed ; - -M: compose update-model - dup model-value swap [ set-model ] set-composed-value ; - -TUPLE: mapping assoc ; - -: ( models -- mapping ) - f mapping construct-model - over values over set-model-dependencies - tuck set-mapping-assoc ; - -M: mapping model-changed - nip - dup mapping-assoc [ model-value ] assoc-map - swap delegate set-model ; - -M: mapping model-activated dup model-changed ; - -M: mapping update-model - dup model-value swap mapping-assoc - [ swapd at set-model ] curry assoc-each ; - -TUPLE: history back forward ; - -: reset-history ( history -- ) - V{ } clone over set-history-back - V{ } clone swap set-history-forward ; - -: ( value -- history ) - history construct-model dup reset-history ; - -: (add-history) ( history to -- ) - swap model-value dup [ swap push ] [ 2drop ] if ; - -: go-back/forward ( history to from -- ) - dup empty? - [ 3drop ] - [ >r dupd (add-history) r> pop swap set-model ] if ; - -: go-back ( history -- ) - dup history-forward over history-back go-back/forward ; - -: go-forward ( history -- ) - dup history-back over history-forward go-back/forward ; - -: add-history ( history -- ) - dup history-forward delete-all - dup history-back (add-history) ; - -TUPLE: delay model timeout alarm ; - -: update-delay-model ( delay -- ) - dup delay-model model-value swap set-model ; - -: ( model timeout -- delay ) - f delay construct-model - [ set-delay-timeout ] keep - [ set-delay-model ] 2keep - [ add-dependency ] keep ; - -: cancel-delay ( delay -- ) - delay-alarm [ cancel-alarm ] when* ; - -: start-delay ( delay -- ) - dup [ f over set-delay-alarm update-delay-model ] curry - over delay-timeout later - swap set-delay-alarm ; - -M: delay model-changed nip dup cancel-delay start-delay ; - -M: delay model-activated update-delay-model ; - GENERIC: range-value ( model -- value ) GENERIC: range-page-value ( model -- value ) GENERIC: range-min-value ( model -- value ) @@ -207,72 +113,6 @@ GENERIC: set-range-page-value ( value model -- ) GENERIC: set-range-min-value ( value model -- ) GENERIC: set-range-max-value ( value model -- ) -TUPLE: range ; - -: ( value min max page -- range ) - 4array [ ] map - { set-delegate } range construct ; - -: range-model ( range -- model ) model-dependencies first ; -: range-page ( range -- model ) model-dependencies second ; -: range-min ( range -- model ) model-dependencies third ; -: range-max ( range -- model ) model-dependencies fourth ; - : clamp-value ( value range -- newvalue ) [ range-min-value max ] keep range-max-value* min ; - -M: range range-value - [ range-model model-value ] keep clamp-value ; - -M: range range-page-value range-page model-value ; - -M: range range-min-value range-min model-value ; - -M: range range-max-value range-max model-value ; - -M: range range-max-value* - dup range-max-value swap range-page-value [-] ; - -M: range set-range-value - [ clamp-value ] keep range-model set-model ; - -M: range set-range-page-value range-page set-model ; - -M: range set-range-min-value range-min set-model ; - -M: range set-range-max-value range-max set-model ; - -M: compose range-value - [ range-value ] composed-value ; - -M: compose range-page-value - [ range-page-value ] composed-value ; - -M: compose range-min-value - [ range-min-value ] composed-value ; - -M: compose range-max-value - [ range-max-value ] composed-value ; - -M: compose range-max-value* - [ range-max-value* ] composed-value ; - -M: compose set-range-value - [ clamp-value ] keep - [ set-range-value ] set-composed-value ; - -M: compose set-range-page-value - [ set-range-page-value ] set-composed-value ; - -M: compose set-range-min-value - [ set-range-min-value ] set-composed-value ; - -M: compose set-range-max-value - [ set-range-max-value ] set-composed-value ; - -: move-by ( amount range -- ) - [ range-value + ] keep set-range-value ; - -: move-by-page ( amount range -- ) - [ range-page-value * ] keep move-by ; diff --git a/extra/models/range/range-docs.factor b/extra/models/range/range-docs.factor new file mode 100755 index 0000000000..6a767b2e13 --- /dev/null +++ b/extra/models/range/range-docs.factor @@ -0,0 +1,58 @@ +USING: help.syntax help.markup kernel math classes classes.tuple +calendar models ; +IN: models.range + +HELP: range +{ $class-description "Range models implement the " { $link "range-model-protocol" } " with real numbers as the minimum, current, maximum, and page size. Range models are created with " { $link } "." } +{ $notes { $link "ui.gadgets.sliders" } " use range models." } ; + +HELP: range-model +{ $values { "range" range } { "model" model } } +{ $description "Outputs a model holding a range model's current value." } +{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; + +HELP: range-min +{ $values { "range" range } { "model" model } } +{ $description "Outputs a model holding a range model's minimum value." } +{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; + +HELP: range-max +{ $values { "range" range } { "model" model } } +{ $description "Outputs a model holding a range model's maximum value." } +{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; + +HELP: range-page +{ $values { "range" range } { "model" model } } +{ $description "Outputs a model holding a range model's page size." } +{ $notes "This word is not part of the " { $link "range-model-protocol" } ", and can only be used on direct instances of " { $link range } "." } ; + +HELP: move-by +{ $values { "amount" real } { "range" range } } +{ $description "Adds a number to a range model's current value." } +{ $side-effects "range" } ; + +HELP: move-by-page +{ $values { "amount" real } { "range" range } } +{ $description "Adds a multiple of the page size to a range model's current value." } +{ $side-effects "range" } ; + +ARTICLE: "models-range" "Range models" +"Range models ensure their value is a real number within a fixed range." +{ $subsection range } +{ $subsection } +"Range models conform to a protocol for getting and setting the current value, as well as the endpoints of the range." +{ $subsection "range-model-protocol" } ; + +ARTICLE: "range-model-protocol" "Range model protocol" +"The range model protocol is implemented by the " { $link range } " and " { $link compose } " classes. User-defined models may implement it too." +{ $subsection range-value } +{ $subsection range-page-value } +{ $subsection range-min-value } +{ $subsection range-max-value } +{ $subsection range-max-value* } +{ $subsection set-range-value } +{ $subsection set-range-page-value } +{ $subsection set-range-min-value } +{ $subsection set-range-max-value } ; + +ABOUT: "models-range" diff --git a/extra/models/range/range-tests.factor b/extra/models/range/range-tests.factor new file mode 100755 index 0000000000..c8a2d1acc6 --- /dev/null +++ b/extra/models/range/range-tests.factor @@ -0,0 +1,36 @@ +IN: models.range.tests +USING: arrays generic kernel math models namespaces sequences assocs +tools.test models.range ; + +! Test +: setup-range 0 0 0 255 ; + +! clamp-value should not go past range ends +[ 0 ] [ -10 setup-range clamp-value ] unit-test +[ 255 ] [ 2000 setup-range clamp-value ] unit-test +[ 14 ] [ 14 setup-range clamp-value ] unit-test + +! range min/max/page values should be correct +[ 0 ] [ setup-range range-page-value ] unit-test +[ 0 ] [ setup-range range-min-value ] unit-test +[ 255 ] [ setup-range range-max-value ] unit-test + +! should be able to set the value within the range and get back +[ 15 ] [ setup-range 15 over set-range-value range-value ] unit-test +[ 0 ] [ setup-range -15 over set-range-value range-value ] unit-test +[ 255 ] [ setup-range 4000 over set-range-value range-value ] unit-test + +! should be able to change the range min/max/page value +[ 1 ] [ setup-range 1 over set-range-page-value range-page-value ] unit-test +[ 50 ] [ setup-range 50 over set-range-min-value range-min-value ] unit-test +[ 4000 ] [ setup-range 4000 over set-range-max-value range-max-value ] unit-test + +! should be able to move by positive and negative values +[ 30 ] [ setup-range 30 over move-by range-value ] unit-test +[ 0 ] [ setup-range 30 over move-by -30 over move-by range-value ] unit-test + +! should be able to move by a page of 10 +[ 10 ] [ + setup-range 10 over set-range-page-value + 1 over move-by-page range-value +] unit-test diff --git a/extra/models/range/range.factor b/extra/models/range/range.factor new file mode 100755 index 0000000000..761e077948 --- /dev/null +++ b/extra/models/range/range.factor @@ -0,0 +1,41 @@ +USING: kernel models arrays sequences math math.order +models.compose ; +IN: models.range + +TUPLE: range ; + +: ( value min max page -- range ) + 4array [ ] map + { set-delegate } range construct ; + +: range-model ( range -- model ) model-dependencies first ; +: range-page ( range -- model ) model-dependencies second ; +: range-min ( range -- model ) model-dependencies third ; +: range-max ( range -- model ) model-dependencies fourth ; + +M: range range-value + [ range-model model-value ] keep clamp-value ; + +M: range range-page-value range-page model-value ; + +M: range range-min-value range-min model-value ; + +M: range range-max-value range-max model-value ; + +M: range range-max-value* + dup range-max-value swap range-page-value [-] ; + +M: range set-range-value + [ clamp-value ] keep range-model set-model ; + +M: range set-range-page-value range-page set-model ; + +M: range set-range-min-value range-min set-model ; + +M: range set-range-max-value range-max set-model ; + +: move-by ( amount range -- ) + [ range-value + ] keep set-range-value ; + +: move-by-page ( amount range -- ) + [ range-page-value * ] keep move-by ; diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 07a5759af2..f3cfb88cef 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -3,7 +3,7 @@ USING: threads kernel namespaces continuations combinators sequences math namespaces.private continuations.private concurrency.messaging quotations kernel.private words -sequences.private assocs models arrays accessors +sequences.private assocs models models.filter arrays accessors generic generic.standard definitions ; IN: tools.walker diff --git a/extra/ui/gadgets/scrollers/scrollers.factor b/extra/ui/gadgets/scrollers/scrollers.factor index e58fbc5925..2492348d56 100755 --- a/extra/ui/gadgets/scrollers/scrollers.factor +++ b/extra/ui/gadgets/scrollers/scrollers.factor @@ -3,7 +3,8 @@ USING: accessors arrays ui.gadgets ui.gadgets.viewports ui.gadgets.frames ui.gadgets.grids ui.gadgets.theme ui.gadgets.sliders ui.gestures kernel math namespaces sequences -models combinators math.vectors classes.tuple ; +models models.range models.compose +combinators math.vectors classes.tuple ; IN: ui.gadgets.scrollers TUPLE: scroller viewport x y follows ; diff --git a/extra/ui/gadgets/sliders/sliders-docs.factor b/extra/ui/gadgets/sliders/sliders-docs.factor index e5de7c2208..e58e4fe7e9 100755 --- a/extra/ui/gadgets/sliders/sliders-docs.factor +++ b/extra/ui/gadgets/sliders/sliders-docs.factor @@ -1,4 +1,4 @@ -USING: help.markup help.syntax ui.gadgets models ; +USING: help.markup help.syntax ui.gadgets models models.range ; IN: ui.gadgets.sliders HELP: elevator diff --git a/extra/ui/gadgets/sliders/sliders.factor b/extra/ui/gadgets/sliders/sliders.factor index eb22a5a823..120e8e8a4c 100755 --- a/extra/ui/gadgets/sliders/sliders.factor +++ b/extra/ui/gadgets/sliders/sliders.factor @@ -3,7 +3,8 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.grids math.order ui.gadgets.theme ui.render kernel math namespaces sequences -vectors models math.vectors math.functions quotations colors ; +vectors models models.range math.vectors math.functions +quotations colors ; IN: ui.gadgets.sliders TUPLE: elevator direction ; diff --git a/extra/ui/gadgets/status-bar/status-bar.factor b/extra/ui/gadgets/status-bar/status-bar.factor index 417826a680..12c365c6a4 100755 --- a/extra/ui/gadgets/status-bar/status-bar.factor +++ b/extra/ui/gadgets/status-bar/status-bar.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors models sequences ui.gadgets.labels -ui.gadgets.theme ui.gadgets.tracks ui.gadgets.worlds ui.gadgets -ui kernel calendar ; +USING: accessors models models.delay models.filter +sequences ui.gadgets.labels ui.gadgets.theme ui.gadgets.tracks +ui.gadgets.worlds ui.gadgets ui kernel calendar ; IN: ui.gadgets.status-bar : ( model -- gadget ) diff --git a/extra/ui/tools/browser/browser.factor b/extra/ui/tools/browser/browser.factor index ae39b3e116..5cc955e031 100755 --- a/extra/ui/tools/browser/browser.factor +++ b/extra/ui/tools/browser/browser.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: debugger ui.tools.workspace help help.topics kernel -models ui.commands ui.gadgets ui.gadgets.panes +models models.history ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.gadgets.buttons compiler.units assocs words vocabs accessors ; diff --git a/extra/ui/tools/deploy/deploy.factor b/extra/ui/tools/deploy/deploy.factor index f0454f5cc2..12d327ab43 100755 --- a/extra/ui/tools/deploy/deploy.factor +++ b/extra/ui/tools/deploy/deploy.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: ui.gadgets colors kernel ui.render namespaces -models sequences ui.gadgets.buttons +models models.mapping sequences ui.gadgets.buttons ui.gadgets.packs ui.gadgets.labels tools.deploy.config namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands assocs ui.gadgets.tracks ui ui.tools.listener diff --git a/extra/ui/tools/interactor/interactor.factor b/extra/ui/tools/interactor/interactor.factor index fcd3f9ab22..791d9bcfd7 100755 --- a/extra/ui/tools/interactor/interactor.factor +++ b/extra/ui/tools/interactor/interactor.factor @@ -2,12 +2,12 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs combinators continuations documents hashtables io io.styles kernel math math.order math.vectors -models namespaces parser lexer prettyprint quotations sequences -strings threads listener classes.tuple ui.commands ui.gadgets -ui.gadgets.editors ui.gadgets.presentations ui.gadgets.worlds -ui.gestures definitions calendar concurrency.flags -concurrency.mailboxes ui.tools.workspace accessors sets -destructors ; +models models.delay namespaces parser lexer prettyprint +quotations sequences strings threads listener classes.tuple +ui.commands ui.gadgets ui.gadgets.editors +ui.gadgets.presentations ui.gadgets.worlds ui.gestures +definitions calendar concurrency.flags concurrency.mailboxes +ui.tools.workspace accessors sets destructors ; IN: ui.tools.interactor ! If waiting is t, we're waiting for user input, and invoking diff --git a/extra/ui/tools/search/search.factor b/extra/ui/tools/search/search.factor index f432027367..d08384913e 100755 --- a/extra/ui/tools/search/search.factor +++ b/extra/ui/tools/search/search.factor @@ -2,12 +2,13 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs ui.tools.interactor ui.tools.listener ui.tools.workspace help help.topics io.files io.styles kernel -models namespaces prettyprint quotations sequences sorting -source-files definitions strings tools.completion tools.crossref -classes.tuple ui.commands ui.gadgets ui.gadgets.editors -ui.gadgets.lists ui.gadgets.scrollers ui.gadgets.tracks -ui.gestures ui.operations vocabs words vocabs.loader -tools.vocabs unicode.case calendar ui ; +models models.delay models.filter namespaces prettyprint +quotations sequences sorting source-files definitions strings +tools.completion tools.crossref classes.tuple ui.commands +ui.gadgets ui.gadgets.editors ui.gadgets.lists +ui.gadgets.scrollers ui.gadgets.tracks ui.gestures ui.operations +vocabs words vocabs.loader tools.vocabs unicode.case calendar ui +; IN: ui.tools.search TUPLE: live-search field list ; diff --git a/extra/ui/tools/walker/walker.factor b/extra/ui/tools/walker/walker.factor index 8d205daebf..4398afa3e0 100755 --- a/extra/ui/tools/walker/walker.factor +++ b/extra/ui/tools/walker/walker.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel concurrency.messaging inspector ui.tools.listener ui.tools.traceback ui.gadgets.buttons ui.gadgets.status-bar -ui.gadgets.tracks ui.commands ui.gadgets models +ui.gadgets.tracks ui.commands ui.gadgets models models.filter ui.tools.workspace ui.gestures ui.gadgets.labels ui threads namespaces tools.walker assocs combinators ; IN: ui.tools.walker diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index dda9a1dc0e..f8228b3177 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -207,9 +207,9 @@ SYMBOLS: msg-obj class-name-ptr mouse-captured ; wParam keystroke>gesture hWnd window-focus send-gesture drop ; -: set-window-active ( hwnd uMsg wParam lParam ? -- n ) - >r 4dup r> 2nip nip - swap window set-world-active? DefWindowProc ; +:: set-window-active ( hwnd uMsg wParam lParam ? -- n ) + ? hwnd window set-world-active? + hwnd uMsg wParam lParam DefWindowProc ; : handle-wm-syscommand ( hWnd uMsg wParam lParam -- n ) { From 86f476a23db20a8bdd15978c1d415be7ed8159d3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Jul 2008 22:36:55 -0500 Subject: [PATCH 08/77] Fix bug in found by Joe --- core/alien/alien-tests.factor | 6 +++++- vm/alien.c | 2 +- 2 files changed, 6 insertions(+), 2 deletions(-) diff --git a/core/alien/alien-tests.factor b/core/alien/alien-tests.factor index 9be2885888..5a880fa5a9 100755 --- a/core/alien/alien-tests.factor +++ b/core/alien/alien-tests.factor @@ -1,5 +1,5 @@ IN: alien.tests -USING: alien alien.accessors alien.syntax byte-arrays arrays +USING: accessors alien alien.accessors alien.syntax byte-arrays arrays kernel kernel.private namespaces tools.test sequences libc math system prettyprint layouts ; @@ -65,6 +65,10 @@ cell 8 = [ [ f ] [ 0 B{ 1 2 3 } pinned-c-ptr? ] unit-test +[ f ] [ 0 B{ 1 2 3 } 1 swap pinned-c-ptr? ] unit-test + +[ t ] [ 0 B{ 1 2 3 } 1 swap underlying>> byte-array? ] unit-test + [ "( displaced alien )" ] [ 0 B{ 1 2 3 } unparse ] unit-test [ f ] [ DLL" fadfasdfsada" dll-valid? ] unit-test diff --git a/vm/alien.c b/vm/alien.c index 7fdf9ccdb2..5b4ff3b832 100755 --- a/vm/alien.c +++ b/vm/alien.c @@ -62,7 +62,7 @@ CELL allot_alien(CELL delegate, CELL displacement) { F_ALIEN *delegate_alien = untag_object(delegate); displacement += delegate_alien->displacement; - alien->alien = F; + alien->alien = delegate_alien->alien; } else alien->alien = delegate; From 64278e21125f7f56b75566a17051b8cb9c292597 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 4 Jul 2008 20:37:16 -0700 Subject: [PATCH 09/77] fix applied to already displaced alien --- vm/alien.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/vm/alien.c b/vm/alien.c index 7fdf9ccdb2..5b4ff3b832 100755 --- a/vm/alien.c +++ b/vm/alien.c @@ -62,7 +62,7 @@ CELL allot_alien(CELL delegate, CELL displacement) { F_ALIEN *delegate_alien = untag_object(delegate); displacement += delegate_alien->displacement; - alien->alien = F; + alien->alien = delegate_alien->alien; } else alien->alien = delegate; From f70634bb01c64e4892a09403568158b8569224e1 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 4 Jul 2008 20:52:24 -0700 Subject: [PATCH 10/77] Add 0 integer>bit-array fix to bit-arrays in its new home under extra --- extra/bit-arrays/bit-arrays.factor | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/extra/bit-arrays/bit-arrays.factor b/extra/bit-arrays/bit-arrays.factor index 4fee1dfba3..96d7cf9905 100755 --- a/extra/bit-arrays/bit-arrays.factor +++ b/extra/bit-arrays/bit-arrays.factor @@ -73,12 +73,14 @@ M: bit-array byte-length length 7 + -3 shift ; \ } [ >bit-array ] parse-literal ; parsing : integer>bit-array ( int -- bit-array ) - [ log2 1+ 0 ] keep - [ dup zero? not ] [ - [ -8 shift ] [ 255 bitand ] bi - -roll [ [ >r underlying>> r> set-alien-unsigned-1 ] 2keep 1+ ] dip - ] [ ] while - 2drop ; + dup zero? [ drop 0 ] [ + [ log2 1+ 0 ] keep + [ dup zero? not ] [ + [ -8 shift ] [ 255 bitand ] bi + -roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip + ] [ ] while + 2drop + ] if ; : bit-array>integer ( bit-array -- int ) 0 swap underlying>> [ length ] keep [ From 727d9edcd369a0d77a9d59ef454da6ce19cb6e98 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 4 Jul 2008 20:57:22 -0700 Subject: [PATCH 11/77] BLAS level 2/level 3 interface words --- extra/math/blas/matrices/authors.txt | 1 + .../math/blas/matrices/matrices-tests.factor | 710 ++++++++++++++++++ extra/math/blas/matrices/matrices.factor | 306 ++++++++ extra/math/blas/matrices/summary.txt | 1 + extra/math/blas/matrices/tags.txt | 2 + extra/math/blas/syntax/syntax.factor | 10 +- extra/math/blas/vectors/vectors.factor | 37 +- 7 files changed, 1050 insertions(+), 17 deletions(-) create mode 100644 extra/math/blas/matrices/authors.txt create mode 100644 extra/math/blas/matrices/matrices-tests.factor create mode 100644 extra/math/blas/matrices/matrices.factor create mode 100644 extra/math/blas/matrices/summary.txt create mode 100644 extra/math/blas/matrices/tags.txt diff --git a/extra/math/blas/matrices/authors.txt b/extra/math/blas/matrices/authors.txt new file mode 100644 index 0000000000..f13c9c1e77 --- /dev/null +++ b/extra/math/blas/matrices/authors.txt @@ -0,0 +1 @@ +Joe Groff diff --git a/extra/math/blas/matrices/matrices-tests.factor b/extra/math/blas/matrices/matrices-tests.factor new file mode 100644 index 0000000000..dabf3c3ee9 --- /dev/null +++ b/extra/math/blas/matrices/matrices-tests.factor @@ -0,0 +1,710 @@ +USING: kernel math.blas.matrices math.blas.vectors math.blas.syntax +sequences tools.test ; +IN: math.blas.matrices.tests + +! clone + +[ smatrix{ + { 1.0 2.0 3.0 } + { 4.0 5.0 6.0 } + { 7.0 8.0 9.0 } +} ] [ + smatrix{ + { 1.0 2.0 3.0 } + { 4.0 5.0 6.0 } + { 7.0 8.0 9.0 } + } clone +] unit-test +[ f ] [ + smatrix{ + { 1.0 2.0 3.0 } + { 4.0 5.0 6.0 } + { 7.0 8.0 9.0 } + } dup clone eq? +] unit-test + +[ dmatrix{ + { 1.0 2.0 3.0 } + { 4.0 5.0 6.0 } + { 7.0 8.0 9.0 } +} ] [ + dmatrix{ + { 1.0 2.0 3.0 } + { 4.0 5.0 6.0 } + { 7.0 8.0 9.0 } + } clone +] unit-test +[ f ] [ + dmatrix{ + { 1.0 2.0 3.0 } + { 4.0 5.0 6.0 } + { 7.0 8.0 9.0 } + } dup clone eq? +] unit-test + +[ cmatrix{ + { C{ 1.0 1.0 } 2.0 3.0 } + { 4.0 C{ 5.0 2.0 } 6.0 } + { 7.0 8.0 C{ 9.0 3.0 } } +} ] [ + cmatrix{ + { C{ 1.0 1.0 } 2.0 3.0 } + { 4.0 C{ 5.0 2.0 } 6.0 } + { 7.0 8.0 C{ 9.0 3.0 } } + } clone +] unit-test +[ f ] [ + cmatrix{ + { C{ 1.0 1.0 } 2.0 3.0 } + { 4.0 C{ 5.0 2.0 } 6.0 } + { 7.0 8.0 C{ 9.0 3.0 } } + } dup clone eq? +] unit-test + +[ zmatrix{ + { C{ 1.0 1.0 } 2.0 3.0 } + { 4.0 C{ 5.0 2.0 } 6.0 } + { 7.0 8.0 C{ 9.0 3.0 } } +} ] [ + zmatrix{ + { C{ 1.0 1.0 } 2.0 3.0 } + { 4.0 C{ 5.0 2.0 } 6.0 } + { 7.0 8.0 C{ 9.0 3.0 } } + } clone +] unit-test +[ f ] [ + zmatrix{ + { C{ 1.0 1.0 } 2.0 3.0 } + { 4.0 C{ 5.0 2.0 } 6.0 } + { 7.0 8.0 C{ 9.0 3.0 } } + } dup clone eq? +] unit-test + +! M.V + +[ svector{ 3.0 1.0 6.0 } ] [ + smatrix{ + { 0.0 1.0 0.0 1.0 } + { -1.0 0.0 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + } + svector{ 1.0 2.0 3.0 1.0 } + M.V +] unit-test +[ svector{ -2.0 1.0 3.0 14.0 } ] [ + smatrix{ + { 0.0 1.0 0.0 1.0 } + { -1.0 0.0 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + } Mtranspose + svector{ 1.0 2.0 3.0 } + M.V +] unit-test + +[ dvector{ 3.0 1.0 6.0 } ] [ + dmatrix{ + { 0.0 1.0 0.0 1.0 } + { -1.0 0.0 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + } + dvector{ 1.0 2.0 3.0 1.0 } + M.V +] unit-test +[ dvector{ -2.0 1.0 3.0 14.0 } ] [ + dmatrix{ + { 0.0 1.0 0.0 1.0 } + { -1.0 0.0 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + } Mtranspose + dvector{ 1.0 2.0 3.0 } + M.V +] unit-test + +[ cvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [ + cmatrix{ + { 0.0 1.0 0.0 1.0 } + { -1.0 C{ 0.0 1.0 } 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + } + cvector{ 1.0 2.0 3.0 1.0 } + M.V +] unit-test +[ cvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [ + cmatrix{ + { 0.0 1.0 0.0 1.0 } + { -1.0 C{ 0.0 1.0 } 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + } Mtranspose + cvector{ 1.0 2.0 3.0 } + M.V +] unit-test + +[ zvector{ 3.0 C{ 1.0 2.0 } 6.0 } ] [ + zmatrix{ + { 0.0 1.0 0.0 1.0 } + { -1.0 C{ 0.0 1.0 } 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + } + zvector{ 1.0 2.0 3.0 1.0 } + M.V +] unit-test +[ zvector{ -2.0 C{ 1.0 2.0 } 3.0 14.0 } ] [ + zmatrix{ + { 0.0 1.0 0.0 1.0 } + { -1.0 C{ 0.0 1.0 } 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + } Mtranspose + zvector{ 1.0 2.0 3.0 } + M.V +] unit-test + +! V(*) + +[ smatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 4.0 6.0 8.0 } + { 3.0 6.0 9.0 12.0 } +} ] [ + svector{ 1.0 2.0 3.0 } svector{ 1.0 2.0 3.0 4.0 } V(*) +] unit-test + +[ dmatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 4.0 6.0 8.0 } + { 3.0 6.0 9.0 12.0 } +} ] [ + dvector{ 1.0 2.0 3.0 } dvector{ 1.0 2.0 3.0 4.0 } V(*) +] unit-test + +[ cmatrix{ + { 1.0 2.0 C{ 3.0 -3.0 } 4.0 } + { 2.0 4.0 C{ 6.0 -6.0 } 8.0 } + { C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } } +} ] [ + cvector{ 1.0 2.0 C{ 3.0 3.0 } } cvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*) +] unit-test + +[ zmatrix{ + { 1.0 2.0 C{ 3.0 -3.0 } 4.0 } + { 2.0 4.0 C{ 6.0 -6.0 } 8.0 } + { C{ 3.0 3.0 } C{ 6.0 6.0 } 18.0 C{ 12.0 12.0 } } +} ] [ + zvector{ 1.0 2.0 C{ 3.0 3.0 } } zvector{ 1.0 2.0 C{ 3.0 -3.0 } 4.0 } V(*) +] unit-test + +! M. + +[ smatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 0.0 -3.0 0.0 0.0 } + { 0.0 4.0 0.0 0.0 10.0 } + { 0.0 0.0 0.0 0.0 0.0 } +} ] [ + smatrix{ + { 1.0 0.0 0.0 } + { 0.0 0.0 -1.0 } + { 0.0 2.0 0.0 } + { 0.0 0.0 0.0 } + } smatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 2.0 0.0 0.0 5.0 } + { 0.0 0.0 3.0 0.0 0.0 } + } M. +] unit-test + +[ smatrix{ + { 1.0 0.0 0.0 0.0 } + { 0.0 0.0 4.0 0.0 } + { 0.0 -3.0 0.0 0.0 } + { 4.0 0.0 0.0 0.0 } + { 0.0 0.0 10.0 0.0 } +} ] [ + smatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 2.0 0.0 0.0 5.0 } + { 0.0 0.0 3.0 0.0 0.0 } + } Mtranspose smatrix{ + { 1.0 0.0 0.0 } + { 0.0 0.0 -1.0 } + { 0.0 2.0 0.0 } + { 0.0 0.0 0.0 } + } Mtranspose M. +] unit-test + +[ dmatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 0.0 -3.0 0.0 0.0 } + { 0.0 4.0 0.0 0.0 10.0 } + { 0.0 0.0 0.0 0.0 0.0 } +} ] [ + dmatrix{ + { 1.0 0.0 0.0 } + { 0.0 0.0 -1.0 } + { 0.0 2.0 0.0 } + { 0.0 0.0 0.0 } + } dmatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 2.0 0.0 0.0 5.0 } + { 0.0 0.0 3.0 0.0 0.0 } + } M. +] unit-test + +[ dmatrix{ + { 1.0 0.0 0.0 0.0 } + { 0.0 0.0 4.0 0.0 } + { 0.0 -3.0 0.0 0.0 } + { 4.0 0.0 0.0 0.0 } + { 0.0 0.0 10.0 0.0 } +} ] [ + dmatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 2.0 0.0 0.0 5.0 } + { 0.0 0.0 3.0 0.0 0.0 } + } Mtranspose dmatrix{ + { 1.0 0.0 0.0 } + { 0.0 0.0 -1.0 } + { 0.0 2.0 0.0 } + { 0.0 0.0 0.0 } + } Mtranspose M. +] unit-test + +[ cmatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 0.0 -3.0 0.0 0.0 } + { 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 } + { 0.0 0.0 0.0 0.0 0.0 } +} ] [ + cmatrix{ + { 1.0 0.0 0.0 } + { 0.0 0.0 -1.0 } + { 0.0 2.0 0.0 } + { 0.0 0.0 0.0 } + } cmatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 } + { 0.0 0.0 3.0 0.0 0.0 } + } M. +] unit-test + +[ cmatrix{ + { 1.0 0.0 0.0 0.0 } + { 0.0 0.0 C{ 4.0 -4.0 } 0.0 } + { 0.0 -3.0 0.0 0.0 } + { 4.0 0.0 0.0 0.0 } + { 0.0 0.0 10.0 0.0 } +} ] [ + cmatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 } + { 0.0 0.0 3.0 0.0 0.0 } + } Mtranspose cmatrix{ + { 1.0 0.0 0.0 } + { 0.0 0.0 -1.0 } + { 0.0 2.0 0.0 } + { 0.0 0.0 0.0 } + } Mtranspose M. +] unit-test + +[ zmatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 0.0 -3.0 0.0 0.0 } + { 0.0 C{ 4.0 -4.0 } 0.0 0.0 10.0 } + { 0.0 0.0 0.0 0.0 0.0 } +} ] [ + zmatrix{ + { 1.0 0.0 0.0 } + { 0.0 0.0 -1.0 } + { 0.0 2.0 0.0 } + { 0.0 0.0 0.0 } + } zmatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 } + { 0.0 0.0 3.0 0.0 0.0 } + } M. +] unit-test + +[ zmatrix{ + { 1.0 0.0 0.0 0.0 } + { 0.0 0.0 C{ 4.0 -4.0 } 0.0 } + { 0.0 -3.0 0.0 0.0 } + { 4.0 0.0 0.0 0.0 } + { 0.0 0.0 10.0 0.0 } +} ] [ + zmatrix{ + { 1.0 0.0 0.0 4.0 0.0 } + { 0.0 C{ 2.0 -2.0 } 0.0 0.0 5.0 } + { 0.0 0.0 3.0 0.0 0.0 } + } Mtranspose zmatrix{ + { 1.0 0.0 0.0 } + { 0.0 0.0 -1.0 } + { 0.0 2.0 0.0 } + { 0.0 0.0 0.0 } + } Mtranspose M. +] unit-test + +! n*M + +[ smatrix{ + { 2.0 0.0 } + { 0.0 2.0 } +} ] [ + 2.0 smatrix{ + { 1.0 0.0 } + { 0.0 1.0 } + } n*M +] unit-test + +[ dmatrix{ + { 2.0 0.0 } + { 0.0 2.0 } +} ] [ + 2.0 dmatrix{ + { 1.0 0.0 } + { 0.0 1.0 } + } n*M +] unit-test + +[ cmatrix{ + { C{ 2.0 1.0 } 0.0 } + { 0.0 C{ -1.0 2.0 } } +} ] [ + C{ 2.0 1.0 } cmatrix{ + { 1.0 0.0 } + { 0.0 C{ 0.0 1.0 } } + } n*M +] unit-test + +[ zmatrix{ + { C{ 2.0 1.0 } 0.0 } + { 0.0 C{ -1.0 2.0 } } +} ] [ + C{ 2.0 1.0 } zmatrix{ + { 1.0 0.0 } + { 0.0 C{ 0.0 1.0 } } + } n*M +] unit-test + +! Mrows, Mcols + +[ svector{ 3.0 3.0 3.0 } ] [ + 2 smatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mcols nth +] unit-test +[ svector{ 3.0 2.0 3.0 4.0 } ] [ + 2 smatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mrows nth +] unit-test +[ 3 ] [ + smatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mrows length +] unit-test +[ 4 ] [ + smatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mcols length +] unit-test +[ svector{ 3.0 3.0 3.0 } ] [ + 2 smatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mtranspose Mrows nth +] unit-test +[ svector{ 3.0 2.0 3.0 4.0 } ] [ + 2 smatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mtranspose Mcols nth +] unit-test +[ 3 ] [ + smatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mtranspose Mcols length +] unit-test +[ 4 ] [ + smatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mtranspose Mrows length +] unit-test + +[ dvector{ 3.0 3.0 3.0 } ] [ + 2 dmatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mcols nth +] unit-test +[ dvector{ 3.0 2.0 3.0 4.0 } ] [ + 2 dmatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mrows nth +] unit-test +[ 3 ] [ + dmatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mrows length +] unit-test +[ 4 ] [ + dmatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mcols length +] unit-test +[ dvector{ 3.0 3.0 3.0 } ] [ + 2 dmatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mtranspose Mrows nth +] unit-test +[ dvector{ 3.0 2.0 3.0 4.0 } ] [ + 2 dmatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mtranspose Mcols nth +] unit-test +[ 3 ] [ + dmatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mtranspose Mcols length +] unit-test +[ 4 ] [ + dmatrix{ + { 1.0 2.0 3.0 4.0 } + { 2.0 2.0 3.0 4.0 } + { 3.0 2.0 3.0 4.0 } + } Mtranspose Mrows length +] unit-test + +[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [ + 2 cmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mcols nth +] unit-test +[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [ + 2 cmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mrows nth +] unit-test +[ 3 ] [ + cmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mrows length +] unit-test +[ 4 ] [ + cmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mcols length +] unit-test +[ cvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [ + 2 cmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mtranspose Mrows nth +] unit-test +[ cvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [ + 2 cmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mtranspose Mcols nth +] unit-test +[ 3 ] [ + cmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mtranspose Mcols length +] unit-test +[ 4 ] [ + cmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mtranspose Mrows length +] unit-test + +[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [ + 2 zmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mcols nth +] unit-test +[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [ + 2 zmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mrows nth +] unit-test +[ 3 ] [ + zmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mrows length +] unit-test +[ 4 ] [ + zmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mcols length +] unit-test +[ zvector{ C{ 3.0 1.0 } C{ 3.0 2.0 } C{ 3.0 3.0 } } ] [ + 2 zmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mtranspose Mrows nth +] unit-test +[ zvector{ C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } ] [ + 2 zmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mtranspose Mcols nth +] unit-test +[ 3 ] [ + zmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mtranspose Mcols length +] unit-test +[ 4 ] [ + zmatrix{ + { C{ 1.0 1.0 } C{ 2.0 1.0 } C{ 3.0 1.0 } C{ 4.0 1.0 } } + { C{ 1.0 2.0 } C{ 2.0 2.0 } C{ 3.0 2.0 } C{ 4.0 2.0 } } + { C{ 1.0 3.0 } C{ 2.0 3.0 } C{ 3.0 3.0 } C{ 4.0 3.0 } } + } Mtranspose Mrows length +] unit-test + +! Msub + +[ smatrix{ + { 3.0 2.0 1.0 } + { 0.0 1.0 0.0 } +} ] [ + smatrix{ + { 0.0 1.0 2.0 3.0 2.0 } + { 1.0 0.0 3.0 2.0 1.0 } + { 2.0 3.0 0.0 1.0 0.0 } + } 1 2 2 3 Msub +] unit-test + +[ smatrix{ + { 3.0 0.0 } + { 2.0 1.0 } + { 1.0 0.0 } +} ] [ + smatrix{ + { 0.0 1.0 2.0 3.0 2.0 } + { 1.0 0.0 3.0 2.0 1.0 } + { 2.0 3.0 0.0 1.0 0.0 } + } Mtranspose 2 1 3 2 Msub +] unit-test + +[ dmatrix{ + { 3.0 2.0 1.0 } + { 0.0 1.0 0.0 } +} ] [ + dmatrix{ + { 0.0 1.0 2.0 3.0 2.0 } + { 1.0 0.0 3.0 2.0 1.0 } + { 2.0 3.0 0.0 1.0 0.0 } + } 1 2 2 3 Msub +] unit-test + +[ dmatrix{ + { 3.0 0.0 } + { 2.0 1.0 } + { 1.0 0.0 } +} ] [ + dmatrix{ + { 0.0 1.0 2.0 3.0 2.0 } + { 1.0 0.0 3.0 2.0 1.0 } + { 2.0 3.0 0.0 1.0 0.0 } + } Mtranspose 2 1 3 2 Msub +] unit-test + +[ cmatrix{ + { C{ 3.0 3.0 } 2.0 1.0 } + { 0.0 1.0 0.0 } +} ] [ + cmatrix{ + { 0.0 1.0 2.0 3.0 2.0 } + { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 } + { 2.0 3.0 0.0 1.0 0.0 } + } 1 2 2 3 Msub +] unit-test + +[ cmatrix{ + { C{ 3.0 3.0 } 0.0 } + { 2.0 1.0 } + { 1.0 0.0 } +} ] [ + cmatrix{ + { 0.0 1.0 2.0 3.0 2.0 } + { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 } + { 2.0 3.0 0.0 1.0 0.0 } + } Mtranspose 2 1 3 2 Msub +] unit-test + +[ zmatrix{ + { C{ 3.0 3.0 } 2.0 1.0 } + { 0.0 1.0 0.0 } +} ] [ + zmatrix{ + { 0.0 1.0 2.0 3.0 2.0 } + { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 } + { 2.0 3.0 0.0 1.0 0.0 } + } 1 2 2 3 Msub +] unit-test + +[ zmatrix{ + { C{ 3.0 3.0 } 0.0 } + { 2.0 1.0 } + { 1.0 0.0 } +} ] [ + zmatrix{ + { 0.0 1.0 2.0 3.0 2.0 } + { 1.0 0.0 C{ 3.0 3.0 } 2.0 1.0 } + { 2.0 3.0 0.0 1.0 0.0 } + } Mtranspose 2 1 3 2 Msub +] unit-test + diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor new file mode 100644 index 0000000000..aa172c954b --- /dev/null +++ b/extra/math/blas/matrices/matrices.factor @@ -0,0 +1,306 @@ +USING: accessors alien alien.c-types arrays byte-arrays combinators +combinators.lib combinators.short-circuit fry kernel locals macros +math math.blas.cblas math.blas.vectors math.blas.vectors.private +math.complex math.functions math.order multi-methods qualified +sequences sequences.private shuffle symbols ; +QUALIFIED: syntax +IN: math.blas.matrices + +TUPLE: blas-matrix-base data ld rows cols transpose ; +TUPLE: float-blas-matrix < blas-matrix-base ; +TUPLE: double-blas-matrix < blas-matrix-base ; +TUPLE: float-complex-blas-matrix < blas-matrix-base ; +TUPLE: double-complex-blas-matrix < blas-matrix-base ; + +C: float-blas-matrix +C: double-blas-matrix +C: float-complex-blas-matrix +C: double-complex-blas-matrix + +METHOD: element-type { float-blas-matrix } + drop "float" ; +METHOD: element-type { double-blas-matrix } + drop "double" ; +METHOD: element-type { float-complex-blas-matrix } + drop "CBLAS_C" ; +METHOD: element-type { double-complex-blas-matrix } + drop "CBLAS_Z" ; + +: Mtransposed? ( matrix -- ? ) + transpose>> ; inline +: Mwidth ( matrix -- width ) + dup Mtransposed? [ rows>> ] [ cols>> ] if ; inline +: Mheight ( matrix -- height ) + dup Mtransposed? [ cols>> ] [ rows>> ] if ; inline + +> [ CblasTrans ] [ CblasNoTrans ] if ; + +GENERIC: (blas-matrix-like) ( data ld rows cols transpose exemplar -- matrix ) + +METHOD: (blas-matrix-like) { object object object object object float-blas-matrix } + drop ; +METHOD: (blas-matrix-like) { object object object object object double-blas-matrix } + drop ; +METHOD: (blas-matrix-like) { object object object object object float-complex-blas-matrix } + drop ; +METHOD: (blas-matrix-like) { object object object object object double-complex-blas-matrix } + drop ; + +METHOD: (blas-matrix-like) { object object object object object float-blas-vector } + drop ; +METHOD: (blas-matrix-like) { object object object object object double-blas-vector } + drop ; +METHOD: (blas-matrix-like) { object object object object object float-complex-blas-vector } + drop ; +METHOD: (blas-matrix-like) { object object object object object double-complex-blas-vector } + drop ; + +METHOD: (blas-vector-like) { object object object float-blas-matrix } + drop ; +METHOD: (blas-vector-like) { object object object double-blas-matrix } + drop ; +METHOD: (blas-vector-like) { object object object float-complex-blas-matrix } + drop ; +METHOD: (blas-vector-like) { object object object double-complex-blas-matrix } + drop ; + +: (validate-gemv) ( A x y -- ) + { + [ drop [ Mwidth ] [ length>> ] bi* = ] + [ nip [ Mheight ] [ length>> ] bi* = ] + } 3&& + [ "Mismatched matrix and vectors in matrix-vector multiplication" throw ] 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 ) + A x y (validate-gemv) + CblasColMajor + A (blas-transpose) + A rows>> + A cols>> + alpha >c-arg call + A data>> + A ld>> + x data>> + x inc>> + beta >c-arg call + y data>> + y inc>> + y ; inline + +: (validate-ger) ( x y A -- ) + { + [ nip [ length>> ] [ Mheight ] bi* = ] + [ nipd [ length>> ] [ Mwidth ] bi* = ] + } 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 ) + x y A (validate-ger) + CblasColMajor + A rows>> + A cols>> + alpha >c-arg call + x data>> + x inc>> + y data>> + y inc>> + A data>> + A ld>> + A f >>transpose ; inline + +: (validate-gemm) ( A B C -- ) + { + [ drop [ Mwidth ] [ Mheight ] bi* = ] + [ nip [ Mheight ] bi@ = ] + [ nipd [ Mwidth ] bi@ = ] + } 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 ) + A B C (validate-gemm) + CblasColMajor + A (blas-transpose) + B (blas-transpose) + C rows>> + C cols>> + A Mwidth + alpha >c-arg call + A data>> + A ld>> + B data>> + B ld>> + beta >c-arg call + C data>> + C ld>> + C f >>transpose ; inline + +: (>matrix) ( arrays >c-array -- c-array ld rows cols transpose ) + [ flip ] dip + '[ concat @ ] [ first length dup ] [ length ] tri f ; inline + +PRIVATE> + +: >float-blas-matrix ( arrays -- matrix ) + [ >c-float-array ] (>matrix) ; +: >double-blas-matrix ( arrays -- matrix ) + [ >c-double-array ] (>matrix) ; +: >float-complex-blas-matrix ( arrays -- matrix ) + [ (flatten-complex-sequence) >c-float-array ] (>matrix) + ; +: >double-complex-blas-matrix ( arrays -- matrix ) + [ (flatten-complex-sequence) >c-double-array ] (>matrix) + ; + +GENERIC: n*M.V+n*V-in-place ( alpha A x beta y -- y=alpha*A.x+b*y ) +GENERIC: n*V(*)V+M-in-place ( alpha x y A -- A=alpha*x(*)y+A ) +GENERIC: n*V(*)Vconj+M-in-place ( alpha x y A -- A=alpha*x(*)yconj+A ) +GENERIC: n*M.M+n*M-in-place ( alpha A B beta C -- C=alpha*A.B+beta*C ) + +METHOD: n*M.V+n*V-in-place { real float-blas-matrix float-blas-vector real float-blas-vector } + [ ] (prepare-gemv) [ cblas_sgemv ] dip ; +METHOD: n*M.V+n*V-in-place { real double-blas-matrix double-blas-vector real double-blas-vector } + [ ] (prepare-gemv) [ cblas_dgemv ] dip ; +METHOD: n*M.V+n*V-in-place { number float-complex-blas-matrix float-complex-blas-vector number float-complex-blas-vector } + [ (>c-complex) ] (prepare-gemv) [ cblas_cgemv ] dip ; +METHOD: n*M.V+n*V-in-place { number double-complex-blas-matrix double-complex-blas-vector number double-complex-blas-vector } + [ (>z-complex) ] (prepare-gemv) [ cblas_zgemv ] dip ; + +METHOD: n*V(*)V+M-in-place { real float-blas-vector float-blas-vector float-blas-matrix } + [ ] (prepare-ger) [ cblas_sger ] dip ; +METHOD: n*V(*)V+M-in-place { real double-blas-vector double-blas-vector double-blas-matrix } + [ ] (prepare-ger) [ cblas_dger ] dip ; +METHOD: n*V(*)V+M-in-place { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix } + [ (>c-complex) ] (prepare-ger) [ cblas_cgeru ] dip ; +METHOD: n*V(*)V+M-in-place { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix } + [ (>z-complex) ] (prepare-ger) [ cblas_zgeru ] dip ; + +METHOD: n*V(*)Vconj+M-in-place { number float-complex-blas-vector float-complex-blas-vector float-complex-blas-matrix } + [ (>c-complex) ] (prepare-ger) [ cblas_cgerc ] dip ; +METHOD: n*V(*)Vconj+M-in-place { number double-complex-blas-vector double-complex-blas-vector double-complex-blas-matrix } + [ (>z-complex) ] (prepare-ger) [ cblas_zgerc ] dip ; + +METHOD: n*M.M+n*M-in-place { real float-blas-matrix float-blas-matrix real float-blas-matrix } + [ ] (prepare-gemm) [ cblas_sgemm ] dip ; +METHOD: n*M.M+n*M-in-place { real double-blas-matrix double-blas-matrix real double-blas-matrix } + [ ] (prepare-gemm) [ cblas_dgemm ] dip ; +METHOD: n*M.M+n*M-in-place { number float-complex-blas-matrix float-complex-blas-matrix number float-complex-blas-matrix } + [ (>c-complex) ] (prepare-gemm) [ cblas_cgemm ] dip ; +METHOD: n*M.M+n*M-in-place { number double-complex-blas-matrix double-complex-blas-matrix number double-complex-blas-matrix } + [ (>z-complex) ] (prepare-gemm) [ cblas_zgemm ] dip ; + +! XXX should do a dense clone +syntax:M: blas-matrix-base clone + [ + [ + { data>> ld>> cols>> element-type } get-slots + heap-size * * memory>byte-array + ] [ { ld>> rows>> cols>> transpose>> } get-slots ] bi + ] keep (blas-matrix-like) ; + +! XXX try rounding stride to next 128 bit bound for better vectorizin' +: empty-matrix ( rows cols exemplar -- matrix ) + [ element-type [ * ] dip ] + [ 2drop ] + [ f swap (blas-matrix-like) ] 3tri ; + +: n*M.V+n*V ( alpha A x beta y -- alpha*A.x+b*y ) + clone n*M.V+n*V-in-place ; +: n*V(*)V+M ( alpha x y A -- alpha*x(*)y+A ) + clone n*V(*)V+M-in-place ; +: n*V(*)Vconj+M ( alpha x y A -- alpha*x(*)yconj+A ) + clone n*V(*)Vconj+M-in-place ; +: n*M.M+n*M ( alpha A B beta C -- alpha*A.B+beta*C ) + clone n*M.M+n*M-in-place ; + +: n*M.V ( alpha A x -- alpha*A.x ) + 1.0 2over [ Mheight ] dip empty-vector + n*M.V+n*V-in-place ; inline + +: M.V ( A x -- A.x ) + 1.0 -rot n*M.V ; inline + +: n*V(*)V ( n x y -- n*x(*)y ) + 2dup [ length>> ] bi@ pick empty-matrix + n*V(*)V+M-in-place ; +: n*V(*)Vconj ( n x y -- n*x(*)yconj ) + 2dup [ length>> ] bi@ pick empty-matrix + n*V(*)Vconj+M-in-place ; + +: V(*) ( x y -- x(*)y ) + 1.0 -rot n*V(*)V ; inline +: V(*)conj ( x y -- x(*)yconj ) + 1.0 -rot n*V(*)Vconj ; inline + +: n*M.M ( n A B -- n*A.B ) + 2dup [ Mheight ] [ Mwidth ] bi* pick empty-matrix + 1.0 swap n*M.M+n*M-in-place ; + +: M. ( A B -- A.B ) + 1.0 -rot n*M.M ; inline + +:: (Msub) ( matrix row col height width -- data ld rows cols ) + matrix ld>> col * row + matrix element-type heap-size * + matrix data>> + matrix ld>> + height + width ; + +: Msub ( matrix row col height width -- submatrix ) + 5 npick dup transpose>> + [ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep + swap (blas-matrix-like) ; + +TUPLE: blas-matrix-rowcol-sequence parent inc rowcol-length rowcol-jump length ; +C: blas-matrix-rowcol-sequence + +INSTANCE: blas-matrix-rowcol-sequence sequence + +syntax:M: blas-matrix-rowcol-sequence length + length>> ; +syntax:M: blas-matrix-rowcol-sequence nth-unsafe + { + [ + [ rowcol-jump>> ] + [ parent>> element-type heap-size ] + [ parent>> data>> ] tri + [ * * ] dip + ] + [ rowcol-length>> ] + [ inc>> ] + [ parent>> ] + } cleave (blas-vector-like) ; + +: (Mcols) ( A -- columns ) + { [ ] [ drop 1 ] [ rows>> ] [ ld>> ] [ cols>> ] } cleave + ; +: (Mrows) ( A -- rows ) + { [ ] [ ld>> ] [ cols>> ] [ drop 1 ] [ rows>> ] } cleave + ; + +: Mrows ( A -- rows ) + dup transpose>> [ (Mcols) ] [ (Mrows) ] if ; +: Mcols ( A -- rows ) + dup transpose>> [ (Mrows) ] [ (Mcols) ] if ; + +: n*M-in-place ( n A -- A=n*A ) + [ (Mcols) [ n*V-in-place drop ] with each ] keep ; + +: n*M ( n A -- n*A ) + clone n*M-in-place ; inline + +: M*n ( A n -- A*n ) + swap n*M ; inline +: M/n ( A n -- A/n ) + recip swap n*M ; inline + +: Mtranspose ( matrix -- matrix^T ) + [ { data>> ld>> rows>> cols>> transpose>> } get-slots not ] keep (blas-matrix-like) ; + +syntax:M: blas-matrix-base equal? + { + [ [ Mwidth ] bi@ = ] + [ [ Mcols ] bi@ [ = ] 2all? ] + } 2&& ; + diff --git a/extra/math/blas/matrices/summary.txt b/extra/math/blas/matrices/summary.txt new file mode 100644 index 0000000000..4cc5684789 --- /dev/null +++ b/extra/math/blas/matrices/summary.txt @@ -0,0 +1 @@ +BLAS level 2 and 3 matrix-vector and matrix-matrix operations diff --git a/extra/math/blas/matrices/tags.txt b/extra/math/blas/matrices/tags.txt new file mode 100644 index 0000000000..241ec1ecda --- /dev/null +++ b/extra/math/blas/matrices/tags.txt @@ -0,0 +1,2 @@ +math +bindings diff --git a/extra/math/blas/syntax/syntax.factor b/extra/math/blas/syntax/syntax.factor index e0fc9e5bc7..895e6f3d99 100644 --- a/extra/math/blas/syntax/syntax.factor +++ b/extra/math/blas/syntax/syntax.factor @@ -1,4 +1,4 @@ -USING: kernel math.blas.vectors parser ; +USING: kernel math.blas.matrices math.blas.vectors parser ; IN: math.blas.syntax : svector{ ( accum -- accum ) @@ -10,3 +10,11 @@ IN: math.blas.syntax : zvector{ ( accum -- accum ) \ } [ >double-complex-blas-vector ] parse-literal ; parsing +: smatrix{ ( accum -- accum ) + \ } [ >float-blas-matrix ] parse-literal ; parsing +: dmatrix{ ( accum -- accum ) + \ } [ >double-blas-matrix ] parse-literal ; parsing +: cmatrix{ ( accum -- accum ) + \ } [ >float-complex-blas-matrix ] parse-literal ; parsing +: zmatrix{ ( accum -- accum ) + \ } [ >double-complex-blas-matrix ] parse-literal ; parsing diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor index acb28aca62..3da95f3079 100644 --- a/extra/math/blas/vectors/vectors.factor +++ b/extra/math/blas/vectors/vectors.factor @@ -1,7 +1,7 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators -fry kernel macros math math.blas.cblas math.complex math.functions -math.order multi-methods qualified sequences sequences.private -shuffle ; +combinators.short-circuit fry kernel macros math math.blas.cblas +math.complex math.functions math.order multi-methods qualified +sequences sequences.private shuffle ; QUALIFIED: syntax IN: math.blas.vectors @@ -135,10 +135,10 @@ PRIVATE> [ length>> 0 ] [ (blas-vector-like) ] tri ; -: empty-vector ( exemplar -- empty-vector ) - [ [ length>> ] [ element-type ] bi ] - [ length>> 1 ] - [ (blas-vector-like) ] tri ; +: empty-vector ( length exemplar -- empty-vector ) + [ element-type ] + [ 1 swap ] 2bi + (blas-vector-like) ; syntax:M: blas-vector-base length length>> ; @@ -163,6 +163,12 @@ syntax:M: double-complex-blas-vector nth-unsafe syntax:M: double-complex-blas-vector set-nth-unsafe (prepare-nth) (set-z-complex-nth) ; +syntax:M: blas-vector-base equal? + { + [ [ length ] bi@ = ] + [ [ = ] 2all? ] + } 2&& ; + : >float-blas-vector ( seq -- v ) [ >c-float-array ] [ length ] bi 1 ; : >double-blas-vector ( seq -- v ) @@ -218,22 +224,21 @@ METHOD: n*V-in-place { number double-complex-blas-vector } [ (>z-complex) ] dip (prepare-scal) [ cblas_zscal ] dip ; -: n*V+V ( n v1 v2 -- n*v1+v2 ) clone n*V+V-in-place ; -: n*V ( n v1 -- n*v1 ) clone n*V-in-place ; -! : n*V ( n v1 -- n*v1 ) dup empty-vector n*V+V-in-place ; ! XXX which is faster? +: n*V+V ( n v1 v2 -- n*v1+v2 ) clone n*V+V-in-place ; inline +: n*V ( n v1 -- n*v1 ) clone n*V-in-place ; inline : V+ ( v1 v2 -- v1+v2 ) - 1.0 -rot n*V+V ; + 1.0 -rot n*V+V ; inline : V- ( v1 v2 -- v1-v2 ) - -1.0 spin n*V+V ; + -1.0 spin n*V+V ; inline : Vneg ( v1 -- -v1 ) - [ zero-vector ] keep V- ; + [ zero-vector ] keep V- ; inline : V*n ( v n -- v*n ) - swap n*V ; + swap n*V ; inline : V/n ( v n -- v*n ) - recip swap n*V ; + recip swap n*V ; inline METHOD: V. { float-blas-vector float-blas-vector } (prepare-dot) cblas_sdot ; @@ -281,4 +286,4 @@ METHOD: Viamax { double-complex-blas-vector } (prepare-nrm2) cblas_izamax ; : Vamax ( v -- max ) - [ Viamax ] keep nth ; + [ Viamax ] keep nth ; inline From 2f06b42750a2277f312a101f1e5d5945eff38230 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Fri, 4 Jul 2008 20:59:08 -0700 Subject: [PATCH 12/77] Revert "Shorthand syntax for arrays-of-arrays, arrays-of-quotations, and hashtables" This reverts commit 340abc119a0bc073785b2546406780c1f22c5657. --- extra/arrays/nested-syntax/authors.txt | 1 - .../nested-syntax/nested-syntax-docs.factor | 29 ------------------- .../nested-syntax/nested-syntax-tests.factor | 11 ------- .../arrays/nested-syntax/nested-syntax.factor | 10 ------- extra/arrays/nested-syntax/summary.txt | 1 - extra/arrays/nested-syntax/tags.txt | 1 - 6 files changed, 53 deletions(-) delete mode 100644 extra/arrays/nested-syntax/authors.txt delete mode 100644 extra/arrays/nested-syntax/nested-syntax-docs.factor delete mode 100644 extra/arrays/nested-syntax/nested-syntax-tests.factor delete mode 100644 extra/arrays/nested-syntax/nested-syntax.factor delete mode 100644 extra/arrays/nested-syntax/summary.txt delete mode 100644 extra/arrays/nested-syntax/tags.txt diff --git a/extra/arrays/nested-syntax/authors.txt b/extra/arrays/nested-syntax/authors.txt deleted file mode 100644 index f13c9c1e77..0000000000 --- a/extra/arrays/nested-syntax/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Joe Groff diff --git a/extra/arrays/nested-syntax/nested-syntax-docs.factor b/extra/arrays/nested-syntax/nested-syntax-docs.factor deleted file mode 100644 index 7933aa0882..0000000000 --- a/extra/arrays/nested-syntax/nested-syntax-docs.factor +++ /dev/null @@ -1,29 +0,0 @@ -USING: help.markup help.syntax ; -IN: arrays.nested-syntax - -HELP: {{ -{ $syntax "{{ zim zang ;; zoop ;; zidilly zam ;; ... }}" } -{ $description "Shorthand for a literal array of arrays. Subarrays are separated by the " { $link POSTPONE: ;; } " token." } -{ $examples "The following blocks of code push an equivalent array onto the stack:" { $example "{{ 1 ;; 2 3 ;; 4 5 6 }}" } { $example "{ { 1 } { 2 3 } { 4 5 6 } }" } } ; - -HELP: H{{ -{ $syntax "H{{ zim zang ;; zoop zidilly ;; zam zung ;; ... }}" } -{ $description "Shorthand for a literal hashtable. Key-value pairs are separated by the " { $link POSTPONE: ;; } " token." } -{ $examples "The following blocks of code push an equivalent hash table onto the stack:" { $example "H{{ \"Monday\" 1 ;; \"Tuesday\" 2 ;; \"Wednesday\" 3 ;; \"Thursday\" 4 }}" } { $example "H{ { \"Monday\" 1 } { \"Tuesday\" 2 } { \"Wednesday\" 3 } { \"Thursday\" 4 } }" } } ; - -HELP: [[ -{ $syntax "[[ foo ;; bar bas ;; qux quux quuuux ;; ... ]]" } -{ $description "Shorthand for a literal array of quotations. Each quotation is separated by the " { $link POSTPONE: ;; } " token." } -{ $examples "The following blocks of code are equivalent:" { $example "[[ 1+ ;; 2 + ]] cleave" } { $example "{ [ 1+ ] [ 2 + ] } cleave" } } ; - -{ POSTPONE: {{ POSTPONE: H{{ POSTPONE: [[ } related-words - -HELP: ;; -{ $description "Separator token used in the " { $link POSTPONE: {{ } ", " { $link POSTPONE: H{{ } ", and " { $link POSTPONE: [[ } " literal syntaxes." } ; - -HELP: }} -{ $description "Delimiter token used to close the " { $link POSTPONE: {{ } " and " { $link POSTPONE: H{{ } " literal syntaxes." } ; - -HELP: ]] -{ $description "Delimiter token used to close the " { $link POSTPONE: [[ } " literal syntax." } ; - diff --git a/extra/arrays/nested-syntax/nested-syntax-tests.factor b/extra/arrays/nested-syntax/nested-syntax-tests.factor deleted file mode 100644 index a709840be4..0000000000 --- a/extra/arrays/nested-syntax/nested-syntax-tests.factor +++ /dev/null @@ -1,11 +0,0 @@ -USING: arrays.nested-syntax kernel tools.test ; -IN: arrays.nested-syntax.tests - -[ { { 1 } { 2 3 } { 4 5 6 } } ] -[ {{ 1 ;; 2 3 ;; 4 5 6 }} ] unit-test - -[ H{ { "foo" 1 } { "bar" 2 } { "bas" 3 } } ] -[ H{{ "foo" 1 ;; "bar" 2 ;; "bas" 3 }} ] unit-test - -[ { [ drop ] [ nip ] } ] -[ [[ drop ;; nip ]] ] unit-test diff --git a/extra/arrays/nested-syntax/nested-syntax.factor b/extra/arrays/nested-syntax/nested-syntax.factor deleted file mode 100644 index 9fae0fba9f..0000000000 --- a/extra/arrays/nested-syntax/nested-syntax.factor +++ /dev/null @@ -1,10 +0,0 @@ -USING: arrays hashtables kernel parser quotations sequences splitting ; -IN: arrays.nested-syntax - -: ;; ( -- * ) ";; can only be used in [[ ]] , {{ }} , or H{{ }} blocks" throw ; -DEFER: ]] delimiter -DEFER: }} delimiter - -: [[ \ ]] [ { POSTPONE: ;; } split [ >quotation ] map ] parse-literal ; parsing -: {{ \ }} [ { POSTPONE: ;; } split [ >array ] map ] parse-literal ; parsing -: H{{ \ }} [ { POSTPONE: ;; } split >hashtable ] parse-literal ; parsing diff --git a/extra/arrays/nested-syntax/summary.txt b/extra/arrays/nested-syntax/summary.txt deleted file mode 100644 index a8d507f2ca..0000000000 --- a/extra/arrays/nested-syntax/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Shorthand syntax for defining arrays of quotations or arrays of arrays diff --git a/extra/arrays/nested-syntax/tags.txt b/extra/arrays/nested-syntax/tags.txt deleted file mode 100644 index f4274299b1..0000000000 --- a/extra/arrays/nested-syntax/tags.txt +++ /dev/null @@ -1 +0,0 @@ -extensions From bae00e8bab84775d844ed8757e7abf861fc55987 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 4 Jul 2008 23:03:03 -0500 Subject: [PATCH 13/77] Better optimizer report --- extra/reports/optimizer/optimizer.factor | 27 ++++++++++++++++++------ 1 file changed, 20 insertions(+), 7 deletions(-) diff --git a/extra/reports/optimizer/optimizer.factor b/extra/reports/optimizer/optimizer.factor index 5016371052..ec3668b83b 100755 --- a/extra/reports/optimizer/optimizer.factor +++ b/extra/reports/optimizer/optimizer.factor @@ -2,20 +2,31 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs words sequences arrays compiler tools.time io.styles io prettyprint vocabs kernel sorting -generator optimizer math math.order ; +generator optimizer math math.order math.statistics combinators ; IN: report.optimizer : count-optimization-passes ( nodes n -- n ) >r optimize-1 [ r> 1+ count-optimization-passes ] [ drop r> ] if ; -: results - [ [ second ] prepose compare ] curry sort 20 tail* - print +: table. ( alist -- ) + 20 short tail* standard-table-style [ [ [ [ pprint-cell ] each ] with-row ] each - ] tabular-output ; inline + ] tabular-output ; + +: results ( results quot title -- ) + print + [ second ] prepose + [ [ compare ] curry sort table. ] + [ + map + [ "Mean: " write mean >float . ] + [ "Median: " write median >float . ] + [ "Standard deviation: " write std >float . ] + tri + ] 2bi ; inline : optimizer-measurements ( -- alist ) all-words [ compiled>> ] filter @@ -26,8 +37,10 @@ IN: report.optimizer ] { } map>assoc ; : optimizer-measurements. ( alist -- ) - [ [ first ] "Worst number of optimizer passes:" results ] - [ [ second ] "Worst compile times:" results ] bi ; + { + [ [ first ] "Optimizer passes:" results ] + [ [ second ] "Compile times:" results ] + } cleave ; : optimizer-report ( -- ) optimizer-measurements optimizer-measurements. ; From b0d11073d693095018e31aa0d30c4ab2f65e75e8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 00:59:28 -0500 Subject: [PATCH 14/77] Fix step-into on generic words and call-next-method in walker --- core/generic/standard/standard-tests.factor | 8 ++++++++ core/generic/standard/standard.factor | 4 +++- extra/tools/walker/walker-tests.factor | 6 +++++- extra/tools/walker/walker.factor | 4 ++++ 4 files changed, 20 insertions(+), 2 deletions(-) diff --git a/core/generic/standard/standard-tests.factor b/core/generic/standard/standard-tests.factor index 9cee497d6d..54fc3c8ca3 100644 --- a/core/generic/standard/standard-tests.factor +++ b/core/generic/standard/standard-tests.factor @@ -309,3 +309,11 @@ M: xref-tuple-2 xref-test (xref-test) ; \ xref-test \ xref-tuple-2 \ xref-test method [ usage unique ] closure key? ] unit-test + +[ t ] [ + { } \ nth effective-method nip \ sequence \ nth method eq? +] unit-test + +[ t ] [ + \ + \ nth effective-method nip dup \ nth "default-method" word-prop eq? and +] unit-test diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 89c2a2a396..f8b3c00c31 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -105,7 +105,9 @@ ERROR: no-next-method class generic ; ] [ ] make ; : single-effective-method ( obj word -- method ) - [ order [ instance? ] with find-last nip ] keep method ; + [ [ order [ instance? ] with find-last nip ] keep method ] + [ "default-method" word-prop ] + bi or ; TUPLE: standard-combination # ; diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor index 2d4a6c3396..7f154a4dbf 100755 --- a/extra/tools/walker/walker-tests.factor +++ b/extra/tools/walker/walker-tests.factor @@ -1,6 +1,7 @@ USING: tools.walker io io.streams.string kernel math math.private namespaces prettyprint sequences tools.test -continuations math.parser threads arrays tools.walker.debug ; +continuations math.parser threads arrays tools.walker.debug +generic.standard ; IN: tools.walker.tests [ { } ] [ @@ -97,6 +98,9 @@ IN: tools.walker.tests [ { 6 } ] [ [ [ 3 throw ] [ 2 * ] recover ] test-walker ] unit-test +[ { T{ no-method f + nth } } ] +[ [ [ 0 \ + nth ] [ ] recover ] test-walker ] unit-test + [ { } ] [ [ "a" "b" set "c" "d" set [ ] test-walker ] with-scope ] unit-test diff --git a/extra/tools/walker/walker.factor b/extra/tools/walker/walker.factor index 07a5759af2..3d7ee035dc 100755 --- a/extra/tools/walker/walker.factor +++ b/extra/tools/walker/walker.factor @@ -83,6 +83,9 @@ M: object add-breakpoint ; : (step-into-continuation) ( -- ) continuation callstack >>call break ; +: (step-into-call-next-method) ( class generic -- ) + next-method-quot (step-into-quot) ; + ! Messages sent to walker thread SYMBOL: step SYMBOL: step-out @@ -132,6 +135,7 @@ SYMBOL: +stopped+ { if [ (step-into-if) ] } { dispatch [ (step-into-dispatch) ] } { continuation [ (step-into-continuation) ] } + { (call-next-method) [ (step-into-call-next-method) ] } } [ "step-into" set-word-prop ] assoc-each { From 44c1c1f679c32e069d07d61c0af15e1b6946a19d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 00:59:39 -0500 Subject: [PATCH 15/77] Move tuple-class to classes.tuple where it belongs --- core/classes/algebra/algebra.factor | 106 ++++++------------ core/classes/builtin/builtin.factor | 26 ++++- core/classes/classes-docs.factor | 4 - core/classes/classes.factor | 3 - core/classes/intersection/intersection.factor | 2 +- core/classes/predicate/predicate.factor | 10 +- core/classes/tuple/tuple-docs.factor | 4 + core/classes/tuple/tuple.factor | 17 ++- core/classes/union/union.factor | 2 +- core/generator/registers/registers.factor | 2 +- core/slots/slots-docs.factor | 2 +- extra/delegate/delegate.factor | 6 +- 12 files changed, 93 insertions(+), 91 deletions(-) diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index b7e4bebe15..9dbe72d9cb 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -1,10 +1,22 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes classes.builtin combinators accessors -sequences arrays vectors assocs namespaces words sorting layouts -math hashtables kernel.private sets math.order ; +USING: kernel classes combinators accessors sequences arrays +vectors assocs namespaces words sorting layouts math hashtables +kernel.private sets math.order ; IN: classes.algebra +TUPLE: anonymous-union members ; + +C: anonymous-union + +TUPLE: anonymous-intersection participants ; + +C: anonymous-intersection + +TUPLE: anonymous-complement class ; + +C: anonymous-complement + : 2cache ( key1 key2 assoc quot -- value ) >r >r 2array r> [ first2 ] r> compose cache ; inline @@ -18,10 +30,19 @@ DEFER: (class-not) : class-not ( class -- complement ) class-not-cache get [ (class-not) ] cache ; -DEFER: (classes-intersect?) ( first second -- ? ) +GENERIC: (classes-intersect?) ( first second -- ? ) + +: normalize-class ( class -- class' ) + { + { [ dup members ] [ members ] } + { [ dup participants ] [ participants ] } + [ ] + } cond ; : classes-intersect? ( first second -- ? ) - classes-intersect-cache get [ (classes-intersect?) ] 2cache ; + classes-intersect-cache get [ + normalize-class (classes-intersect?) + ] 2cache ; DEFER: (class-and) @@ -33,18 +54,6 @@ DEFER: (class-or) : class-or ( first second -- class ) class-or-cache get [ (class-or) ] 2cache ; -TUPLE: anonymous-union members ; - -C: anonymous-union - -TUPLE: anonymous-intersection participants ; - -C: anonymous-intersection - -TUPLE: anonymous-complement class ; - -C: anonymous-complement - : superclass<= ( first second -- ? ) >r superclass r> class<= ; @@ -63,13 +72,6 @@ C: anonymous-complement : anonymous-complement<= ( first second -- ? ) [ class>> ] bi@ swap class<= ; -: normalize-class ( class -- class' ) - { - { [ dup members ] [ members ] } - { [ dup participants ] [ participants ] } - [ ] - } cond ; - : normalize-complement ( class -- class' ) class>> normalize-class { { [ dup anonymous-union? ] [ @@ -116,40 +118,15 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; } cond ] if ; -: anonymous-union-intersect? ( first second -- ? ) +M: anonymous-union (classes-intersect?) members>> [ classes-intersect? ] with contains? ; -: anonymous-intersection-intersect? ( first second -- ? ) +M: anonymous-intersection (classes-intersect?) participants>> [ classes-intersect? ] with all? ; -: anonymous-complement-intersect? ( first second -- ? ) +M: anonymous-complement (classes-intersect?) class>> class<= not ; -: tuple-class-intersect? ( first second -- ? ) - { - { [ over tuple eq? ] [ 2drop t ] } - { [ over builtin-class? ] [ 2drop f ] } - { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] } - [ swap classes-intersect? ] - } cond ; - -: builtin-class-intersect? ( first second -- ? ) - { - { [ 2dup eq? ] [ 2drop t ] } - { [ over builtin-class? ] [ 2drop f ] } - [ swap classes-intersect? ] - } cond ; - -: (classes-intersect?) ( first second -- ? ) - normalize-class { - { [ dup anonymous-union? ] [ anonymous-union-intersect? ] } - { [ dup anonymous-intersection? ] [ anonymous-intersection-intersect? ] } - { [ dup anonymous-complement? ] [ anonymous-complement-intersect? ] } - { [ dup tuple-class? ] [ tuple-class-intersect? ] } - { [ dup builtin-class? ] [ builtin-class-intersect? ] } - { [ dup superclass ] [ superclass classes-intersect? ] } - } cond ; - : anonymous-union-and ( first second -- class ) members>> [ class-and ] with map ; @@ -225,26 +202,13 @@ PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; tuck [ class<= ] with all? [ peek ] [ drop f ] if ] if ; -DEFER: (flatten-class) -DEFER: flatten-builtin-class +GENERIC: (flatten-class) ( class -- ) -: flatten-intersection-class ( class -- ) - participants [ flatten-builtin-class ] map - dup empty? [ - drop builtins get [ (flatten-class) ] each - ] [ - unclip [ assoc-intersect ] reduce [ swap set ] assoc-each - ] if ; +M: anonymous-union (flatten-class) + members>> [ (flatten-class) ] each ; -: (flatten-class) ( class -- ) - { - { [ dup tuple-class? ] [ dup set ] } - { [ dup builtin-class? ] [ dup set ] } - { [ dup members ] [ members [ (flatten-class) ] each ] } - { [ dup participants ] [ flatten-intersection-class ] } - { [ dup superclass ] [ superclass (flatten-class) ] } - [ drop ] - } cond ; +M: word (flatten-class) + normalize-class (flatten-class) ; : flatten-class ( class -- assoc ) [ (flatten-class) ] H{ } make-assoc ; @@ -258,7 +222,7 @@ DEFER: flatten-builtin-class flatten-builtin-class keys [ "type" word-prop ] map natural-sort ; -: class-tags ( class -- tag/f ) +: class-tags ( class -- seq ) class-types [ dup num-tags get >= [ drop \ hi-tag tag-number ] when diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index acbbc5e841..f349d0a126 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes words kernel kernel.private namespaces -sequences math math.private ; +USING: accessors classes classes.algebra words kernel +kernel.private namespaces sequences math math.private +combinators assocs ; IN: classes.builtin SYMBOL: builtins @@ -31,3 +32,24 @@ M: builtin-class rank-class drop 0 ; M: builtin-class instance? class>type builtin-instance? ; + +M: builtin-class (flatten-class) dup set ; + +M: builtin-class (classes-intersect?) + { + { [ 2dup eq? ] [ 2drop t ] } + { [ over builtin-class? ] [ 2drop f ] } + [ swap classes-intersect? ] + } cond ; + +M: anonymous-intersection (flatten-class) + participants>> + participants [ flatten-builtin-class ] map + dup empty? [ + drop builtins get sift [ (flatten-class) ] each + ] [ + unclip [ assoc-intersect ] reduce [ swap set ] assoc-each + ] if ; + +M: anonymous-complement (flatten-class) + drop builtins get sift [ (flatten-class) ] each ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 5f02212bad..fcad00bb18 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -65,10 +65,6 @@ HELP: classes { $values { "seq" "a sequence of class words" } } { $description "Finds all class words in the dictionary." } ; -HELP: tuple-class -{ $class-description "The class of tuple class words." } -{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; - HELP: update-map { $var-description "Assoc mapping each class to a set of classes defined in terms of this class. The " { $link define-class } " word uses this information to update generic words when classes are redefined." } ; diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 56c3b0a0ab..34f2fcf196 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -32,9 +32,6 @@ SYMBOL: implementors-map PREDICATE: class < word "class" word-prop ; -PREDICATE: tuple-class < class - "metaclass" word-prop tuple-class eq? ; - : classes ( -- seq ) implementors-map get keys ; : predicate-word ( word -- predicate ) diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 0eae1b62d3..5df580d82f 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -namespaces arrays math quotations ; +classes.algebra classes.builtin namespaces arrays math quotations ; IN: classes.intersection PREDICATE: intersection-class < class diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor index 3067b7d9dd..e6d6b5a0d4 100755 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: classes kernel namespaces words sequences quotations -arrays kernel.private assocs combinators ; +USING: classes classes.algebra kernel namespaces words sequences +quotations arrays kernel.private assocs combinators ; IN: classes.predicate PREDICATE: predicate-class < class @@ -51,3 +51,9 @@ M: predicate-class rank-class drop 1 ; M: predicate-class instance? 2dup superclass instance? [ predicate-instance? ] [ 2drop f ] if ; + +M: predicate-class (flatten-class) + superclass (flatten-class) ; + +M: predicate-class (classes-intersect?) + superclass classes-intersect? ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 8c2525731e..fd8b450eed 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -332,6 +332,10 @@ $nl ABOUT: "tuples" +HELP: tuple-class +{ $class-description "The class of tuple class words." } +{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; + HELP: tuple= { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } } { $description "Low-level tuple equality test. User code should use " { $link = } " instead." } diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 83d85b68d8..e85905a551 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -3,10 +3,13 @@ USING: arrays definitions hashtables kernel kernel.private math namespaces sequences sequences.private strings vectors words quotations memory combinators generic classes classes.algebra -classes.private slots.deprecated slots.private slots -compiler.units math.private accessors assocs effects ; +classes.builtin classes.private slots.deprecated slots.private +slots compiler.units math.private accessors assocs effects ; IN: classes.tuple +PREDICATE: tuple-class < class + "metaclass" word-prop tuple-class eq? ; + M: tuple class 1 slot 2 slot { word } declare ; ERROR: not-a-tuple object ; @@ -289,6 +292,16 @@ M: tuple-class rank-class drop 0 ; M: tuple-class instance? dup tuple-layout echelon>> tuple-instance? ; +M: tuple-class (flatten-class) dup set ; + +M: tuple-class (classes-intersect?) + { + { [ over tuple eq? ] [ 2drop t ] } + { [ over builtin-class? ] [ 2drop f ] } + { [ over tuple-class? ] [ [ class<= ] [ swap class<= ] 2bi or ] } + [ swap classes-intersect? ] + } cond ; + M: tuple clone (clone) dup delegate clone over set-delegate ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 6ae4e1bdc3..e3deb25e7a 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -namespaces arrays math quotations ; +classes.algebra namespaces arrays math quotations ; IN: classes.union PREDICATE: union-class < class diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 61e2b82f4f..550bab72f4 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -563,7 +563,7 @@ M: loc lazy-store ] if ; : class-tag ( class -- tag/f ) - class-tags dup length 1 = [ first ] [ drop f ] if ; + dup [ class-tags dup length 1 = [ first ] [ drop f ] if ] when ; : class-matches? ( actual expected -- ? ) { diff --git a/core/slots/slots-docs.factor b/core/slots/slots-docs.factor index b11d656b03..39a501c7f8 100755 --- a/core/slots/slots-docs.factor +++ b/core/slots/slots-docs.factor @@ -2,7 +2,7 @@ USING: help.markup help.syntax generic kernel.private parser words kernel quotations namespaces sequences words arrays effects generic.standard classes.builtin slots.private classes strings math assocs byte-arrays alien -math ; +math classes.tuple ; IN: slots ARTICLE: "accessors" "Slot accessors" diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 915ad0c648..6cea58058e 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2007 Daniel Ehrenberg ! See http://factorcode.org/license.txt for BSD license. -USING: accessors parser generic kernel classes words slots assocs -sequences arrays vectors definitions prettyprint -math hashtables sets macros namespaces ; +USING: accessors parser generic kernel classes classes.tuple +words slots assocs sequences arrays vectors definitions +prettyprint math hashtables sets macros namespaces ; IN: delegate : protocol-words ( protocol -- words ) From d9bb18b193838be76511535345ba17930692ee21 Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 5 Jul 2008 03:07:10 -0500 Subject: [PATCH 16/77] More aggressive tree shaker --- extra/tools/deploy/shaker/shaker.factor | 37 +++++++++++++++++++++---- 1 file changed, 31 insertions(+), 6 deletions(-) diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index 05bf3c9642..2dd334d024 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -4,7 +4,7 @@ USING: accessors qualified io.streams.c init fry namespaces assocs kernel parser lexer strings.parser tools.deploy.config vocabs sequences words words.private memory kernel.private continuations io prettyprint vocabs.loader debugger system -strings sets ; +strings sets vectors quotations byte-arrays ; QUALIFIED: bootstrap.stage2 QUALIFIED: classes QUALIFIED: command-line @@ -79,8 +79,8 @@ IN: tools.deploy.shaker [ [ props>> swap - '[ drop , member? not ] assoc-filter - sift-assoc f assoc-like + '[ drop , member? not ] assoc-filter sift-assoc + dup assoc-empty? [ drop f ] [ >alist >vector ] if ] keep (>>props) ] with each ; @@ -93,7 +93,10 @@ IN: tools.deploy.shaker "compiled-uses" "constraints" "declared-effect" + "default" + "default-method" "default-output-classes" + "derived-from" "identities" "if-intrinsics" "infer" @@ -103,15 +106,18 @@ IN: tools.deploy.shaker "loc" "members" "methods" + "method-class" + "method-generic" "combination" "cannot-infer" - "default-method" + "no-compile" "optimizer-hooks" "output-classes" "participants" "predicate" "predicate-definition" "predicating" + "tuple-dispatch-generic" "slots" "slot-names" "specializer" @@ -127,6 +133,8 @@ IN: tools.deploy.shaker strip-prettyprint? [ { + "break-before" + "break-after" "delimiter" "flushable" "foldable" @@ -265,13 +273,27 @@ IN: tools.deploy.shaker 21 setenv ] [ drop ] if ; +: compress ( pred string -- ) + "Compressing " prepend show + instances + dup H{ } clone [ [ ] cache ] curry map + become ; inline + +: compress-byte-arrays ( -- ) + [ byte-array? ] "byte arrays" compress ; + +: compress-quotations ( -- ) + [ quotation? ] "quotations" compress ; + +: compress-strings ( -- ) + [ string? ] "strings" compress ; + : finish-deploy ( final-image -- ) "Finishing up" show >r { } set-datastack r> { } set-retainstack V{ } set-namestack V{ } set-catchstack - "Saving final image" show [ save-image-and-exit ] call-clear ; @@ -295,7 +317,10 @@ SYMBOL: deploy-vocab deploy-vocab get vocab-main set-boot-quot* stripped-word-props >r stripped-globals strip-globals - r> strip-words ; + r> strip-words + compress-byte-arrays + compress-quotations + compress-strings ; : (deploy) ( final-image vocab config -- ) #! Does the actual work of a deployment in the slave From 8321a41db08fea8ff3043717a4119901a11f5eea Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 5 Jul 2008 03:07:25 -0500 Subject: [PATCH 17/77] Tweak to reduce image size; don't produce prototypes for tuples with all slots set to f --- core/classes/tuple/tuple.factor | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 83d85b68d8..b77fa3ecbd 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -135,7 +135,8 @@ ERROR: bad-superclass class ; dup boa-check-quot "boa-check" set-word-prop ; : tuple-prototype ( class -- prototype ) - [ all-slots [ initial>> ] map ] keep slots>tuple ; + [ all-slots [ initial>> ] map ] keep + over [ ] contains? [ slots>tuple ] [ 2drop f ] if ; : define-tuple-prototype ( class -- ) dup tuple-prototype "prototype" set-word-prop ; @@ -304,7 +305,8 @@ M: tuple hashcode* ] recursive-hashcode ; M: tuple-class new - "prototype" word-prop (clone) ; + dup "prototype" word-prop + [ (clone) ] [ tuple-layout ] ?if ; M: tuple-class boa [ "boa-check" word-prop call ] From db0d714eba8311b5d22f81a3097fcd076826c53f Mon Sep 17 00:00:00 2001 From: slava Date: Sat, 5 Jul 2008 03:07:34 -0500 Subject: [PATCH 18/77] Output relocation data size --- vm/code_gc.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/vm/code_gc.c b/vm/code_gc.c index e0abdc5a61..03661999c5 100755 --- a/vm/code_gc.c +++ b/vm/code_gc.c @@ -308,6 +308,8 @@ DEFINE_PRIMITIVE(code_room) /* Dump all code blocks for debugging */ void dump_heap(F_HEAP *heap) { + CELL size = 0; + F_BLOCK *scan = first_block(heap); while(scan) @@ -319,9 +321,11 @@ void dump_heap(F_HEAP *heap) status = "free"; break; case B_ALLOCATED: + size += object_size(block_to_compiled(scan)->relocation); status = "allocated"; break; case B_MARKED: + size += object_size(block_to_compiled(scan)->relocation); status = "marked"; break; default: @@ -333,6 +337,8 @@ void dump_heap(F_HEAP *heap) scan = next_block(heap,scan); } + + printf("%ld bytes of relocation data\n",size); } /* Compute where each block is going to go, after compaction */ From 0dec9230dc33b3c48ac648fcd4d486c833a101a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 03:44:54 -0500 Subject: [PATCH 19/77] Stricter deploy size tests (I'm such a masochist) --- extra/tools/deploy/deploy-tests.factor | 28 ++++++++++---------------- 1 file changed, 11 insertions(+), 17 deletions(-) diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 86691e89a0..8a0f0e5468 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -12,42 +12,36 @@ namespaces continuations layouts accessors ; ] with-directory ; : small-enough? ( n -- ? ) - >r "test.image" temp-file file-info size>> r> <= ; + >r "test.image" temp-file file-info size>> r> cell 4 / * <= ; [ ] [ "hello-world" shake-and-bake ] unit-test -[ t ] [ - cell 8 = 8 5 ? 100000 * small-enough? -] unit-test +[ t ] [ 50000 small-enough? ] unit-test [ ] [ "sudoku" shake-and-bake ] unit-test -[ t ] [ - cell 8 = 20 10 ? 100000 * small-enough? -] unit-test +[ t ] [ 80000 small-enough? ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test +[ t ] [ 130000 small-enough? ] unit-test + [ "staging.math-compiler-ui-strip.image" ] [ "hello-ui" deploy-config [ bootstrap-profile staging-image-name file-name ] bind ] unit-test -[ t ] [ - cell 8 = 35 17 ? 100000 * small-enough? -] unit-test - [ ] [ "maze" shake-and-bake ] unit-test -[ t ] [ - cell 8 = 30 15 ? 100000 * small-enough? -] unit-test +[ t ] [ 120000 small-enough? ] unit-test + +[ ] [ "tetris" shake-and-bake ] unit-test + +[ t ] [ 120000 small-enough? ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test -[ t ] [ - cell 8 = 50 30 ? 100000 * small-enough? -] unit-test +[ t ] [ 250000 small-enough? ] unit-test { "tools.deploy.test.1" From 33655a7044d04f4eb57bf62f1d4750e175aac145 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 03:47:09 -0500 Subject: [PATCH 20/77] Fix Unix I/O on 64-bit --- extra/io/unix/backend/backend.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 2128142615..7f130fc7e3 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -168,7 +168,7 @@ M: stdin dispose : wait-for-stdin ( stdin -- n ) [ control>> CHAR: X over io:stream-write1 io:stream-flush ] - [ size>> "uint" heap-size swap io:stream-read *uint ] + [ size>> "size_t" heap-size swap io:stream-read *uint ] bi ; :: refill-stdin ( buffer stdin size -- ) From 33603b9a28188cfefb0cf0a761f76452efbdabbc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 03:47:15 -0500 Subject: [PATCH 21/77] Fix benchmark load errors --- extra/benchmark/dispatch1/dispatch1.factor | 2 +- extra/benchmark/dispatch5/dispatch5.factor | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/benchmark/dispatch1/dispatch1.factor b/extra/benchmark/dispatch1/dispatch1.factor index 1c8701f73f..430162892d 100644 --- a/extra/benchmark/dispatch1/dispatch1.factor +++ b/extra/benchmark/dispatch1/dispatch1.factor @@ -1,4 +1,4 @@ -USING: classes kernel sequences vocabs math ; +USING: classes classes.tuple kernel sequences vocabs math ; IN: benchmark.dispatch1 GENERIC: g ( obj -- obj ) diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor index 727d288765..8b6bd76f3a 100755 --- a/extra/benchmark/dispatch5/dispatch5.factor +++ b/extra/benchmark/dispatch5/dispatch5.factor @@ -1,4 +1,4 @@ -USING: classes kernel sequences vocabs math ; +USING: classes classes.tuple kernel sequences vocabs math ; IN: benchmark.dispatch5 MIXIN: g From c99215667d4f6974ca614c1e2692da8f6e29bbfd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 03:59:49 -0500 Subject: [PATCH 22/77] Oops, all sizes were off by an order of magnitude --- extra/tools/deploy/deploy-tests.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index 8a0f0e5468..ebcc924ce2 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -16,15 +16,15 @@ namespaces continuations layouts accessors ; [ ] [ "hello-world" shake-and-bake ] unit-test -[ t ] [ 50000 small-enough? ] unit-test +[ t ] [ 500000 small-enough? ] unit-test [ ] [ "sudoku" shake-and-bake ] unit-test -[ t ] [ 80000 small-enough? ] unit-test +[ t ] [ 800000 small-enough? ] unit-test [ ] [ "hello-ui" shake-and-bake ] unit-test -[ t ] [ 130000 small-enough? ] unit-test +[ t ] [ 1300000 small-enough? ] unit-test [ "staging.math-compiler-ui-strip.image" ] [ "hello-ui" deploy-config @@ -33,15 +33,15 @@ namespaces continuations layouts accessors ; [ ] [ "maze" shake-and-bake ] unit-test -[ t ] [ 120000 small-enough? ] unit-test +[ t ] [ 1200000 small-enough? ] unit-test [ ] [ "tetris" shake-and-bake ] unit-test -[ t ] [ 120000 small-enough? ] unit-test +[ t ] [ 1200000 small-enough? ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test -[ t ] [ 250000 small-enough? ] unit-test +[ t ] [ 2500000 small-enough? ] unit-test { "tools.deploy.test.1" From 48671cfca7c56aed6d34f2aa893f63d80bf32855 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 04:42:58 -0500 Subject: [PATCH 23/77] Fix classes.algebra unit tests --- core/classes/algebra/algebra-tests.factor | 3 ++- core/classes/builtin/builtin.factor | 3 +-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 05c254f225..78da6ee9b3 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -3,7 +3,8 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units growable -random inference effects kernel.private sbufs math.order ; +random inference effects kernel.private sbufs math.order +classes.tuple ; IN: classes.algebra.tests \ class< must-infer diff --git a/core/classes/builtin/builtin.factor b/core/classes/builtin/builtin.factor index f349d0a126..b0e4754682 100644 --- a/core/classes/builtin/builtin.factor +++ b/core/classes/builtin/builtin.factor @@ -43,8 +43,7 @@ M: builtin-class (classes-intersect?) } cond ; M: anonymous-intersection (flatten-class) - participants>> - participants [ flatten-builtin-class ] map + participants>> [ flatten-builtin-class ] map dup empty? [ drop builtins get sift [ (flatten-class) ] each ] [ From a6c3de58bc2ae5373edd98a5a50d907717705338 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 05:02:44 -0500 Subject: [PATCH 24/77] Tetris is a bit bigger on Windows; that's ok, since its a new addition to size tests --- extra/tools/deploy/deploy-tests.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/tools/deploy/deploy-tests.factor b/extra/tools/deploy/deploy-tests.factor index ebcc924ce2..b66688b63a 100755 --- a/extra/tools/deploy/deploy-tests.factor +++ b/extra/tools/deploy/deploy-tests.factor @@ -37,7 +37,7 @@ namespaces continuations layouts accessors ; [ ] [ "tetris" shake-and-bake ] unit-test -[ t ] [ 1200000 small-enough? ] unit-test +[ t ] [ 1500000 small-enough? ] unit-test [ ] [ "bunny" shake-and-bake ] unit-test From 28c86d07f5d07cbf94e4a6fb93797953451a690d Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 5 Jul 2008 06:45:47 -0500 Subject: [PATCH 25/77] combinators.cleave: ncleave --- extra/combinators/cleave/cleave.factor | 10 +++++++++- 1 file changed, 9 insertions(+), 1 deletion(-) diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index 8018adaaa4..2f9e027211 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -1,8 +1,16 @@ -USING: kernel arrays sequences macros combinators ; +USING: kernel combinators quotations arrays sequences locals macros + shuffle combinators.lib ; IN: combinators.cleave +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +:: [ncleave] ( SEQ N -- quot ) + SEQ [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ; + +MACRO: ncleave ( seq n -- quot ) [ncleave] ; + ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! Cleave into array ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! From 0b6d405537c2c33a16edbd02fe5729ba712646fb Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 5 Jul 2008 07:25:10 -0500 Subject: [PATCH 26/77] combinators.cleave: narr and arity variants --- extra/combinators/cleave/cleave.factor | 23 +++++++++++++++++------ 1 file changed, 17 insertions(+), 6 deletions(-) diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor index 2f9e027211..9b8a790760 100644 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -1,13 +1,19 @@ -USING: kernel combinators quotations arrays sequences locals macros - shuffle combinators.lib ; +USING: kernel combinators words quotations arrays sequences locals macros + shuffle combinators.lib arrays.lib fry ; IN: combinators.cleave ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: >quot ( obj -- quot ) dup word? [ 1quotation ] when ; + +: >quots ( seq -- seq ) [ >quot ] map ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + :: [ncleave] ( SEQ N -- quot ) - SEQ [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ; + SEQ >quots [ [ N nkeep ] curry ] map concat [ N ndrop ] append >quotation ; MACRO: ncleave ( seq n -- quot ) [ncleave] ; @@ -15,11 +21,16 @@ MACRO: ncleave ( seq n -- quot ) [ncleave] ; ! Cleave into array ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -USING: words quotations fry arrays.lib ; +: [narr] ( seq n -- quot ) over length '[ , , ncleave , narray ] ; -: >quot ( obj -- quot ) dup word? [ 1quotation ] when ; +MACRO: narr ( seq n -- array ) [narr] ; -: >quots ( seq -- seq ) [ >quot ] map ; +MACRO: 0arr ( seq -- array ) 0 [narr] ; +MACRO: 1arr ( seq -- array ) 1 [narr] ; +MACRO: 2arr ( seq -- array ) 2 [narr] ; +MACRO: 3arr ( seq -- array ) 3 [narr] ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! MACRO: ( seq -- ) [ >quots ] [ length ] bi From 05798b88d92f2017c99a27720d3aaaa21d105540 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 5 Jul 2008 07:52:50 -0500 Subject: [PATCH 27/77] combinators.cleave-tests: add tests for arr --- extra/combinators/cleave/cleave-tests.factor | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) create mode 100644 extra/combinators/cleave/cleave-tests.factor diff --git a/extra/combinators/cleave/cleave-tests.factor b/extra/combinators/cleave/cleave-tests.factor new file mode 100644 index 0000000000..94d8c3eae0 --- /dev/null +++ b/extra/combinators/cleave/cleave-tests.factor @@ -0,0 +1,19 @@ + +USING: kernel math math.functions tools.test combinators.cleave ; + +IN: combinators.cleave.tests + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: unit-test* ( input output -- ) swap unit-test ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +[ { [ 1 ] [ 2 ] [ 3 ] [ 4 ] } 0arr ] [ { 1 2 3 4 } ] unit-test* + +[ 3 { 1+ 1- 2^ } 1arr ] [ { 4 2 8 } ] unit-test* + +[ 3 4 { [ + ] [ - ] [ ^ ] } 2arr ] [ { 7 -1 81 } ] unit-test* + +[ 1 2 3 { [ + + ] [ - - ] [ * * ] } 3arr ] [ { 6 2 6 } ] unit-test* + From d532c819a2b56dd14f733470252befed30fd2ef4 Mon Sep 17 00:00:00 2001 From: Eduardo Cavazos Date: Sat, 5 Jul 2008 11:06:30 -0500 Subject: [PATCH 28/77] newfx: insert and splice --- extra/newfx/newfx.factor | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/extra/newfx/newfx.factor b/extra/newfx/newfx.factor index 9335c61025..9cc63fd57e 100644 --- a/extra/newfx/newfx.factor +++ b/extra/newfx/newfx.factor @@ -237,3 +237,9 @@ METHOD: as-mutate { object object assoc } set-at ; : prepend! ( a b -- ba ) over append 0 pick copy ; : prepended! ( a b -- ) over append 0 rot copy ; + +! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +: insert ( seq i obj -- seq ) >r cut r> prefix append ; + +: splice ( seq i seq -- seq ) >r cut r> prepend append ; \ No newline at end of file From aa269f14caaa5a5b9502f2493d9c648de260e9d4 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 5 Jul 2008 11:24:01 -0700 Subject: [PATCH 29/77] Documentation for math.blas --- extra/math/blas/matrices/matrices-docs.factor | 193 ++++++++++++++++++ extra/math/blas/matrices/matrices.factor | 8 +- extra/math/blas/vectors/vectors-docs.factor | 111 ++++++++++ extra/math/blas/vectors/vectors.factor | 36 ++-- 4 files changed, 326 insertions(+), 22 deletions(-) create mode 100644 extra/math/blas/matrices/matrices-docs.factor create mode 100644 extra/math/blas/vectors/vectors-docs.factor diff --git a/extra/math/blas/matrices/matrices-docs.factor b/extra/math/blas/matrices/matrices-docs.factor new file mode 100644 index 0000000000..7ac72af58f --- /dev/null +++ b/extra/math/blas/matrices/matrices-docs.factor @@ -0,0 +1,193 @@ +USING: alien byte-arrays help.markup help.syntax math.blas.vectors sequences ; +IN: math.blas.matrices + +ARTICLE: "math.blas" "Basic Linear Algebra Subroutines (BLAS) interface" +"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:" +{ $subsection float-blas-vector } +{ $subsection double-blas-vector } +{ $subsection float-complex-blas-vector } +{ $subsection double-complex-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 } +"Matrices can be transposed, broken down into sequences of row or column vectors, or sliced into rectangular submatrices:" +{ $subsection Mtranspose } +{ $subsection Mrows } +{ $subsection Mcols } +{ $subsection Msub } +"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:" +{ $subsection Vnorm } +{ $subsection Vasum } +{ $subsection Viamax } +{ $subsection n*V } +{ $subsection V+ } +{ $subsection V- } +{ $subsection V. } +{ $subsection V.conj } +"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:" +{ $subsection M.V } +{ $subsection V(*) } +{ $subsection V(*)conj } +{ $subsection M. } +{ $subsection n*M } +"The above operations only operate on the BLAS vector and matrix types. You cannot mix element types in a BLAS operation; for example, you can't use " { $link V. } " to take the dot product of a " { $link float-blas-vector } " and " { $link double-blas-vector } "." +$nl +"The low-level BLAS C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ; + +HELP: blas-matrix-base +{ $class-description "The base class for all BLAS matrix types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:" +{ $list + { { $link float-blas-matrix } } + { { $link double-blas-matrix } } + { { $link float-complex-blas-matrix } } + { { $link double-complex-blas-matrix } } +} +"All of these subclasses share the same tuple layout:" +{ $list + { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed, column-major array of float, double, float complex, or double complex values;" } + { { $snippet "ld" } " indicates the distance, in elements, between matrix columns;" } + { { $snippet "rows" } " and " { $snippet "cols" } " indicate the number of significant rows and columns in the matrix;" } + { "and " { $snippet "transpose" } ", if set to a true value, indicates that the matrix should be treated as transposed relative to its in-memory representation." } +} } ; + +{ blas-vector-base blas-matrix-base } related-words + +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 +{ $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 +{ $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 +} related-words + +HELP: Mwidth +{ $values { "matrix" "a BLAS matrix inherited from " { $link blas-matrix-base } } { "width" "The number of columns" } } +{ $description "Returns the number of columns in " { $snippet "matrix" } "." } ; + +HELP: Mheight +{ $values { "matrix" "a BLAS matrix inherited from " { $link blas-matrix-base } } { "width" "The number of columns" } } +{ $description "Returns the number of rows in " { $snippet "matrix" } "." } ; + +{ Mwidth Mheight } related-words + +HELP: n*M.V+n*V-in-place +{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "beta" "a number" } { "y" "an M-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } ", and overwrite the current contents of " { $snippet "y" } " with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } +{ $side-effects "The memory used by " { $snippet "y" } " is overwritten with the result." } ; + +HELP: n*V(*)V+M-in-place +{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGER and xGERU routines in BLAS." } +{ $side-effects "The memory used by " { $snippet "A" } " is overwritten with the result." } ; + +HELP: n*V(*)Vconj+M-in-place +{ $values { "alpha" "a number" } { "x" "an M-element complex BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element complex BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column complex BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGERC routines in BLAS." } +{ $side-effects "The memory used by " { $snippet "A" } " is overwritten with the result." } ; + +HELP: n*M.M+n*M-in-place +{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "beta" "a number" } { "C" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ; + +HELP: +{ $values { "rows" "the number of rows the new matrix will have" } { "cols" "the number of columns the new matrix will have" } { "exemplar" "A BLAS vector inherited from " { $link blas-vector-base } " or BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $description "Create a matrix of all zeros with the given dimensions and the same element type as " { $snippet "exemplar" } "." } ; + +{ } related-words + +HELP: n*M.V+n*V +{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "beta" "a number" } { "y" "an M-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". The returned vector will have the same length as " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } ; + +HELP: n*V(*)V+M +{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGER and xGERU routines in BLAS." } ; + +HELP: n*V(*)Vconj+M +{ $values { "alpha" "a number" } { "x" "an M-element complex BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element complex BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column complex BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". The returned matrix will have the same dimensions as " { $snippet "A" } ". Corresponds to the xGERC routines in BLAS." } ; + +HELP: n*M.M+n*M +{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "beta" "a number" } { "C" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $description "Calculate the matrix product " { $snippet "αAB + βC" } " and overwrite the current contents of C with the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match, as must the heights of " { $snippet "A" } " and " { $snippet "C" } ", and the widths of " { $snippet "B" } " and " { $snippet "C" } ". Corresponds to the xGEMM routines in BLAS." } ; + +HELP: n*M.V +{ $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $description "Calculate the matrix-vector product " { $snippet "αAx" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ; + +HELP: M.V +{ $values { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $description "Calculate the matrix-vector product " { $snippet "Ax" } " and return a freshly allocated vector containing the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ". The length of the returned vector will match the height of " { $snippet "A" } ". Corresponds to the xGEMV routines in BLAS." } ; + +{ n*M.V+n*V-in-place n*M.V+n*V n*M.V M.V } related-words + +HELP: n*V(*)V +{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $description "Calculate the outer product " { $snippet "αx⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ; + +HELP: n*V(*)Vconj +{ $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $description "Calculate the outer product " { $snippet "αx⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ; + +HELP: V(*) +{ $values { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $description "Calculate the outer product " { $snippet "x⊗y" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGER and xGERU routines in BLAS." } ; + +HELP: V(*)conj +{ $values { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } } +{ $description "Calculate the conjugate outer product " { $snippet "x⊗y̅" } " and return a freshly allocated matrix containing the result. The returned matrix's height will match the length of " { $snippet "x" } ", and its width will match the length of " { $snippet "y" } ". Corresponds to the xGERC routines in BLAS." } ; + +{ n*V(*)V+M-in-place n*V(*)Vconj+M-in-place n*V(*)V+M n*V(*)Vconj+M n*V(*)V n*V(*)Vconj V(*) V(*)conj V. V.conj } related-words + +HELP: n*M.M +{ $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $description "Calculate the matrix product " { $snippet "αAB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ; + +HELP: M. +{ $values { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } +{ $description "Calculate the matrix product " { $snippet "AB" } " and return a freshly allocated matrix containing the result. The width of " { $snippet "A" } " and the height of " { $snippet "B" } " must match. The returned matrix's height will be the same as " { $snippet "A" } "'s, and its width will match " { $snippet "B" } "'s. Corresponds to the xGEMM routines in BLAS." } ; + +{ n*M.M+n*M-in-place n*M.M+n*M n*M.M M. } related-words + +HELP: Msub +{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "row" "The topmost row of the slice" } { "col" "The leftmost column of the slice" } { "height" "The height of the slice" } { "width" "The width of the slice" } } +{ $description "Select a rectangular submatrix of " { $snippet "matrix" } " with the given dimensions. The returned submatrix will share the parent matrix's storage." } ; + +HELP: Mrows +{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $description "Return a sequence of BLAS vectors representing the rows of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ; + +HELP: Mcols +{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $description "Return a sequence of BLAS vectors representing the columns of " { $snippet "matrix" } ". Each vector will share the parent matrix's storage." } ; + +HELP: n*M-in-place +{ $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and overwrite the current contents of A with the result." } +{ $side-effects "The memory used by " { $snippet "A" } " is overwritten with the result." } ; + +HELP: n*M +{ $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ; + +HELP: M*n +{ $values { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "n" "a number" } } +{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ; + +HELP: M/n +{ $values { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } { "n" "a number" } } +{ $description "Calculate the scalar-matrix product " { $snippet "(1/n)A" } " and return a freshly allocated matrix with the same dimensions as " { $snippet "A" } " containing the result." } ; + +{ n*M-in-place n*M M*n M/n } related-words + +HELP: Mtranspose +{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $description "Returns the transpose of " { $snippet "matrix" } ". The returned matrix shares storage with the original matrix." } ; diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor index aa172c954b..965eda813d 100644 --- a/extra/math/blas/matrices/matrices.factor +++ b/extra/math/blas/matrices/matrices.factor @@ -200,7 +200,7 @@ syntax:M: blas-matrix-base clone ] keep (blas-matrix-like) ; ! XXX try rounding stride to next 128 bit bound for better vectorizin' -: empty-matrix ( rows cols exemplar -- matrix ) +: ( rows cols exemplar -- matrix ) [ element-type [ * ] dip ] [ 2drop ] [ f swap (blas-matrix-like) ] 3tri ; @@ -222,10 +222,10 @@ syntax:M: blas-matrix-base clone 1.0 -rot n*M.V ; inline : n*V(*)V ( n x y -- n*x(*)y ) - 2dup [ length>> ] bi@ pick empty-matrix + 2dup [ length>> ] bi@ pick n*V(*)V+M-in-place ; : n*V(*)Vconj ( n x y -- n*x(*)yconj ) - 2dup [ length>> ] bi@ pick empty-matrix + 2dup [ length>> ] bi@ pick n*V(*)Vconj+M-in-place ; : V(*) ( x y -- x(*)y ) @@ -234,7 +234,7 @@ syntax:M: blas-matrix-base clone 1.0 -rot n*V(*)Vconj ; inline : n*M.M ( n A B -- n*A.B ) - 2dup [ Mheight ] [ Mwidth ] bi* pick empty-matrix + 2dup [ Mheight ] [ Mwidth ] bi* pick 1.0 swap n*M.M+n*M-in-place ; : M. ( A B -- A.B ) diff --git a/extra/math/blas/vectors/vectors-docs.factor b/extra/math/blas/vectors/vectors-docs.factor new file mode 100644 index 0000000000..9ebfd40d1c --- /dev/null +++ b/extra/math/blas/vectors/vectors-docs.factor @@ -0,0 +1,111 @@ +USING: alien byte-arrays help.markup help.syntax sequences ; +IN: math.blas.vectors + +HELP: blas-vector-base +{ $class-description "The base class for all BLAS vector types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:" +{ $list + { { $link float-blas-vector } } + { { $link double-blas-vector } } + { { $link float-complex-blas-vector } } + { { $link double-complex-blas-vector } } +} +"All of these subclasses share the same tuple layout:" +{ $list + { { $snippet "data" } " contains an alien pointer referencing or byte-array containing a packed array of float, double, float complex, or double complex values;" } + { { $snippet "length" } " indicates the length of the vector;" } + { "and " { $snippet "inc" } " indicates the distance, in elements, between elements." } +} } ; + +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-matrix-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-matrix-base } "." } ; + +HELP: n*V+V-in-place +{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Calculate the vector sum " { $snippet "αx + y" } " and replace the existing contents of y with the result. Corresponds to the xAXPY routines in BLAS." } +{ $side-effects "The memory used by y is overwritten with the result." } ; + +HELP: n*V-in-place +{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and replace the existing contents of x with the result. Corresponds to the xSCAL routines in BLAS." } +{ $side-effects "The memory used by x is overwritten with the result." } ; + +HELP: V. +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Calculate the inner product " { $snippet "x⋅y" } ". Corresponds to the xDOT and xDOTU routines in BLAS." } ; + +HELP: V.conj +{ $values { "x" "a complex BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a complex BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Calculate the conjugate inner product " { $snippet "x̅⋅y" } ". Corresponds to the xDOTC routines in BLAS." } ; + +HELP: Vnorm +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Calculate the norm-2, i.e., the magnitude or absolute value, of " { $snippet "x" } " (" { $snippet "‖x‖₂" } "). Corresponds to the xNRM2 routines in BLAS." } ; + +HELP: Vasum +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Calculate the sum of the norm-1s of the elements of " { $snippet "x" } " (" { $snippet "Σ ‖xᵢ‖₁" } "). Corresponds to the xASUM routines in BLAS." } ; + +HELP: Vswap +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Swap the contents of " { $snippet "x" } " and " { $snippet "y" } " in place. Corresponds to the xSWAP routines in BLAS." } +{ $side-effects "The memory contents of the two vectors are exchanged." } ; + +HELP: Viamax +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Return the index of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the smallest index. Corresponds to the IxAMAX routines in BLAS." } ; + +HELP: Vamax +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the first element. Corresponds to the IxAMAX routines in BLAS." } ; + +{ Viamax Vamax } related-words + +HELP: element-type +{ $values { "v" "a BLAS vector inheriting from " { $link blas-vector-base } ", or a BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $description "Return the C type of the elements in the given BLAS vector or matrix." } ; + +HELP: +{ $values { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } " } } +{ $description "Return a vector of zeros with the same length and element type as " { $snippet "v" } ". The vector is constructed with an " { $snippet "inc" } " of zero, so it is not suitable for receiving results from BLAS functions; it is intended to be used as a term in other vector calculations. To construct an empty vector that can be used to receive results, see " { $link } "." } ; + +HELP: +{ $values { "length" "The length of the new vector" } { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } " } } +{ $description "Return a vector of zeros with the given length and the same element type as " { $snippet "v" } "." } ; + +HELP: n*V+V +{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Calculate the vector sum " { $snippet "αx + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ; + +HELP: n*V +{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ; + +HELP: V+ +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Calculate the vector sum " { $snippet "x + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ; + +HELP: V- +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Calculate the vector difference " { $snippet "x – y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ; + +HELP: Vneg +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } +{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result." } ; + +HELP: V*n +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "alpha" "a number" } } +{ $description "Calculate the scalar-vector product " { $snippet "αx" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ; + +HELP: V/n +{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "alpha" "a number" } } +{ $description "Calculate the scalar-vector product " { $snippet "(1/α)x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result. Corresponds to the xSCAL routines in BLAS." } ; + +{ n*V+V-in-place n*V-in-place n*V+V n*V V+ V- Vneg V*n V/n } related-words + + diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor index 3da95f3079..b8b8283781 100644 --- a/extra/math/blas/vectors/vectors.factor +++ b/extra/math/blas/vectors/vectors.factor @@ -21,16 +21,16 @@ C: double-blas-vector C: float-complex-blas-vector C: double-complex-blas-vector -GENERIC: n*V+V-in-place ( n v1 v2 -- v2=n*v1+v2 ) -GENERIC: n*V-in-place ( n v -- v=n*v ) +GENERIC: n*V+V-in-place ( alpha x y -- y=alpha*x+y ) +GENERIC: n*V-in-place ( alpha x -- x=alpha*x ) -GENERIC: V. ( v1 v2 -- v1.v2 ) -GENERIC: V.conj ( v1 v2 -- v1^H.v2 ) -GENERIC: Vnorm ( v -- norm ) -GENERIC: Vasum ( v -- abs-sum ) -GENERIC: Vswap ( v1 v2 -- v1=v2 v2=v1 ) +GENERIC: V. ( x y -- x.y ) +GENERIC: V.conj ( x y -- xconj.y ) +GENERIC: Vnorm ( x -- norm2(x) ) +GENERIC: Vasum ( x -- sum(norm1(x[i])) +GENERIC: Vswap ( x y -- x=y y=x ) -GENERIC: Viamax ( v -- abs-max-index ) +GENERIC: Viamax ( x -- i-where-x[i]=max(norm1(x[i])) ) GENERIC: element-type ( v -- type ) @@ -130,12 +130,12 @@ MACRO: (set-complex-nth) ( set-nth-quot -- ) PRIVATE> -: zero-vector ( exemplar -- zero ) +: ( exemplar -- zero ) [ element-type ] [ length>> 0 ] [ (blas-vector-like) ] tri ; -: empty-vector ( length exemplar -- empty-vector ) +: ( length exemplar -- ) [ element-type ] [ 1 swap ] 2bi (blas-vector-like) ; @@ -224,20 +224,20 @@ METHOD: n*V-in-place { number double-complex-blas-vector } [ (>z-complex) ] dip (prepare-scal) [ cblas_zscal ] dip ; -: n*V+V ( n v1 v2 -- n*v1+v2 ) clone n*V+V-in-place ; inline -: n*V ( n v1 -- n*v1 ) clone n*V-in-place ; inline +: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V-in-place ; inline +: n*V ( alpha x -- alpha*x ) clone n*V-in-place ; inline -: V+ ( v1 v2 -- v1+v2 ) +: V+ ( x y -- x+y ) 1.0 -rot n*V+V ; inline -: V- ( v1 v2 -- v1-v2 ) +: V- ( x y -- x-y ) -1.0 spin n*V+V ; inline -: Vneg ( v1 -- -v1 ) - [ zero-vector ] keep V- ; inline +: Vneg ( x -- -x ) + -1.0 swap n*V ; inline -: V*n ( v n -- v*n ) +: V*n ( x alpha -- x*alpha ) swap n*V ; inline -: V/n ( v n -- v*n ) +: V/n ( x alpha -- x/alpha ) recip swap n*V ; inline METHOD: V. { float-blas-vector float-blas-vector } From bff6c521bc32299e226ab1fe956d3790fc159c54 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 5 Jul 2008 11:30:42 -0700 Subject: [PATCH 30/77] Fix $side-effects in blas help --- extra/math/blas/matrices/matrices-docs.factor | 17 ++++++++++++---- extra/math/blas/vectors/vectors-docs.factor | 20 ++++++------------- extra/math/blas/vectors/vectors.factor | 6 +++--- 3 files changed, 22 insertions(+), 21 deletions(-) diff --git a/extra/math/blas/matrices/matrices-docs.factor b/extra/math/blas/matrices/matrices-docs.factor index 7ac72af58f..12cc579610 100644 --- a/extra/math/blas/matrices/matrices-docs.factor +++ b/extra/math/blas/matrices/matrices-docs.factor @@ -81,17 +81,17 @@ HELP: Mheight HELP: n*M.V+n*V-in-place { $values { "alpha" "a number" } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "x" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "beta" "a number" } { "y" "an M-element BLAS vector inherited from " { $link blas-vector-base } } } { $description "Calculate the matrix-vector product " { $snippet "αAx + βy" } ", and overwrite the current contents of " { $snippet "y" } " with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "x" } ", and the height must match the length of " { $snippet "y" } ". Corresponds to the xGEMV routines in BLAS." } -{ $side-effects "The memory used by " { $snippet "y" } " is overwritten with the result." } ; +{ $side-effects "y" } ; HELP: n*V(*)V+M-in-place { $values { "alpha" "a number" } { "x" "an M-element BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } { $description "Calculate the outer product " { $snippet "αx⊗y + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGER and xGERU routines in BLAS." } -{ $side-effects "The memory used by " { $snippet "A" } " is overwritten with the result." } ; +{ $side-effects "A" } ; HELP: n*V(*)Vconj+M-in-place { $values { "alpha" "a number" } { "x" "an M-element complex BLAS vector inherited from " { $link blas-vector-base } } { "y" "an N-element complex BLAS vector inherited from " { $link blas-vector-base } } { "A" "an M-row, N-column complex BLAS matrix inherited from " { $link blas-matrix-base } } } { $description "Calculate the conjugate outer product " { $snippet "αx⊗y̅ + A" } " and overwrite the current contents of A with the result. The width of " { $snippet "A" } " must match the length of " { $snippet "y" } ", and its height must match the length of " { $snippet "x" } ". Corresponds to the xGERC routines in BLAS." } -{ $side-effects "The memory used by " { $snippet "A" } " is overwritten with the result." } ; +{ $side-effects "A" } ; HELP: n*M.M+n*M-in-place { $values { "alpha" "a number" } { "A" "an M-row, K-column BLAS matrix inherited from " { $link blas-matrix-base } } { "B" "a K-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } { "beta" "a number" } { "C" "an M-row, N-column BLAS matrix inherited from " { $link blas-matrix-base } } } @@ -172,7 +172,7 @@ HELP: Mcols HELP: n*M-in-place { $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } { $description "Calculate the scalar-matrix product " { $snippet "nA" } " and overwrite the current contents of A with the result." } -{ $side-effects "The memory used by " { $snippet "A" } " is overwritten with the result." } ; +{ $side-effects "A" } ; HELP: n*M { $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } @@ -191,3 +191,12 @@ HELP: M/n HELP: Mtranspose { $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } } { $description "Returns the transpose of " { $snippet "matrix" } ". The returned matrix shares storage with the original matrix." } ; + +HELP: element-type +{ $values { "v" "a BLAS vector inheriting from " { $link blas-vector-base } ", or a BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $description "Return the C type of the elements in the given BLAS vector or matrix." } ; + +HELP: +{ $values { "length" "The length of the new vector" } { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } ", or a BLAS matrix inheriting from " { $link blas-matrix-base } } } +{ $description "Return a vector of zeros with the given length and the same element type as " { $snippet "v" } "." } ; + diff --git a/extra/math/blas/vectors/vectors-docs.factor b/extra/math/blas/vectors/vectors-docs.factor index 9ebfd40d1c..1518bffd95 100644 --- a/extra/math/blas/vectors/vectors-docs.factor +++ b/extra/math/blas/vectors/vectors-docs.factor @@ -21,19 +21,19 @@ HELP: float-blas-vector 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-matrix-base } "." } ; +{ $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-matrix-base } "." } ; +{ $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: n*V+V-in-place { $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } { $description "Calculate the vector sum " { $snippet "αx + y" } " and replace the existing contents of y with the result. Corresponds to the xAXPY routines in BLAS." } -{ $side-effects "The memory used by y is overwritten with the result." } ; +{ $side-effects "y" } ; HELP: n*V-in-place { $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } { $description "Calculate the scalar-vector product " { $snippet "αx" } " and replace the existing contents of x with the result. Corresponds to the xSCAL routines in BLAS." } -{ $side-effects "The memory used by x is overwritten with the result." } ; +{ $side-effects "x" } ; HELP: V. { $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } @@ -54,7 +54,7 @@ HELP: Vasum HELP: Vswap { $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } { $description "Swap the contents of " { $snippet "x" } " and " { $snippet "y" } " in place. Corresponds to the xSWAP routines in BLAS." } -{ $side-effects "The memory contents of the two vectors are exchanged." } ; +{ $side-effects "x" "y" } ; HELP: Viamax { $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } } @@ -66,18 +66,10 @@ HELP: Vamax { Viamax Vamax } related-words -HELP: element-type -{ $values { "v" "a BLAS vector inheriting from " { $link blas-vector-base } ", or a BLAS matrix inheriting from " { $link blas-matrix-base } } } -{ $description "Return the C type of the elements in the given BLAS vector or matrix." } ; - HELP: -{ $values { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } " } } +{ $values { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } } } { $description "Return a vector of zeros with the same length and element type as " { $snippet "v" } ". The vector is constructed with an " { $snippet "inc" } " of zero, so it is not suitable for receiving results from BLAS functions; it is intended to be used as a term in other vector calculations. To construct an empty vector that can be used to receive results, see " { $link } "." } ; -HELP: -{ $values { "length" "The length of the new vector" } { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } " } } -{ $description "Return a vector of zeros with the given length and the same element type as " { $snippet "v" } "." } ; - HELP: n*V+V { $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } } { $description "Calculate the vector sum " { $snippet "αx + y" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " and " { $snippet "y" } " containing the result. Corresponds to the xAXPY routines in BLAS." } ; diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor index b8b8283781..bd3b54c7eb 100644 --- a/extra/math/blas/vectors/vectors.factor +++ b/extra/math/blas/vectors/vectors.factor @@ -26,11 +26,11 @@ GENERIC: n*V-in-place ( alpha x -- x=alpha*x ) GENERIC: V. ( x y -- x.y ) GENERIC: V.conj ( x y -- xconj.y ) -GENERIC: Vnorm ( x -- norm2(x) ) -GENERIC: Vasum ( x -- sum(norm1(x[i])) +GENERIC: Vnorm ( x -- norm ) +GENERIC: Vasum ( x -- sum ) GENERIC: Vswap ( x y -- x=y y=x ) -GENERIC: Viamax ( x -- i-where-x[i]=max(norm1(x[i])) ) +GENERIC: Viamax ( x -- max-i ) GENERIC: element-type ( v -- type ) From 264fffbf0868a94485b162c516831b61b42c9edb Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sat, 5 Jul 2008 23:30:04 +0200 Subject: [PATCH 31/77] factor.el: factor-run-file ask to save if source has been modified. Add factor-display-output-buffer to optionally show factor buffer. --- misc/factor.el | 17 +++++++++++++++++ 1 file changed, 17 insertions(+) diff --git a/misc/factor.el b/misc/factor.el index 300c95c430..5c9d050468 100644 --- a/misc/factor.el +++ b/misc/factor.el @@ -29,6 +29,12 @@ (defvar factor-mode-syntax-table nil "Syntax table used while in Factor mode.") +(defcustom factor-display-compilation-output t + "Display the REPL buffer before compiling files." + :type '(choice (const :tag "Enable" t) (const :tag "Disable" nil)) + :group 'factor) + + (if factor-mode-syntax-table () (let ((i 0)) @@ -139,9 +145,20 @@ (defun factor-run-file () (interactive) + (when (and (buffer-modified-p) + (y-or-n-p (format "Save file %s? " (buffer-file-name)))) + (save-buffer)) + (when factor-display-compilation-output + (factor-display-output-buffer)) (comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name))) (comint-send-string "*factor*" " run-file\n")) +(defun factor-display-output-buffer () + (with-current-buffer "*factor*" + (goto-char (point-max)) + (unless (get-buffer-window (current-buffer) t) + (display-buffer (current-buffer) t)))) + ;; (defun factor-send-region (start end) ;; (interactive "r") ;; (comint-send-region "*factor*" start end) From a8b826e8edc1b3a7348983f4cddef616c8a23ddb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 17:08:01 -0500 Subject: [PATCH 32/77] Fix hang --- core/classes/algebra/algebra-tests.factor | 4 +++- core/classes/algebra/algebra.factor | 3 --- core/classes/intersection/intersection.factor | 3 +++ core/classes/union/union.factor | 3 +++ 4 files changed, 9 insertions(+), 4 deletions(-) diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 78da6ee9b3..444cf50e58 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.algebra classes.private classes.union classes.mixin classes.predicate vectors definitions source-files compiler.units growable -random inference effects kernel.private sbufs math.order +random inference effects kernel.private sbufs math.order classes.tuple ; IN: classes.algebra.tests @@ -288,6 +288,8 @@ INTERSECTION: generic-class generic class ; generic-class flatten-class ] unit-test +[ \ + flatten-class ] must-fail + INTERSECTION: empty-intersection ; [ t ] [ object empty-intersection class<= ] unit-test diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 9dbe72d9cb..1076901678 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -207,9 +207,6 @@ GENERIC: (flatten-class) ( class -- ) M: anonymous-union (flatten-class) members>> [ (flatten-class) ] each ; -M: word (flatten-class) - normalize-class (flatten-class) ; - : flatten-class ( class -- assoc ) [ (flatten-class) ] H{ } make-assoc ; diff --git a/core/classes/intersection/intersection.factor b/core/classes/intersection/intersection.factor index 5df580d82f..bb7e0adc62 100644 --- a/core/classes/intersection/intersection.factor +++ b/core/classes/intersection/intersection.factor @@ -31,3 +31,6 @@ M: intersection-class rank-class drop 2 ; M: intersection-class instance? "participants" word-prop [ instance? ] with all? ; + +M: intersection-class (flatten-class) + participants (flatten-class) ; diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index e3deb25e7a..fbb1925363 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -32,3 +32,6 @@ M: union-class rank-class drop 2 ; M: union-class instance? "members" word-prop [ instance? ] with contains? ; + +M: union-class (flatten-class) + members (flatten-class) ; From 954737dfeb558b70a04a487212d74552c1f3f757 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 5 Jul 2008 15:13:48 -0700 Subject: [PATCH 33/77] fix blas library load for unix. fix reference to old empty-vector word in matrices --- extra/math/blas/cblas/cblas.factor | 6 +++--- extra/math/blas/matrices/matrices.factor | 2 +- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/math/blas/cblas/cblas.factor b/extra/math/blas/cblas/cblas.factor index 266972fc99..31807b7389 100644 --- a/extra/math/blas/cblas/cblas.factor +++ b/extra/math/blas/cblas/cblas.factor @@ -2,9 +2,9 @@ USING: alien alien.c-types alien.syntax kernel system combinators ; IN: math.blas.cblas << "cblas" { - { [ os macosx? ] [ "libcblas.dylib" "cdecl" add-library ] } - { [ os windows? ] [ "cblas.dll" "cdecl" add-library ] } - [ drop "libcblas.so" "cdecl" add-library ] + { [ os macosx? ] [ "libblas.dylib" "cdecl" add-library ] } + { [ os windows? ] [ "blas.dll" "cdecl" add-library ] } + [ "libblas.so" "cdecl" add-library ] } cond >> LIBRARY: cblas diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor index 965eda813d..b29ca85d45 100644 --- a/extra/math/blas/matrices/matrices.factor +++ b/extra/math/blas/matrices/matrices.factor @@ -215,7 +215,7 @@ syntax:M: blas-matrix-base clone clone n*M.M+n*M-in-place ; : n*M.V ( alpha A x -- alpha*A.x ) - 1.0 2over [ Mheight ] dip empty-vector + 1.0 2over [ Mheight ] dip n*M.V+n*V-in-place ; inline : M.V ( A x -- A.x ) From 761fbfeb8f0216925bbf9015d7fb1af93467366f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 5 Jul 2008 18:28:53 -0700 Subject: [PATCH 34/77] Vsub word for slicing BLAS vectors. Documentation improvements --- extra/math/blas/matrices/matrices-docs.factor | 65 ++++++++++++++----- extra/math/blas/vectors/vectors-docs.factor | 30 ++++++++- extra/math/blas/vectors/vectors-tests.factor | 7 ++ extra/math/blas/vectors/vectors.factor | 12 +++- 4 files changed, 95 insertions(+), 19 deletions(-) diff --git a/extra/math/blas/matrices/matrices-docs.factor b/extra/math/blas/matrices/matrices-docs.factor index 12cc579610..0d9ac69171 100644 --- a/extra/math/blas/matrices/matrices-docs.factor +++ b/extra/math/blas/matrices/matrices-docs.factor @@ -1,8 +1,17 @@ USING: alien byte-arrays help.markup help.syntax math.blas.vectors sequences ; IN: math.blas.matrices -ARTICLE: "math.blas" "Basic Linear Algebra Subroutines (BLAS) interface" +ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface" "Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:" +{ $subsection "math.blas-types" } +"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:" +{ $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." ; + +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 } @@ -11,30 +20,54 @@ ARTICLE: "math.blas" "Basic Linear Algebra Subroutines (BLAS) interface" { $subsection float-blas-matrix } { $subsection double-blas-matrix } { $subsection float-complex-blas-matrix } -{ $subsection double-complex-blas-matrix } -"Matrices can be transposed, broken down into sequences of row or column vectors, or sliced into rectangular submatrices:" +{ $subsection double-complex-blas-matrix } +"Syntax words are provided for constructing literal vectors and matrices in the " { $vocab-link "math.blas.syntax" } " vocabulary:" +{ $subsection "math.blas.syntax" } +"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 } +"For the simple case of creating a dense, zero-filled vector or matrix, simple empty object constructors are provided:" +{ $subsection } +{ $subsection } ; + +ARTICLE: "math.blas.matrices" "BLAS interface matrix operations" +"Transposing and slicing matrices:" { $subsection Mtranspose } { $subsection Mrows } { $subsection Mcols } { $subsection Msub } -"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:" -{ $subsection Vnorm } -{ $subsection Vasum } -{ $subsection Viamax } -{ $subsection n*V } -{ $subsection V+ } -{ $subsection V- } -{ $subsection V. } -{ $subsection V.conj } -"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:" +"Matrix-vector products:" +{ $subsection n*M.V+n*V-in-place } +{ $subsection n*M.V+n*V } +{ $subsection n*M.V } { $subsection M.V } +"Vector outer products:" +{ $subsection n*V(*)V+M-in-place } +{ $subsection n*V(*)Vconj+M-in-place } +{ $subsection n*V(*)V+M } +{ $subsection n*V(*)Vconj+M } +{ $subsection n*V(*)V } +{ $subsection n*V(*)Vconj } { $subsection V(*) } { $subsection V(*)conj } +"Matrix products:" +{ $subsection n*M.M+n*M-in-place } +{ $subsection n*M.M+n*M } +{ $subsection n*M.M } { $subsection M. } +"Scalar-matrix products:" +{ $subsection n*M-in-place } { $subsection n*M } -"The above operations only operate on the BLAS vector and matrix types. You cannot mix element types in a BLAS operation; for example, you can't use " { $link V. } " to take the dot product of a " { $link float-blas-vector } " and " { $link double-blas-vector } "." -$nl -"The low-level BLAS C interface can be accessed directly through the " { $vocab-link "math.blas.cblas" } " vocabulary." ; +{ $subsection M*n } +{ $subsection M/n } ; + +ABOUT: "math.blas.matrices" HELP: blas-matrix-base { $class-description "The base class for all BLAS matrix types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:" diff --git a/extra/math/blas/vectors/vectors-docs.factor b/extra/math/blas/vectors/vectors-docs.factor index 1518bffd95..4fad9c7378 100644 --- a/extra/math/blas/vectors/vectors-docs.factor +++ b/extra/math/blas/vectors/vectors-docs.factor @@ -1,6 +1,32 @@ USING: alien byte-arrays help.markup help.syntax sequences ; IN: math.blas.vectors +ARTICLE: "math.blas.vectors" "BLAS interface vector operations" +"Slicing vectors:" +{ $subsection Vsub } +"Taking the norm (magnitude) of a vector:" +{ $subsection Vnorm } +"Summing and taking the maximum of elements:" +{ $subsection Vasum } +{ $subsection Viamax } +{ $subsection Vamax } +"Scalar-vector products:" +{ $subsection n*V-in-place } +{ $subsection n*V } +{ $subsection V*n } +{ $subsection V/n } +{ $subsection Vneg } +"Vector addition:" +{ $subsection n*V+V-in-place } +{ $subsection n*V+V } +{ $subsection V+ } +{ $subsection V- } +"Vector inner products:" +{ $subsection V. } +{ $subsection V.conj } ; + +ABOUT: "math.blas.vectors" + HELP: blas-vector-base { $class-description "The base class for all BLAS vector types. Objects of this type should not be created directly; instead, instantiate one of the typed subclasses:" { $list @@ -100,4 +126,6 @@ HELP: V/n { n*V+V-in-place n*V-in-place n*V+V n*V V+ V- Vneg V*n V/n } related-words - +HELP: Vsub +{ $values { "v" "a BLAS vector inheriting from " { $link blas-vector-base } } { "start" "The index of the first element of the slice" } { "length" "The length of the slice" } } +{ $description "Slice a subvector out of " { $snippet "v" } " with the given length. The subvector will share storage with the parent vector." } ; diff --git a/extra/math/blas/vectors/vectors-tests.factor b/extra/math/blas/vectors/vectors-tests.factor index e059d2943d..d4cff82e50 100644 --- a/extra/math/blas/vectors/vectors-tests.factor +++ b/extra/math/blas/vectors/vectors-tests.factor @@ -171,3 +171,10 @@ unit-test [ -6.0 ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } Vamax ] unit-test [ C{ 2.0 -5.0 } ] [ cvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test [ C{ 2.0 -5.0 } ] [ zvector{ C{ 2.0 -5.0 } 4.0 -6.0 -1.0 } Vamax ] unit-test + +! Vsub + +[ svector{ -5.0 4.0 -6.0 } ] [ svector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test +[ dvector{ -5.0 4.0 -6.0 } ] [ dvector{ 1.0 -5.0 4.0 -6.0 -1.0 } 1 3 Vsub ] unit-test +[ cvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ cvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test +[ zvector{ -5.0 C{ 4.0 3.0 } -6.0 } ] [ zvector{ 1.0 -5.0 C{ 4.0 3.0 } -6.0 -1.0 } 1 3 Vsub ] unit-test diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor index bd3b54c7eb..3c927318a6 100644 --- a/extra/math/blas/vectors/vectors.factor +++ b/extra/math/blas/vectors/vectors.factor @@ -135,7 +135,7 @@ PRIVATE> [ length>> 0 ] [ (blas-vector-like) ] tri ; -: ( length exemplar -- ) +: ( length exemplar -- vector ) [ element-type ] [ 1 swap ] 2bi (blas-vector-like) ; @@ -285,5 +285,13 @@ METHOD: Viamax { float-complex-blas-vector } METHOD: Viamax { double-complex-blas-vector } (prepare-nrm2) cblas_izamax ; -: Vamax ( v -- max ) +: Vamax ( x -- max ) [ Viamax ] keep nth ; inline + +: Vsub ( v start length -- vsub ) + rot [ + [ + nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri + [ * * ] dip + ] [ swap 2nip ] [ 2nip inc>> ] 3tri + ] keep (blas-vector-like) ; From 1c92b20a9a647880b7a15a957c1002d4b244f3e0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 20:37:28 -0500 Subject: [PATCH 35/77] Fix two bugs --- core/classes/tuple/tuple-tests.factor | 2 ++ core/classes/tuple/tuple.factor | 34 ++++++++++++++++----------- core/generator/generator.factor | 11 +++++---- 3 files changed, 28 insertions(+), 19 deletions(-) diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index 9deb6b1133..a269fad556 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -657,6 +657,8 @@ TUPLE: boa-coercer-test { x array-capacity } ; [ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test +[ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test + ! Test error classes ERROR: error-class-test a b c ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 66a75387f1..8471aa918a 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -17,6 +17,9 @@ ERROR: not-a-tuple object ; : check-tuple ( object -- tuple ) dup tuple? [ not-a-tuple ] unless ; inline +: all-slots ( class -- slots ) + superclasses [ "slots" word-prop ] map concat ; + > 2dup instance? + [ 2drop ] [ bad-slot-value ] if + ] 2each + ] if-bootstrapping ; inline + +: initial-values ( class -- slots ) + all-slots [ initial>> ] map ; + +: pad-slots ( slots class -- slots' class ) + [ initial-values over length tail append ] keep ; inline + PRIVATE> : tuple>array ( tuple -- array ) @@ -56,21 +73,10 @@ PRIVATE> : tuple-slots ( tuple -- seq ) prepare-tuple>array drop copy-tuple-slots ; -: all-slots ( class -- slots ) - superclasses [ "slots" word-prop ] map concat ; - -: check-slots ( seq class -- seq class ) - [ ] [ - 2dup all-slots [ - class>> 2dup instance? - [ 2drop ] [ bad-slot-value ] if - ] 2each - ] if-bootstrapping ; inline - GENERIC: slots>tuple ( seq class -- tuple ) M: tuple-class slots>tuple - check-slots + check-slots pad-slots tuple-layout [ [ tuple-size ] [ [ set-array-nth ] curry ] @@ -138,8 +144,8 @@ ERROR: bad-superclass class ; dup boa-check-quot "boa-check" set-word-prop ; : tuple-prototype ( class -- prototype ) - [ all-slots [ initial>> ] map ] keep - over [ ] contains? [ slots>tuple ] [ 2drop f ] if ; + [ initial-values ] keep + over [ ] all? [ 2drop f ] [ slots>tuple ] if ; : define-tuple-prototype ( class -- ) dup tuple-prototype "prototype" set-word-prop ; diff --git a/core/generator/generator.factor b/core/generator/generator.factor index d369c047d9..07d8d6fdad 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -13,11 +13,12 @@ SYMBOL: compiled : queue-compile ( word -- ) { - { [ dup compiled get key? ] [ drop ] } - { [ dup inlined-block? ] [ drop ] } - { [ dup primitive? ] [ drop ] } - [ compile-queue get push-front ] - } cond ; + { [ dup "forgotten" word-prop ] [ ] } + { [ dup compiled get key? ] [ ] } + { [ dup inlined-block? ] [ ] } + { [ dup primitive? ] [ ] } + [ dup compile-queue get push-front ] + } cond drop ; : maybe-compile ( word -- ) dup compiled>> [ drop ] [ queue-compile ] if ; From 9256e31d669f70f0f76bd19325fc77197d331a35 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 21:00:05 -0500 Subject: [PATCH 36/77] Fix feps on 64 bit --- core/bootstrap/image/image.factor | 6 ++++++ core/bootstrap/primitives.factor | 2 +- 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 64c9299b89..58ee77fafd 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -228,6 +228,12 @@ M: fixnum ' bootstrap-most-positive-fixnum between? [ tag-fixnum ] [ >bignum ' ] if ; +TUPLE: fake-bignum n ; + +C: fake-bignum + +M: fake-bignum ' n>> tag-fixnum ; + ! Floats M: float ' diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6bd2ca7c98..235f3894a1 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -181,7 +181,7 @@ define-union-class ! A predicate class used for declarations "array-capacity" "sequences.private" create "fixnum" "math" lookup -0 bootstrap-max-array-capacity [ between? ] 2curry +0 bootstrap-max-array-capacity [ between? ] 2curry define-predicate-class ! Catch-all class for providing a default method. From a26e66e4139bba253eee0d355af07ed76f8acdbc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 21:29:02 -0500 Subject: [PATCH 37/77] Fix a couple of load errors --- extra/color-picker/color-picker.factor | 10 +++++----- extra/lcd/lcd.factor | 7 ++++--- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/extra/color-picker/color-picker.factor b/extra/color-picker/color-picker.factor index c64d1e4872..b494dbc188 100755 --- a/extra/color-picker/color-picker.factor +++ b/extra/color-picker/color-picker.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel math math.functions math.parser models sequences -ui ui.gadgets ui.gadgets.frames -ui.gadgets.labels ui.gadgets.packs ui.gadgets.sliders ui.render -; +USING: kernel math math.functions math.parser models +models.filter models.range models.compose sequences ui +ui.gadgets ui.gadgets.frames ui.gadgets.labels ui.gadgets.packs +ui.gadgets.sliders ui.render ; IN: color-picker ! Simple example demonstrating the use of models. diff --git a/extra/lcd/lcd.factor b/extra/lcd/lcd.factor index 952bc17f17..b0d5060b4a 100755 --- a/extra/lcd/lcd.factor +++ b/extra/lcd/lcd.factor @@ -1,7 +1,8 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: sequences kernel math io calendar calendar.format -calendar.model arrays models namespaces ui.gadgets -ui.gadgets.labels -ui.gadgets.theme ui ; +calendar.model arrays models models.filter namespaces ui.gadgets +ui.gadgets.labels ui.gadgets.theme ui ; IN: lcd : lcd-digit ( row digit -- str ) From 72b78eaef9d39e3beddd143370a0667866056d4d Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 5 Jul 2008 19:39:26 -0700 Subject: [PATCH 38/77] performance improvement for converting large datasets to blas matrices --- extra/math/blas/matrices/matrices.factor | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor index b29ca85d45..99f20b432b 100644 --- a/extra/math/blas/matrices/matrices.factor +++ b/extra/math/blas/matrices/matrices.factor @@ -2,7 +2,7 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.lib combinators.short-circuit fry kernel locals macros math math.blas.cblas math.blas.vectors math.blas.vectors.private math.complex math.functions math.order multi-methods qualified -sequences sequences.private shuffle symbols ; +sequences sequences.merged sequences.private shuffle symbols ; QUALIFIED: syntax IN: math.blas.matrices @@ -137,8 +137,7 @@ METHOD: (blas-vector-like) { object object object double-complex-blas-matrix } C f >>transpose ; inline : (>matrix) ( arrays >c-array -- c-array ld rows cols transpose ) - [ flip ] dip - '[ concat @ ] [ first length dup ] [ length ] tri f ; inline + '[ @ ] [ length dup ] [ first length ] tri f ; inline PRIVATE> From 1b63addff1c818c28b00bea9248bdfe394bc69be Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 5 Jul 2008 19:46:10 -0700 Subject: [PATCH 39/77] oops... add math.blas.syntax documentation --- extra/math/blas/syntax/syntax-docs.factor | 76 +++++++++++++++++++++++ 1 file changed, 76 insertions(+) create mode 100644 extra/math/blas/syntax/syntax-docs.factor diff --git a/extra/math/blas/syntax/syntax-docs.factor b/extra/math/blas/syntax/syntax-docs.factor new file mode 100644 index 0000000000..32693893e0 --- /dev/null +++ b/extra/math/blas/syntax/syntax-docs.factor @@ -0,0 +1,76 @@ +USING: help.markup help.syntax math.blas.matrices math.blas.vectors multiline ; +IN: math.blas.syntax + +ARTICLE: "math.blas.syntax" "BLAS interface literal syntax" +{ $subsection POSTPONE: svector{ } +{ $subsection POSTPONE: dvector{ } +{ $subsection POSTPONE: cvector{ } +{ $subsection POSTPONE: zvector{ } +{ $subsection POSTPONE: smatrix{ } +{ $subsection POSTPONE: dmatrix{ } +{ $subsection POSTPONE: cmatrix{ } +{ $subsection POSTPONE: zmatrix{ } ; + +ABOUT: "math.blas.syntax" + +HELP: svector{ +{ $syntax "svector{ 1.0 -2.0 3.0 }" } +{ $description "Construct a literal " { $link float-blas-vector } "." } ; + +HELP: dvector{ +{ $syntax "dvector{ 1.0 -2.0 3.0 }" } +{ $description "Construct a literal " { $link double-blas-vector } "." } ; + +HELP: cvector{ +{ $syntax "cvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } +{ $description "Construct a literal " { $link float-complex-blas-vector } "." } ; + +HELP: zvector{ +{ $syntax "dvector{ 1.0 -2.0 C{ 3.0 -1.0 } }" } +{ $description "Construct a literal " { $link double-complex-blas-vector } "." } ; + +{ + POSTPONE: svector{ POSTPONE: dvector{ + POSTPONE: cvector{ POSTPONE: zvector{ +} related-words + +HELP: smatrix{ +{ $syntax <" smatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 1.0 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + { 0.0 0.0 0.0 1.0 } +} "> } +{ $description "Construct a literal " { $link float-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; + +HELP: dmatrix{ +{ $syntax <" dmatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 1.0 0.0 2.0 } + { 0.0 0.0 1.0 3.0 } + { 0.0 0.0 0.0 1.0 } +} "> } +{ $description "Construct a literal " { $link double-blas-matrix } ". Note that although BLAS matrices are stored in column-major order, the literal is specified in row-major order." } ; + +HELP: cmatrix{ +{ $syntax <" cmatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 C{ 0.0 1.0 } 0.0 2.0 } + { 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." } ; + +HELP: zmatrix{ +{ $syntax <" zmatrix{ + { 1.0 0.0 0.0 1.0 } + { 0.0 C{ 0.0 1.0 } 0.0 2.0 } + { 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." } ; + +{ + POSTPONE: smatrix{ POSTPONE: dmatrix{ + POSTPONE: cmatrix{ POSTPONE: zmatrix{ +} related-words From 402b2079aaf2fd549ef1c33966b82ecb26576992 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 5 Jul 2008 19:49:54 -0700 Subject: [PATCH 40/77] some headings for the math.blas.syntax help summary --- extra/math/blas/syntax/syntax-docs.factor | 2 ++ 1 file changed, 2 insertions(+) diff --git a/extra/math/blas/syntax/syntax-docs.factor b/extra/math/blas/syntax/syntax-docs.factor index 32693893e0..6b58df738a 100644 --- a/extra/math/blas/syntax/syntax-docs.factor +++ b/extra/math/blas/syntax/syntax-docs.factor @@ -2,10 +2,12 @@ USING: help.markup help.syntax math.blas.matrices math.blas.vectors multiline ; IN: math.blas.syntax ARTICLE: "math.blas.syntax" "BLAS interface literal syntax" +"Vectors:" { $subsection POSTPONE: svector{ } { $subsection POSTPONE: dvector{ } { $subsection POSTPONE: cvector{ } { $subsection POSTPONE: zvector{ } +"Matrices:" { $subsection POSTPONE: smatrix{ } { $subsection POSTPONE: dmatrix{ } { $subsection POSTPONE: cmatrix{ } From a9adf82e70b352a38866fbe7c91228f62d15875d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 22:19:16 -0500 Subject: [PATCH 41/77] Fix obscure bug in profiprofiler --- extra/tools/profiler/profiler-tests.factor | 14 +++++++++++++- vm/profiler.c | 4 ++-- 2 files changed, 15 insertions(+), 3 deletions(-) diff --git a/extra/tools/profiler/profiler-tests.factor b/extra/tools/profiler/profiler-tests.factor index d78e6fcbea..75ca5ede8c 100755 --- a/extra/tools/profiler/profiler-tests.factor +++ b/extra/tools/profiler/profiler-tests.factor @@ -1,6 +1,6 @@ IN: tools.profiler.tests USING: accessors tools.profiler tools.test kernel memory math -threads alien tools.profiler.private sequences ; +threads alien tools.profiler.private sequences compiler.units ; [ t ] [ \ length counter>> @@ -42,3 +42,15 @@ threads alien tools.profiler.private sequences ; [ 1 ] [ \ foobaz counter>> ] unit-test [ 2 ] [ \ fooblah counter>> ] unit-test + +: recompile-while-profiling-test ( -- ) ; + +[ ] [ + [ + 333 [ recompile-while-profiling-test ] times + { recompile-while-profiling-test } compile + 333 [ recompile-while-profiling-test ] times + ] profile +] unit-test + +[ 666 ] [ \ recompile-while-profiling-test counter>> ] unit-test diff --git a/vm/profiler.c b/vm/profiler.c index 58a4aa035e..27e903178b 100755 --- a/vm/profiler.c +++ b/vm/profiler.c @@ -35,8 +35,6 @@ void update_word_xt(F_WORD *word) /* If we just enabled the profiler, reset call count */ if(profiling_p) { - word->counter = tag_fixnum(0); - if(!word->profiling) { REGISTER_UNTAGGED(word); @@ -71,6 +69,8 @@ void set_profiling(bool profiling) for(i = 0; i < length; i++) { F_WORD *word = untag_word(array_nth(untag_array(words),i)); + if(profiling) + word->counter = tag_fixnum(0); update_word_xt(word); } From 476e143fdbd39ce8375e79fb509960b6359a2d33 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 23:07:11 -0500 Subject: [PATCH 42/77] Fix type error --- core/cpu/x86/64/64.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/cpu/x86/64/64.factor b/core/cpu/x86/64/64.factor index 6d99b72439..bdd452f83d 100755 --- a/core/cpu/x86/64/64.factor +++ b/core/cpu/x86/64/64.factor @@ -178,7 +178,7 @@ stack-params "__stack_value" c-type set-c-type-reg-class >> : struct-types&offset ( struct-type -- pairs ) struct-type-fields [ - [ type>> ] [ offset>> ] bi 2array + [ class>> ] [ offset>> ] bi 2array ] map ; : split-struct ( pairs -- seq ) From 78d24d5a5d71f3c9fee0d48287e2f5b34467863b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 5 Jul 2008 23:08:30 -0500 Subject: [PATCH 43/77] Fix unit test failures --- core/classes/tuple/tuple-docs.factor | 2 +- core/generic/generic-tests.factor | 4 ++-- extra/models/models-tests.factor | 3 ++- extra/ui/gadgets/scrollers/scrollers-tests.factor | 4 ++-- extra/xml/errors/errors-tests.factor | 2 +- extra/xmode/utilities/utilities-tests.factor | 1 - 6 files changed, 8 insertions(+), 8 deletions(-) diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index fd8b450eed..98e1fd3e50 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -334,7 +334,7 @@ ABOUT: "tuples" HELP: tuple-class { $class-description "The class of tuple class words." } -{ $examples { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; +{ $examples { $example "USING: classes.tuple prettyprint ;" "IN: scratchpad" "TUPLE: name title first last ;" "name tuple-class? ." "t" } } ; HELP: tuple= { $values { "tuple1" tuple } { "tuple2" tuple } { "?" "a boolean" } } diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index 88e13ec0f8..f3c51506fb 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -1,8 +1,8 @@ USING: accessors alien arrays definitions generic generic.standard generic.math assocs hashtables io kernel math namespaces parser prettyprint sequences strings tools.test vectors words -quotations classes classes.algebra continuations layouts -classes.union sorting compiler.units ; +quotations classes classes.algebra classes.tuple continuations +layouts classes.union sorting compiler.units ; IN: generic.tests GENERIC: foobar ( x -- y ) diff --git a/extra/models/models-tests.factor b/extra/models/models-tests.factor index 637cb8f17a..ee1bb542f0 100755 --- a/extra/models/models-tests.factor +++ b/extra/models/models-tests.factor @@ -1,5 +1,6 @@ IN: models.tests -USING: arrays generic kernel math models namespaces sequences assocs +USING: arrays generic kernel math models models.compose +namespaces sequences assocs tools.test ; TUPLE: model-tester hit? ; diff --git a/extra/ui/gadgets/scrollers/scrollers-tests.factor b/extra/ui/gadgets/scrollers/scrollers-tests.factor index 5ccd6c7cd8..4df92141ba 100755 --- a/extra/ui/gadgets/scrollers/scrollers-tests.factor +++ b/extra/ui/gadgets/scrollers/scrollers-tests.factor @@ -1,6 +1,6 @@ IN: ui.gadgets.scrollers.tests -USING: ui.gadgets ui.gadgets.scrollers -namespaces tools.test kernel models ui.gadgets.viewports +USING: ui.gadgets ui.gadgets.scrollers namespaces tools.test +kernel models models.compose models.range ui.gadgets.viewports ui.gadgets.labels ui.gadgets.grids ui.gadgets.frames ui.gadgets.sliders math math.vectors arrays sequences tools.test.ui ; diff --git a/extra/xml/errors/errors-tests.factor b/extra/xml/errors/errors-tests.factor index 402c76dc01..ab061530fe 100755 --- a/extra/xml/errors/errors-tests.factor +++ b/extra/xml/errors/errors-tests.factor @@ -14,7 +14,7 @@ T{ not-yes/no f 1 41 "maybe" } "" xm T{ extra-attrs f 1 32 V{ T{ name f "" "foo" f } } } "" xml-error-test T{ bad-version f 1 28 "5 million" } "" xml-error-test -T{ notags f 1 0 } "" xml-error-test +T{ notags f } "" xml-error-test T{ multitags } "" xml-error-test T{ bad-prolog f 1 26 T{ prolog f "1.0" "UTF-8" f } } "" xml-error-test diff --git a/extra/xmode/utilities/utilities-tests.factor b/extra/xmode/utilities/utilities-tests.factor index a2183edbc9..55b6bbe26a 100755 --- a/extra/xmode/utilities/utilities-tests.factor +++ b/extra/xmode/utilities/utilities-tests.factor @@ -45,7 +45,6 @@ TAGS> T{ employee f "Jane" "CFO" } } "PUBLIC" - "This is a great company" } ] [ "resource:extra/xmode/utilities/test.xml" From e6282fe1a8b47dc8794031fb7b36b8f105398799 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jul 2008 01:37:11 -0500 Subject: [PATCH 44/77] Performance improvements --- core/generic/standard/engines/engines.factor | 14 ++++++-------- .../engines/predicate/predicate.factor | 19 +++++++++++++------ core/generic/standard/standard.factor | 16 +++++++++++++++- core/optimizer/inlining/inlining.factor | 18 ++++++++++-------- .../specializers/specializers.factor | 13 +------------ 5 files changed, 45 insertions(+), 35 deletions(-) diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index 20e22fde82..bdac7c1dfe 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -1,16 +1,16 @@ -USING: assocs kernel namespaces quotations generic math -sequences combinators words classes.algebra ; +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: assocs kernel kernel.private namespaces quotations +generic math sequences combinators words classes.algebra arrays +; IN: generic.standard.engines SYMBOL: default SYMBOL: assumed +SYMBOL: (dispatch#) GENERIC: engine>quot ( engine -- quot ) -M: quotation engine>quot ; - -M: method-body engine>quot 1quotation ; - : engines>quots ( assoc -- assoc' ) [ engine>quot ] assoc-map ; @@ -36,8 +36,6 @@ M: method-body engine>quot 1quotation ; r> execute r> pick set-at ] if ; inline -SYMBOL: (dispatch#) - : (picker) ( n -- quot ) { { 0 [ [ dup ] ] } diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor index 9c810592a0..8846c9eee7 100644 --- a/core/generic/standard/engines/predicate/predicate.factor +++ b/core/generic/standard/engines/predicate/predicate.factor @@ -1,6 +1,8 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. USING: generic.standard.engines generic namespaces kernel -sequences classes.algebra accessors words combinators -assocs ; +kernel.private sequences classes.algebra accessors words +combinators assocs arrays ; IN: generic.standard.engines.predicate TUPLE: predicate-dispatch-engine methods ; @@ -24,8 +26,13 @@ C: predicate-dispatch-engine : sort-methods ( assoc -- assoc' ) >alist [ keys sort-classes ] keep extract-keys ; +: methods-with-default ( engine -- assoc ) + methods>> clone default get object bootstrap-word pick set-at ; + M: predicate-dispatch-engine engine>quot - methods>> clone - default get object bootstrap-word pick set-at engines>quots - sort-methods prune-redundant-predicates - class-predicates alist>quot ; + methods-with-default + engines>quots + sort-methods + prune-redundant-predicates + class-predicates + alist>quot ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index f8b3c00c31..2a99588db8 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -10,7 +10,16 @@ IN: generic.standard GENERIC: dispatch# ( word -- n ) -M: word dispatch# "combination" word-prop dispatch# ; +M: generic dispatch# + "combination" word-prop dispatch# ; + +GENERIC: method-declaration ( class generic -- quot ) + +M: generic method-declaration + "combination" word-prop method-declaration ; + +M: quotation engine>quot + assumed get generic get method-declaration prepend ; : unpickers { @@ -135,6 +144,9 @@ M: standard-combination perform-combination M: standard-combination dispatch# #>> ; +M: standard-combination method-declaration + dispatch# object swap prefix [ declare ] curry [ ] like ; + M: standard-combination next-method-quot* [ single-next-method-quot picker prepend @@ -157,6 +169,8 @@ PREDICATE: hook-generic < generic M: hook-combination dispatch# drop 0 ; +M: hook-combination method-declaration 2drop [ ] ; + M: hook-generic extra-values drop 1 ; M: hook-generic effective-method diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 295dcaf496..618a2c746d 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -191,6 +191,10 @@ DEFER: (flat-length) : apply-identities ( node -- node/f ) dup find-identity f splice-quot ; +: splice-word-def ( #call word def -- node ) + [ drop +inlined+ depends-on ] [ swap 1array ] 2bi + splice-quot ; + : optimistic-inline? ( #call -- ? ) dup node-param "specializer" word-prop dup [ >r node-input-classes r> specialized-length tail* @@ -199,22 +203,20 @@ DEFER: (flat-length) 2drop f ] if ; -: splice-word-def ( #call word -- node ) - dup +inlined+ depends-on - dup def>> swap 1array splice-quot ; +: already-inlined? ( #call -- ? ) + [ param>> ] [ history>> ] bi memq? ; : optimistic-inline ( #call -- node ) - dup node-param over node-history memq? [ - drop t - ] [ - dup node-param splice-word-def + dup already-inlined? [ drop t ] [ + dup param>> dup def>> splice-word-def ] if ; : should-inline? ( word -- ? ) flat-length 11 <= ; : method-body-inline? ( #call -- ? ) - node-param dup method-body? [ should-inline? ] [ drop f ] if ; + param>> dup [ method-body? ] [ "default" word-prop not ] bi and + [ should-inline? ] [ drop f ] if ; M: #call optimize-node* { diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 90ae7fc6f9..18c960b129 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -18,13 +18,6 @@ IN: optimizer.specializers unclip [ swap [ f ] \ if 3array append [ ] like ] reduce ] if ; -: tag-specializer ( quot -- newquot ) - [ - [ dup tag ] % - num-tags get swap , - \ dispatch , - ] [ ] make ; - : specializer-cases ( quot word -- default alist ) dup [ array? ] all? [ 1array ] unless [ [ make-specializer ] keep @@ -39,11 +32,7 @@ IN: optimizer.specializers method-declaration [ declare ] curry prepend ; : specialize-quot ( quot specializer -- quot' ) - dup { number } = [ - drop tag-specializer - ] [ - specializer-cases alist>quot - ] if ; + specializer-cases alist>quot ; : standard-method? ( method -- ? ) dup method-body? [ From 0f6ecc10cd4ccdb6c03d863b9ac0d1c330eda371 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jul 2008 04:12:46 -0500 Subject: [PATCH 45/77] Fix EINTR handling in Unix stdin pipe hack --- extra/io/unix/backend/backend.factor | 2 +- vm/os-unix.c | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 7f130fc7e3..165747084e 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -168,7 +168,7 @@ M: stdin dispose : wait-for-stdin ( stdin -- n ) [ control>> CHAR: X over io:stream-write1 io:stream-flush ] - [ size>> "size_t" heap-size swap io:stream-read *uint ] + [ size>> "ssize_t" heap-size swap io:stream-read *int ] bi ; :: refill-stdin ( buffer stdin size -- ) diff --git a/vm/os-unix.c b/vm/os-unix.c index be1d2c0c18..5b0da5a8d2 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -339,7 +339,7 @@ void *stdin_loop(void *arg) for(;;) { - size_t bytes = read(0,buf,sizeof(buf)); + ssize_t bytes = read(0,buf,sizeof(buf)); if(bytes < 0) { if(errno == EINTR) From 4191882a686e90e84f0ad2bd4c7b5fa3dea7e14a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jul 2008 06:09:21 -0500 Subject: [PATCH 46/77] Debug persistent vectors --- .../persistent-vectors-docs.factor | 8 +--- .../persistent-vectors-tests.factor | 24 +++++++--- .../persistent-vectors.factor | 47 +++++++++++-------- 3 files changed, 46 insertions(+), 33 deletions(-) diff --git a/extra/persistent-vectors/persistent-vectors-docs.factor b/extra/persistent-vectors/persistent-vectors-docs.factor index dc9222cedb..0be443e38d 100644 --- a/extra/persistent-vectors/persistent-vectors-docs.factor +++ b/extra/persistent-vectors/persistent-vectors-docs.factor @@ -27,10 +27,6 @@ HELP: >persistent-vector HELP: persistent-vector { $class-description "The class of persistent vectors." } ; -HELP: pempty -{ $values { "pvec" persistent-vector } } -{ $description "Outputs an empty " { $link persistent-vector } "." } ; - ARTICLE: "persistent-vectors" "Persistent vectors" "A " { $emphasis "persistent vector" } " differs from an ordinary vector (" { $link "vectors" } ") in that it is immutable, and all operations yield new persistent vectors instead of modifying inputs. Unlike immutable operations on ordinary sequences, persistent vector operations are efficient and run in sub-linear time." $nl @@ -42,12 +38,12 @@ $nl { $subsection new-nth } { $subsection ppush } { $subsection ppop } -"The empty persistent vector, used for building up all other persistent vectors:" -{ $subsection pempty } "Converting a sequence into a persistent vector:" { $subsection >persistent-vector } "Persistent vectors have a literal syntax:" { $subsection POSTPONE: PV{ } +"The empty persistent vector, written " { $snippet "PV{ }" } ", is used for building up all other persistent vectors." +$nl "This implementation of persistent vectors is based on the " { $snippet "clojure.lang.PersistentVector" } " class from Rich Hickey's Clojure language for the JVM (" { $url "http://clojure.org" } ")." ; ABOUT: "persistent-vectors" diff --git a/extra/persistent-vectors/persistent-vectors-tests.factor b/extra/persistent-vectors/persistent-vectors-tests.factor index 45eb894e67..1e2fae6a39 100644 --- a/extra/persistent-vectors/persistent-vectors-tests.factor +++ b/extra/persistent-vectors/persistent-vectors-tests.factor @@ -1,23 +1,23 @@ IN: persistent-vectors.tests -USING: tools.test persistent-vectors sequences kernel arrays -random namespaces vectors math math.order ; +USING: accessors tools.test persistent-vectors sequences kernel +arrays random namespaces vectors math math.order ; \ new-nth must-infer \ ppush must-infer \ ppop must-infer -[ 0 ] [ pempty length ] unit-test +[ 0 ] [ PV{ } length ] unit-test -[ 1 ] [ 3 pempty ppush length ] unit-test +[ 1 ] [ 3 PV{ } ppush length ] unit-test -[ 3 ] [ 3 pempty ppush first ] unit-test +[ 3 ] [ 3 PV{ } ppush first ] unit-test [ PV{ 3 1 3 3 7 } ] [ - pempty { 3 1 3 3 7 } [ swap ppush ] each + PV{ } { 3 1 3 3 7 } [ swap ppush ] each ] unit-test [ { 3 1 3 3 7 } ] [ - pempty { 3 1 3 3 7 } [ swap ppush ] each >array + PV{ } { 3 1 3 3 7 } [ swap ppush ] each >array ] unit-test { 100 1060 2000 10000 100000 1000000 } [ @@ -52,6 +52,16 @@ random namespaces vectors math math.order ; [ ] [ PV{ } 10000 [ push/pop-test ] times drop ] unit-test +[ PV{ } ] [ + PV{ } + 10000 [ 1 swap ppush ] times + 10000 [ ppop ] times +] unit-test + +[ t ] [ + 10000 >persistent-vector 752 [ ppop ] times dup length sequence= +] unit-test + [ t ] [ 100 [ drop diff --git a/extra/persistent-vectors/persistent-vectors.factor b/extra/persistent-vectors/persistent-vectors.factor index 691ebfcf4d..e071ae69d2 100644 --- a/extra/persistent-vectors/persistent-vectors.factor +++ b/extra/persistent-vectors/persistent-vectors.factor @@ -4,6 +4,12 @@ USING: math accessors kernel sequences.private sequences arrays combinators combinators.short-circuit parser prettyprint.backend ; IN: persistent-vectors + + ERROR: empty-error pvec ; GENERIC: ppush ( val seq -- seq' ) @@ -18,14 +24,13 @@ GENERIC: new-nth ( val i seq -- seq' ) M: sequence new-nth clone [ set-nth ] keep ; -TUPLE: persistent-vector count root tail ; +TUPLE: persistent-vector +{ count fixnum } +{ root node initial: T{ node f { } 1 } } +{ tail node initial: T{ node f { } 0 } } ; M: persistent-vector length count>> ; -> ] bi* nth ; inline + [ node-mask ] [ children>> ] bi* nth ; : body-nth ( i node -- i node' ) dup level>> [ dupd [ level>> node-shift ] keep node-nth - ] times ; inline + ] times ; : tail-offset ( pvec -- n ) [ count>> ] [ tail>> children>> length ] bi - ; @@ -58,9 +63,7 @@ M: persistent-vector nth-unsafe children>> length node-size = ; : 1node ( val level -- node ) - node new - swap >>level - swap 1array >>children ; + [ 1array ] dip node boa ; : 2node ( first second -- node ) [ 2array ] [ drop level>> 1+ ] 2bi node boa ; @@ -123,6 +126,10 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' ) ] if ] if ; +! The pop code is really convoluted. I don't understand Rich Hickey's +! original code. It uses a 'Box' out parameter which is passed around +! inside a recursive function, and gets mutated along the way to boot. +! Super-confusing. : ppop-tail ( pvec -- pvec' ) [ clone [ ppop ] change-children ] change-tail ; @@ -137,10 +144,12 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' ) : (ppop-new-tail) ( root -- root' tail' ) dup level>> 1 > [ - dup children>> peek (ppop-new-tail) over - [ [ swap node-set-last ] dip ] - [ 2drop ppop-contraction ] - if + dup children>> peek (ppop-new-tail) [ + dup + [ swap node-set-last ] + [ drop ppop-contraction drop ] + if + ] dip ] [ ppop-contraction ] if ; @@ -159,13 +168,10 @@ M: persistent-vector new-nth ( obj i pvec -- pvec' ) PRIVATE> -: pempty ( -- pvec ) - T{ persistent-vector f 0 T{ node f { } 1 } T{ node f { } 0 } } ; inline - M: persistent-vector ppop ( pvec -- pvec' ) dup count>> { { 0 [ empty-error ] } - { 1 [ drop pempty ] } + { 1 [ drop T{ persistent-vector } ] } [ [ clone @@ -176,12 +182,13 @@ M: persistent-vector ppop ( pvec -- pvec' ) } case ; M: persistent-vector like - drop pempty [ swap ppush ] reduce ; + drop T{ persistent-vector } [ swap ppush ] reduce ; M: persistent-vector equal? over persistent-vector? [ sequence= ] [ 2drop f ] if ; -: >persistent-vector ( seq -- pvec ) pempty like ; inline +: >persistent-vector ( seq -- pvec ) + T{ persistent-vector } like ; : PV{ \ } [ >persistent-vector ] parse-literal ; parsing From b5dc709c025957c32370c4f40778d15c682f379f Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 6 Jul 2008 08:37:16 -0700 Subject: [PATCH 47/77] Rewrite integer>bit-array to use locals --- extra/bit-arrays/bit-arrays.factor | 20 +++++++++++--------- 1 file changed, 11 insertions(+), 9 deletions(-) diff --git a/extra/bit-arrays/bit-arrays.factor b/extra/bit-arrays/bit-arrays.factor index 96d7cf9905..3d699a2623 100755 --- a/extra/bit-arrays/bit-arrays.factor +++ b/extra/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 sequences sequences.private byte-arrays +kernel.private locals sequences sequences.private byte-arrays parser prettyprint.backend ; IN: bit-arrays @@ -72,14 +72,16 @@ M: bit-array byte-length length 7 + -3 shift ; : ?{ ( parsed -- parsed ) \ } [ >bit-array ] parse-literal ; parsing -: integer>bit-array ( int -- bit-array ) - dup zero? [ drop 0 ] [ - [ log2 1+ 0 ] keep - [ dup zero? not ] [ - [ -8 shift ] [ 255 bitand ] bi - -roll [ [ set-alien-unsigned-1 ] 2keep 1+ ] dip - ] [ ] while - 2drop +:: integer>bit-array ( n -- bit-array ) + n zero? [ 0 ] [ + [let | out [ n log2 1+ ] i! [ 0 ] n'! [ n ] | + [ n' zero? not ] [ + n' out underlying>> i 255 bitand set-alien-unsigned-1 + n' -8 shift n'! + i 1+ i! + ] [ ] while + out + ] ] if ; : bit-array>integer ( bit-array -- int ) From 722d05c19f31a8363ed71bf411fba9bd4969a80d Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Sun, 6 Jul 2008 21:48:45 +0200 Subject: [PATCH 48/77] Added a new ctags vocab that generates index files in ctag format --- extra/ctags/authors.txt | 1 + extra/ctags/ctags-docs.factor | 47 ++++++++++++++++++++++++++++++++++ extra/ctags/ctags-tests.factor | 7 +++++ extra/ctags/ctags.factor | 34 ++++++++++++++++++++++++ extra/ctags/summary.txt | 1 + 5 files changed, 90 insertions(+) create mode 100644 extra/ctags/authors.txt create mode 100644 extra/ctags/ctags-docs.factor create mode 100644 extra/ctags/ctags-tests.factor create mode 100644 extra/ctags/ctags.factor create mode 100644 extra/ctags/summary.txt diff --git a/extra/ctags/authors.txt b/extra/ctags/authors.txt new file mode 100644 index 0000000000..158cf94ea0 --- /dev/null +++ b/extra/ctags/authors.txt @@ -0,0 +1 @@ +Alfredo Beaumont diff --git a/extra/ctags/ctags-docs.factor b/extra/ctags/ctags-docs.factor new file mode 100644 index 0000000000..f2dbd8bc2b --- /dev/null +++ b/extra/ctags/ctags-docs.factor @@ -0,0 +1,47 @@ +USING: help.syntax help.markup kernel prettyprint sequences strings ; +IN: ctags + +ARTICLE: "ctags" "Ctags file" +{ $emphasis "ctags" } " generates a index file of every factor word in ctags format as supported by vi and other editors. More information can be found at " { $url "http://en.wikipedia.org/wiki/Ctags" } "." +{ $subsection ctags } +{ $subsection ctags-write } +{ $subsection ctag } ; + +HELP: ctags ( path -- ) +{ $values { "path" "a pathname string" } } +{ $description "Generates a index file in ctags format and stores in " { $snippet "path" } "." } +{ $examples + { $example + "USING: ctags ;" + "\"tags\" ctags-write" + "" + } +} ; + +HELP: ctags-write ( seq path -- ) +{ $values { "seq" sequence } + { "path" "a pathname string" } } +{ $description "Stores a " { $snippet "seq" } " in " { $snippet "path" } ". " { $snippet "seq" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" } +{ $examples + { $example + "USING: kernel ctags ;" + "{ { if { \"resource:extra/unix/unix.factor\" 91 } } } \"tags\" ctags-write" + "" + } +} +{ $notes + { $snippet "tags" } " file will contain a single line: if\\t/path/to/factor/extra/unix/unix.factor\\t91" } ; + +HELP: ctag ( seq -- str ) +{ $values { "seq" sequence } + { "str" string } } +{ $description "Outputs a string " { $snippet "str" } " in ctag format for sequence with two elements, first one must be a valid word and second one a sequence whose first element is a resource name and second element is a line number" } +{ $examples + { $example + "USING: kernel ctags ;" + "{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag ." + "\"if\\t/path/to/factor/extra/unix/unix.factor\\t91\"" + } +} ; + +ABOUT: "ctags" \ No newline at end of file diff --git a/extra/ctags/ctags-tests.factor b/extra/ctags/ctags-tests.factor new file mode 100644 index 0000000000..dc6e402653 --- /dev/null +++ b/extra/ctags/ctags-tests.factor @@ -0,0 +1,7 @@ +USING: kernel ctags tools.test io.backend sequences ; +IN: columns.tests + +[ t ] [ + "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append + { if { "resource:extra/unix/unix.factor" 91 } } ctag = +] unit-test \ No newline at end of file diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor new file mode 100644 index 0000000000..5480772ba1 --- /dev/null +++ b/extra/ctags/ctags.factor @@ -0,0 +1,34 @@ +! Copyright (C) 2008 Alfredo Beaumont +! See http://factorcode.org/license.txt for BSD license. + +! Simple Ctags generator +! Alfredo Beaumont + +USING: kernel sequences io io.files io.backend +io.encodings.ascii math.parser vocabs definitions +namespaces words sorting ; +IN: ctags + +: ctag ( seq -- str ) + [ + dup first ?word-name % + "\t" % + second dup first normalize-path % + "\t" % + second number>string % + ] "" make ; + +: ctags-write ( seq path -- ) + ascii [ [ ctag print ] each ] with-file-writer ; + +: (ctags) ( -- seq ) + { } all-words [ + dup where [ + { } 2sequence suffix + ] [ + drop + ] if* + ] each ; + +: ctags ( path -- ) + (ctags) sort-keys swap ctags-write ; \ No newline at end of file diff --git a/extra/ctags/summary.txt b/extra/ctags/summary.txt new file mode 100644 index 0000000000..2025e02521 --- /dev/null +++ b/extra/ctags/summary.txt @@ -0,0 +1 @@ +Ctags generator From 3358e399d7e520a6358ad9cab7fb95dbc4b13f8d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jul 2008 18:11:59 -0500 Subject: [PATCH 49/77] { } 2sequence => 2array --- extra/ctags/ctags.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor index 5480772ba1..5b9ff90e5c 100644 --- a/extra/ctags/ctags.factor +++ b/extra/ctags/ctags.factor @@ -4,7 +4,7 @@ ! Simple Ctags generator ! Alfredo Beaumont -USING: kernel sequences io io.files io.backend +USING: arrays kernel sequences io io.files io.backend io.encodings.ascii math.parser vocabs definitions namespaces words sorting ; IN: ctags @@ -24,7 +24,7 @@ IN: ctags : (ctags) ( -- seq ) { } all-words [ dup where [ - { } 2sequence suffix + 2array suffix ] [ drop ] if* From 0bb85a1ef9bdd5d841b294db33d1a06a93f933d2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jul 2008 18:21:34 -0500 Subject: [PATCH 50/77] Fix obscure corner case; -include='compiler math' --- core/math/intervals/intervals.factor | 7 ++++++- core/optimizer/math/math.factor | 2 +- 2 files changed, 7 insertions(+), 2 deletions(-) diff --git a/core/math/intervals/intervals.factor b/core/math/intervals/intervals.factor index 9540081d5b..9b994b4bbf 100755 --- a/core/math/intervals/intervals.factor +++ b/core/math/intervals/intervals.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. ! Based on Slate's src/unfinished/interval.slate by Brian Rice. USING: accessors kernel sequences arrays math math.order -combinators ; +combinators generic ; IN: math.intervals TUPLE: interval { from read-only } { to read-only } ; @@ -177,6 +177,11 @@ C: interval : interval/ ( i1 i2 -- i3 ) [ [ / ] interval-op ] interval-division-op ; +: interval/-safe ( i1 i2 -- i3 ) + #! Just a hack to make the compiler work if bootstrap.math + #! is not loaded. + \ integer \ / method [ interval/ ] [ 2drop f ] if ; + : interval/i ( i1 i2 -- i3 ) [ [ [ /i ] interval-op ] interval-integer-op diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index b7a3ff28e7..27ef4042e2 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -158,7 +158,7 @@ optimizer.math.partial generic.standard system accessors ; { + { { fixnum integer } } interval+ } { - { { fixnum integer } } interval- } { * { { fixnum integer } } interval* } - { / { { fixnum rational } { integer rational } } interval/ } + { / { { fixnum rational } { integer rational } } interval/-safe } { /i { { fixnum integer } } interval/i } { shift { { fixnum integer } } interval-shift-safe } } [ From b1e534617992314663ca3fa2bfc9f85423334ed3 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 6 Jul 2008 18:28:41 -0500 Subject: [PATCH 51/77] More EINTR handling --- vm/os-unix.c | 12 ++++++++++-- 1 file changed, 10 insertions(+), 2 deletions(-) diff --git a/vm/os-unix.c b/vm/os-unix.c index 5b0da5a8d2..48d9a2dea8 100755 --- a/vm/os-unix.c +++ b/vm/os-unix.c @@ -322,8 +322,16 @@ void safe_write(int fd, void *data, size_t size) void safe_read(int fd, void *data, size_t size) { - if(read(fd,data,size) != size) - fatal_error("error reading fd",errno); + ssize_t bytes = read(fd,data,size); + if(bytes < 0) + { + if(errno == EINTR) + safe_read(fd,data,size); + else + fatal_error("error reading fd",errno); + } + else if(bytes != size) + fatal_error("unexpected eof on fd",bytes); } void *stdin_loop(void *arg) From a8808b7087aa43c0ce1166d857c7895e4c220166 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Jul 2008 10:39:04 -0500 Subject: [PATCH 52/77] Non-optimizing compiler now inlow inlines some primitives, this improves bootstrap time --- core/bootstrap/image/image.factor | 85 ++++++++- core/classes/algebra/algebra.factor | 3 + core/cpu/x86/32/bootstrap.factor | 1 + core/cpu/x86/64/bootstrap.factor | 1 + core/cpu/x86/bootstrap.factor | 84 +++++++++ core/generator/generator.factor | 2 +- core/generator/registers/registers.factor | 7 +- core/generic/standard/engines/engines.factor | 6 +- core/generic/standard/engines/tag/tag.factor | 2 +- .../standard/engines/tuple/tuple.factor | 32 ++-- core/io/streams/c/c.factor | 2 +- core/threads/threads.factor | 16 +- vm/os-unix.h | 2 + vm/quotations.c | 166 ++++++++++++++---- vm/run.h | 41 ++++- 15 files changed, 379 insertions(+), 71 deletions(-) diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index 58ee77fafd..a8fcc712eb 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -8,7 +8,7 @@ grouping growable classes classes.builtin classes.tuple classes.tuple.private words.private io.binary io.files vocabs vocabs.loader source-files definitions debugger quotations.private sequences.private combinators -io.encodings.binary math.order accessors ; +io.encodings.binary math.order math.private accessors slots.private ; IN: bootstrap.image : my-arch ( -- arch ) @@ -75,7 +75,7 @@ SYMBOL: objects : data-base 1024 ; inline -: userenv-size 64 ; inline +: userenv-size 70 ; inline : header-size 10 ; inline @@ -118,6 +118,29 @@ SYMBOL: jit-dispatch SYMBOL: jit-epilog SYMBOL: jit-return SYMBOL: jit-profiling +SYMBOL: jit-tag +SYMBOL: jit-tag-word +SYMBOL: jit-eq? +SYMBOL: jit-eq?-word +SYMBOL: jit-slot +SYMBOL: jit-slot-word +SYMBOL: jit-declare-word +SYMBOL: jit-drop +SYMBOL: jit-drop-word +SYMBOL: jit-dup +SYMBOL: jit-dup-word +SYMBOL: jit->r +SYMBOL: jit->r-word +SYMBOL: jit-r> +SYMBOL: jit-r>-word +SYMBOL: jit-swap +SYMBOL: jit-swap-word +SYMBOL: jit-over +SYMBOL: jit-over-word +SYMBOL: jit-fixnum-fast +SYMBOL: jit-fixnum-fast-word +SYMBOL: jit-fixnum>= +SYMBOL: jit-fixnum>=-word ! Default definition for undefined words SYMBOL: undefined-quot @@ -140,7 +163,30 @@ SYMBOL: undefined-quot { jit-epilog 33 } { jit-return 34 } { jit-profiling 35 } - { undefined-quot 37 } + { jit-tag 36 } + { jit-tag-word 37 } + { jit-eq? 38 } + { jit-eq?-word 39 } + { jit-slot 40 } + { jit-slot-word 41 } + { jit-declare-word 42 } + { jit-drop 43 } + { jit-drop-word 44 } + { jit-dup 45 } + { jit-dup-word 46 } + { jit->r 47 } + { jit->r-word 48 } + { jit-r> 49 } + { jit-r>-word 50 } + { jit-swap 51 } + { jit-swap-word 52 } + { jit-over 53 } + { jit-over-word 54 } + { jit-fixnum-fast 55 } + { jit-fixnum-fast-word 56 } + { jit-fixnum>= 57 } + { jit-fixnum>=-word 58 } + { undefined-quot 60 } } at header-size + ; : emit ( cell -- ) image get push ; @@ -414,6 +460,18 @@ M: quotation ' \ if jit-if-word set \ dispatch jit-dispatch-word set \ do-primitive jit-primitive-word set + \ tag jit-tag-word set + \ eq? jit-eq?-word set + \ slot jit-slot-word set + \ declare jit-declare-word set + \ drop jit-drop-word set + \ dup jit-dup-word set + \ >r jit->r-word set + \ r> jit-r>-word set + \ swap jit-swap-word set + \ over jit-over-word set + \ fixnum-fast jit-fixnum-fast-word set + \ fixnum>= jit-fixnum>=-word set [ undefined ] undefined-quot set { jit-code-format @@ -430,6 +488,27 @@ M: quotation ' jit-epilog jit-return jit-profiling + jit-tag + jit-tag-word + jit-eq? + jit-eq?-word + jit-slot + jit-slot-word + jit-declare-word + jit-drop + jit-drop-word + jit-dup + jit-dup-word + jit->r + jit->r-word + jit-r> + jit-r>-word + jit-swap + jit-swap-word + jit-fixnum-fast + jit-fixnum-fast-word + jit-fixnum>= + jit-fixnum>=-word undefined-quot } [ emit-userenv ] each ; diff --git a/core/classes/algebra/algebra.factor b/core/classes/algebra/algebra.factor index 1076901678..2d2498a1c3 100755 --- a/core/classes/algebra/algebra.factor +++ b/core/classes/algebra/algebra.factor @@ -224,3 +224,6 @@ M: anonymous-union (flatten-class) dup num-tags get >= [ drop \ hi-tag tag-number ] when ] map prune ; + +: class-tag ( class -- tag/f ) + class-tags dup length 1 = [ first ] [ drop f ] if ; diff --git a/core/cpu/x86/32/bootstrap.factor b/core/cpu/x86/32/bootstrap.factor index 312b952b84..386f1366fc 100755 --- a/core/cpu/x86/32/bootstrap.factor +++ b/core/cpu/x86/32/bootstrap.factor @@ -11,6 +11,7 @@ IN: bootstrap.x86 : temp-reg ( -- reg ) EBX ; : stack-reg ( -- reg ) ESP ; : ds-reg ( -- reg ) ESI ; +: rs-reg ( -- reg ) EDI ; : fixnum>slot@ ( -- ) arg0 1 SAR ; : rex-length ( -- n ) 0 ; diff --git a/core/cpu/x86/64/bootstrap.factor b/core/cpu/x86/64/bootstrap.factor index d167c2882a..0c9ce92edf 100755 --- a/core/cpu/x86/64/bootstrap.factor +++ b/core/cpu/x86/64/bootstrap.factor @@ -11,6 +11,7 @@ IN: bootstrap.x86 : temp-reg ( -- reg ) RBX ; : stack-reg ( -- reg ) RSP ; : ds-reg ( -- reg ) R14 ; +: rs-reg ( -- reg ) R15 ; : fixnum>slot@ ( -- ) ; : rex-length ( -- n ) 1 ; diff --git a/core/cpu/x86/bootstrap.factor b/core/cpu/x86/bootstrap.factor index 011c27112e..bf176eebfa 100755 --- a/core/cpu/x86/bootstrap.factor +++ b/core/cpu/x86/bootstrap.factor @@ -74,6 +74,90 @@ big-endian off arg0 quot-xt-offset [+] JMP ! execute branch ] rc-absolute-cell rt-literal 1 rex-length + jit-dispatch jit-define +[ + arg1 ds-reg [] MOV ! load from stack + arg1 tag-mask get AND ! compute tag + arg1 tag-bits get SHL ! tag the tag + ds-reg [] arg1 MOV ! push to stack +] f f f jit-tag jit-define + +: jit-compare ( -- ) + arg1 0 MOV ! load t + arg1 dup [] MOV + temp-reg \ f tag-number MOV ! load f + arg0 ds-reg [] MOV ! load first value + ds-reg bootstrap-cell SUB ! adjust stack pointer + ds-reg [] arg0 CMP ! compare with second value + ; + +[ + jit-compare + arg1 temp-reg CMOVNE ! not equal? + ds-reg [] arg1 MOV ! store +] rc-absolute-cell rt-literal 1 rex-length + jit-eq? jit-define + +[ + arg0 ds-reg [] MOV ! load slot number + ds-reg bootstrap-cell SUB ! adjust stack pointer + arg1 ds-reg [] MOV ! load object + fixnum>slot@ ! turn slot number into offset + arg1 tag-bits get SHR ! mask off tag + arg1 tag-bits get SHL + arg0 arg1 arg0 [+] MOV ! load slot value + ds-reg [] arg0 MOV ! push to stack +] f f f jit-slot jit-define + +[ + ds-reg bootstrap-cell SUB +] f f f jit-drop jit-define + +[ + arg0 ds-reg [] MOV + ds-reg bootstrap-cell ADD + ds-reg [] arg0 MOV +] f f f jit-dup jit-define + +[ + rs-reg bootstrap-cell ADD + arg0 ds-reg [] MOV + ds-reg bootstrap-cell SUB + rs-reg [] arg0 MOV +] f f f jit->r jit-define + +[ + ds-reg bootstrap-cell ADD + arg0 rs-reg [] MOV + rs-reg bootstrap-cell SUB + ds-reg [] arg0 MOV +] f f f jit-r> jit-define + +[ + arg0 ds-reg [] MOV + arg1 ds-reg bootstrap-cell neg [+] MOV + ds-reg bootstrap-cell neg [+] arg0 MOV + ds-reg [] arg1 MOV +] f f f jit-swap jit-define + +[ + arg0 ds-reg bootstrap-cell neg [+] MOV + ds-reg bootstrap-cell ADD + ds-reg [] arg0 MOV +] f f f jit-over jit-define + +[ + arg0 ds-reg [] MOV + ds-reg bootstrap-cell SUB + arg1 ds-reg [] MOV + arg1 arg0 SUB + ds-reg [] arg1 MOV +] f f f jit-fixnum-fast jit-define + +[ + jit-compare + arg1 temp-reg CMOVL ! not equal? + ds-reg [] arg1 MOV ! store +] rc-absolute-cell rt-literal 1 rex-length + jit-fixnum>= jit-define + [ stack-reg stack-frame-size bootstrap-cell - ADD ! unwind stack frame ] f f f jit-epilog jit-define diff --git a/core/generator/generator.factor b/core/generator/generator.factor index 07d8d6fdad..e646010c4c 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -32,7 +32,7 @@ SYMBOL: compiling-loops ! Label of current word, after prologue, makes recursion faster SYMBOL: current-label-start -: compiled-stack-traces? ( -- ? ) 36 getenv ; +: compiled-stack-traces? ( -- ? ) 59 getenv ; : begin-compiling ( word label -- ) H{ } clone compiling-loops set diff --git a/core/generator/registers/registers.factor b/core/generator/registers/registers.factor index 550bab72f4..45b6640b3a 100755 --- a/core/generator/registers/registers.factor +++ b/core/generator/registers/registers.factor @@ -562,13 +562,10 @@ M: loc lazy-store 2drop t ] if ; -: class-tag ( class -- tag/f ) - dup [ class-tags dup length 1 = [ first ] [ drop f ] if ] when ; - : class-matches? ( actual expected -- ? ) { { f [ drop t ] } - { known-tag [ class-tag >boolean ] } + { known-tag [ dup [ class-tag >boolean ] when ] } [ class<= ] } case ; @@ -639,7 +636,7 @@ PRIVATE> [ second template-matches? ] find nip ; : operand-tag ( operand -- tag/f ) - operand-class class-tag ; + operand-class dup [ class-tag ] when ; UNION: immediate fixnum POSTPONE: f ; diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor index bdac7c1dfe..f60ee6d0d1 100644 --- a/core/generic/standard/engines/engines.factor +++ b/core/generic/standard/engines/engines.factor @@ -22,7 +22,11 @@ GENERIC: engine>quot ( engine -- quot ) : linear-dispatch-quot ( alist -- quot ) default get [ drop ] prepend swap - [ >r [ dupd eq? ] curry r> \ drop prefix ] assoc-map + [ + [ [ dup ] swap [ eq? ] curry compose ] + [ [ drop ] prepose ] + bi* [ ] like + ] assoc-map alist>quot ; : split-methods ( assoc class -- first second ) diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor index c1e72a65de..02a7af105f 100644 --- a/core/generic/standard/engines/tag/tag.factor +++ b/core/generic/standard/engines/tag/tag.factor @@ -44,7 +44,7 @@ C: hi-tag-dispatch-engine "type" word-prop num-tags get - ; : hi-tag-quot ( -- quot ) - [ hi-tag ] num-tags get [ fixnum-fast ] curry compose ; + [ 0 slot ] num-tags get [ fixnum-fast ] curry compose ; M: hi-tag-dispatch-engine engine>quot methods>> engines>quots* [ >r hi-tag-number r> ] assoc-map diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index cf2d50b6e2..6f1773a21f 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -80,15 +80,17 @@ M: engine-word irrelevant? drop t ; : array-nth% ( n -- ) 2 + , [ slot { word } declare ] % ; -: tuple-layout-superclasses ( obj -- array ) - { tuple } declare - 1 slot { tuple-layout } declare - 4 slot { array } declare ; inline +: tuple-layout-superclasses% ( -- ) + [ + { tuple } declare + 1 slot { tuple-layout } declare + 4 slot { array } declare + ] % ; inline : tuple-dispatch-engine-body ( engine -- quot ) [ picker % - [ tuple-layout-superclasses ] % + tuple-layout-superclasses% [ n>> array-nth% ] [ methods>> [ @@ -106,7 +108,7 @@ M: echelon-dispatch-engine engine>quot ] [ [ picker % - [ tuple-layout-superclasses ] % + tuple-layout-superclasses% [ n>> array-nth% ] [ methods>> [ @@ -120,18 +122,24 @@ M: echelon-dispatch-engine engine>quot : >=-case-quot ( alist -- quot ) default get [ drop ] prepend swap - [ >r [ dupd fixnum>= ] curry r> \ drop prefix ] assoc-map + [ + [ [ dup ] swap [ fixnum>= ] curry compose ] + [ [ drop ] prepose ] + bi* [ ] like + ] assoc-map alist>quot ; -: tuple-layout-echelon ( obj -- array ) - { tuple } declare - 1 slot { tuple-layout } declare - 5 slot ; inline +: tuple-layout-echelon% ( -- ) + [ + { tuple } declare + 1 slot { tuple-layout } declare + 5 slot + ] % ; inline M: tuple-dispatch-engine engine>quot [ picker % - [ tuple-layout-echelon ] % + tuple-layout-echelon% [ tuple assumed set echelons>> dup empty? [ diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index 365d5b7c5d..de6d8519ca 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -58,7 +58,7 @@ M: object init-io ; : stdin-handle 11 getenv ; : stdout-handle 12 getenv ; -: stderr-handle 38 getenv ; +: stderr-handle 61 getenv ; M: object (init-stdio) stdin-handle diff --git a/core/threads/threads.factor b/core/threads/threads.factor index 4fe4c5bcb2..552d64cfe7 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -15,7 +15,7 @@ id continuation state runnable mailbox variables sleep-entry ; -: self ( -- thread ) 40 getenv ; inline +: self ( -- thread ) 63 getenv ; inline ! Thread-local storage : tnamespace ( -- assoc ) @@ -30,7 +30,7 @@ mailbox variables sleep-entry ; : tchange ( key quot -- ) tnamespace swap change-at ; inline -: threads 41 getenv ; +: threads 64 getenv ; : thread ( id -- thread ) threads at ; @@ -53,7 +53,7 @@ mailbox variables sleep-entry ; : unregister-thread ( thread -- ) check-registered id>> threads delete-at ; -: set-self ( thread -- ) 40 setenv ; inline +: set-self ( thread -- ) 63 setenv ; inline PRIVATE> @@ -68,9 +68,9 @@ PRIVATE> : ( quot name -- thread ) \ thread new-thread ; -: run-queue 42 getenv ; +: run-queue 65 getenv ; -: sleep-queue 43 getenv ; +: sleep-queue 66 getenv ; : resume ( thread -- ) f >>state @@ -207,9 +207,9 @@ GENERIC: error-in-thread ( error thread -- ) 42 setenv - 43 setenv + H{ } clone 64 setenv + 65 setenv + 66 setenv initial-thread global [ drop f "Initial" ] cache >>continuation diff --git a/vm/os-unix.h b/vm/os-unix.h index 6d220de903..6db03148cd 100755 --- a/vm/os-unix.h +++ b/vm/os-unix.h @@ -27,6 +27,8 @@ typedef char F_SYMBOL; #define OPEN_WRITE(path) fopen(path,"wb") #define FPRINTF(stream,format,arg) fprintf(stream,format,arg) +void start_thread(void *(*start_routine)(void *)); + void init_ffi(void); void ffi_dlopen(F_DLL *dll); void *ffi_dlsym(F_DLL *dll, F_SYMBOL *symbol); diff --git a/vm/quotations.c b/vm/quotations.c index e092aab4bf..0f60eea3e1 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -25,6 +25,13 @@ bool jit_fast_dispatch_p(F_ARRAY *array, CELL i) && array_nth(array,i + 1) == userenv[JIT_DISPATCH_WORD]; } +bool jit_ignore_declare_p(F_ARRAY *array, CELL i) +{ + return (i + 1) < array_capacity(array) + && type_of(array_nth(array,i)) == ARRAY_TYPE + && array_nth(array,i + 1) == userenv[JIT_DECLARE_WORD]; +} + F_ARRAY *code_to_emit(CELL name) { return untag_object(array_nth(untag_object(userenv[name]),0)); @@ -72,8 +79,24 @@ bool jit_stack_frame_p(F_ARRAY *array) for(i = 0; i < length - 1; i++) { - if(type_of(array_nth(array,i)) == WORD_TYPE) - return true; + CELL obj = array_nth(array,i); + if(type_of(obj) == WORD_TYPE) + { + if(obj != userenv[JIT_TAG_WORD] + && obj != userenv[JIT_EQP_WORD] + && obj != userenv[JIT_SLOT_WORD] + && obj != userenv[JIT_DROP_WORD] + && obj != userenv[JIT_DUP_WORD] + && obj != userenv[JIT_TO_R_WORD] + && obj != userenv[JIT_FROM_R_WORD] + && obj != userenv[JIT_SWAP_WORD] + && obj != userenv[JIT_OVER_WORD] + && obj != userenv[JIT_FIXNUM_MINUS_WORD] + && obj != userenv[JIT_FIXNUM_GE_WORD]) + { + return true; + } + } } return false; @@ -131,24 +154,74 @@ void jit_compile(CELL quot, bool relocate) switch(type_of(obj)) { case WORD_TYPE: - /* Emit the epilog before the primitive call gate - so that we save the C stack pointer minus the - current stack frame. */ - word = untag_object(obj); - - GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); - - if(i == length - 1) + /* Intrinsics */ + if(obj == userenv[JIT_TAG_WORD]) { - if(stack_frame) - EMIT(JIT_EPILOG,0); - - EMIT(JIT_WORD_JUMP,literals_count - 1); - - tail_call = true; + EMIT(JIT_TAG,0); + } + else if(obj == userenv[JIT_EQP_WORD]) + { + GROWABLE_ARRAY_ADD(literals,T); + EMIT(JIT_EQP,literals_count - 1); + } + else if(obj == userenv[JIT_SLOT_WORD]) + { + EMIT(JIT_SLOT,0); + } + else if(obj == userenv[JIT_DROP_WORD]) + { + EMIT(JIT_DROP,0); + } + else if(obj == userenv[JIT_DUP_WORD]) + { + EMIT(JIT_DUP,0); + } + else if(obj == userenv[JIT_TO_R_WORD]) + { + EMIT(JIT_TO_R,0); + } + else if(obj == userenv[JIT_FROM_R_WORD]) + { + EMIT(JIT_FROM_R,0); + } + else if(obj == userenv[JIT_SWAP_WORD]) + { + EMIT(JIT_SWAP,0); + } + else if(obj == userenv[JIT_OVER_WORD]) + { + EMIT(JIT_OVER,0); + } + else if(obj == userenv[JIT_FIXNUM_MINUS_WORD]) + { + EMIT(JIT_FIXNUM_MINUS,0); + } + else if(obj == userenv[JIT_FIXNUM_GE_WORD]) + { + GROWABLE_ARRAY_ADD(literals,T); + EMIT(JIT_FIXNUM_GE,literals_count - 1); } else - EMIT(JIT_WORD_CALL,literals_count - 1); + { + /* Emit the epilog before the primitive call gate + so that we save the C stack pointer minus the + current stack frame. */ + word = untag_object(obj); + + GROWABLE_ARRAY_ADD(literals,array_nth(untag_object(array),i)); + + if(i == length - 1) + { + if(stack_frame) + EMIT(JIT_EPILOG,0); + + EMIT(JIT_WORD_JUMP,literals_count - 1); + + tail_call = true; + } + else + EMIT(JIT_WORD_CALL,literals_count - 1); + } break; case WRAPPER_TYPE: wrapper = untag_object(obj); @@ -194,6 +267,11 @@ void jit_compile(CELL quot, bool relocate) tail_call = true; break; } + else if(jit_ignore_declare_p(untag_object(array),i)) + { + i++; + break; + } default: GROWABLE_ARRAY_ADD(literals,obj); EMIT(JIT_PUSH_LITERAL,literals_count - 1); @@ -261,24 +339,47 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) for(i = 0; i < length; i++) { CELL obj = array_nth(untag_object(array),i); - F_WORD *word; switch(type_of(obj)) { case WORD_TYPE: - word = untag_object(obj); - - if(i == length - 1) - { - if(stack_frame) - COUNT(JIT_EPILOG,i); - - COUNT(JIT_WORD_JUMP,i) - - tail_call = true; - } + /* Intrinsics */ + if(obj == userenv[JIT_TAG_WORD]) + COUNT(JIT_TAG,i) + else if(obj == userenv[JIT_EQP_WORD]) + COUNT(JIT_EQP,i) + else if(obj == userenv[JIT_SLOT_WORD]) + COUNT(JIT_SLOT,i) + else if(obj == userenv[JIT_DROP_WORD]) + COUNT(JIT_DROP,i) + else if(obj == userenv[JIT_DUP_WORD]) + COUNT(JIT_DUP,i) + else if(obj == userenv[JIT_TO_R_WORD]) + COUNT(JIT_TO_R,i) + else if(obj == userenv[JIT_FROM_R_WORD]) + COUNT(JIT_FROM_R,i) + else if(obj == userenv[JIT_SWAP_WORD]) + COUNT(JIT_SWAP,i) + else if(obj == userenv[JIT_OVER_WORD]) + COUNT(JIT_OVER,i) + else if(obj == userenv[JIT_FIXNUM_MINUS_WORD]) + COUNT(JIT_FIXNUM_MINUS,i) + else if(obj == userenv[JIT_FIXNUM_GE_WORD]) + COUNT(JIT_FIXNUM_GE,i) else - COUNT(JIT_WORD_CALL,i) + { + if(i == length - 1) + { + if(stack_frame) + COUNT(JIT_EPILOG,i); + + COUNT(JIT_WORD_JUMP,i) + + tail_call = true; + } + else + COUNT(JIT_WORD_CALL,i) + } break; case WRAPPER_TYPE: COUNT(JIT_PUSH_LITERAL,i) @@ -319,6 +420,11 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) tail_call = true; break; } + if(jit_ignore_declare_p(untag_object(array),i)) + { + i++; + break; + } default: COUNT(JIT_PUSH_LITERAL,i) break; diff --git a/vm/run.h b/vm/run.h index cc980453cf..b54640ec8a 100755 --- a/vm/run.h +++ b/vm/run.h @@ -1,4 +1,4 @@ -#define USER_ENV 64 +#define USER_ENV 70 typedef enum { NAMESTACK_ENV, /* used by library only */ @@ -47,20 +47,43 @@ typedef enum { JIT_EPILOG, JIT_RETURN, JIT_PROFILING, + JIT_TAG, + JIT_TAG_WORD, + JIT_EQP, + JIT_EQP_WORD, + JIT_SLOT, + JIT_SLOT_WORD, + JIT_DECLARE_WORD, + JIT_DROP, + JIT_DROP_WORD, + JIT_DUP, + JIT_DUP_WORD, + JIT_TO_R, + JIT_TO_R_WORD, + JIT_FROM_R, + JIT_FROM_R_WORD, + JIT_SWAP, + JIT_SWAP_WORD, + JIT_OVER, + JIT_OVER_WORD, + JIT_FIXNUM_MINUS, + JIT_FIXNUM_MINUS_WORD, + JIT_FIXNUM_GE, + JIT_FIXNUM_GE_WORD, - STACK_TRACES_ENV = 36, + STACK_TRACES_ENV = 59, - UNDEFINED_ENV = 37, /* default quotation for undefined words */ + UNDEFINED_ENV = 60, /* default quotation for undefined words */ - STDERR_ENV = 38, /* stderr FILE* handle */ + STDERR_ENV = 61, /* stderr FILE* handle */ - STAGE2_ENV = 39, /* have we bootstrapped? */ + STAGE2_ENV = 62, /* have we bootstrapped? */ - CURRENT_THREAD_ENV = 40, + CURRENT_THREAD_ENV = 63, - THREADS_ENV = 41, - RUN_QUEUE_ENV = 42, - SLEEP_QUEUE_ENV = 43, + THREADS_ENV = 64, + RUN_QUEUE_ENV = 65, + SLEEP_QUEUE_ENV = 66, } F_ENVTYPE; #define FIRST_SAVE_ENV BOOT_ENV From 5ba6a0c56d9555721e0dd446b517ec20861a3d7c Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Jul 2008 10:50:42 -0500 Subject: [PATCH 53/77] Comment out reload tests for now --- core/compiler/tests/reload.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/core/compiler/tests/reload.factor b/core/compiler/tests/reload.factor index 1e31757fca..b2b65b5868 100644 --- a/core/compiler/tests/reload.factor +++ b/core/compiler/tests/reload.factor @@ -1,6 +1,6 @@ IN: compiler.tests USE: vocabs.loader -"parser" reload -"sequences" reload -"kernel" reload +! "parser" reload +! "sequences" reload +! "kernel" reload From 763a45cc67377f1c03a5ab348b084eb1f14aab30 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Mon, 7 Jul 2008 12:14:07 -0500 Subject: [PATCH 54/77] Fix mmap on windows --- extra/io/windows/privileges/privileges.factor | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/extra/io/windows/privileges/privileges.factor b/extra/io/windows/privileges/privileges.factor index 144c799912..e169bdf12f 100755 --- a/extra/io/windows/privileges/privileges.factor +++ b/extra/io/windows/privileges/privileges.factor @@ -1,4 +1,5 @@ -USING: io.backend kernel continuations sequences ; +USING: io.backend kernel continuations sequences +system vocabs.loader combinators ; IN: io.windows.privileges HOOK: set-privilege io-backend ( name ? -- ) inline @@ -6,3 +7,8 @@ HOOK: set-privilege io-backend ( name ? -- ) inline : with-privileges ( seq quot -- ) over [ [ t set-privilege ] each ] curry compose swap [ [ f set-privilege ] each ] curry [ ] cleanup ; inline + +{ + { [ os winnt? ] [ "io.windows.nt.privileges" require ] } + { [ os wince? ] [ "io.windows.ce.privileges" require ] } +} cond From dd8e4651866911e18dbc73c5b589698e5ab9b54f Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Mon, 7 Jul 2008 23:21:23 +0200 Subject: [PATCH 55/77] Changed ctags-write to use set-file-lines as suggested --- extra/ctags/ctags-docs.factor | 12 ++++++++++++ extra/ctags/ctags-tests.factor | 9 +++++++-- extra/ctags/ctags.factor | 5 ++++- 3 files changed, 23 insertions(+), 3 deletions(-) diff --git a/extra/ctags/ctags-docs.factor b/extra/ctags/ctags-docs.factor index f2dbd8bc2b..2da85bd43d 100644 --- a/extra/ctags/ctags-docs.factor +++ b/extra/ctags/ctags-docs.factor @@ -32,6 +32,18 @@ HELP: ctags-write ( seq path -- ) { $notes { $snippet "tags" } " file will contain a single line: if\\t/path/to/factor/extra/unix/unix.factor\\t91" } ; +HELP: ctag-strings ( alist -- seq ) +{ $values { "alist" alist } + { "seq" sequence } } +{ $description "Converts an " { $snippet "alist" } " with ctag format (a word as key and a sequence whose first element is a resource name and a second element is a line number as value) in a " { $snippet "seq" } " of ctag strings." } +{ $examples + { $example + "USING: kernel ctags ;" + "{ { if { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings" + "{ \"if\\t/path/to/factor/extra/unix/unix.factor\\t91\" }" + } +} ; + HELP: ctag ( seq -- str ) { $values { "seq" sequence } { "str" string } } diff --git a/extra/ctags/ctags-tests.factor b/extra/ctags/ctags-tests.factor index dc6e402653..6c73b58ecb 100644 --- a/extra/ctags/ctags-tests.factor +++ b/extra/ctags/ctags-tests.factor @@ -1,7 +1,12 @@ -USING: kernel ctags tools.test io.backend sequences ; -IN: columns.tests +USING: kernel ctags tools.test io.backend sequences arrays prettyprint ; +IN: ctags.tests [ t ] [ "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append { if { "resource:extra/unix/unix.factor" 91 } } ctag = +] unit-test + +[ t ] [ + "if\t" "resource:extra/unix/unix.factor" normalize-path "\t91" 3append 1array + { { if { "resource:extra/unix/unix.factor" 91 } } } ctag-strings = ] unit-test \ No newline at end of file diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor index 5b9ff90e5c..c8bf2272fb 100644 --- a/extra/ctags/ctags.factor +++ b/extra/ctags/ctags.factor @@ -18,8 +18,11 @@ IN: ctags second number>string % ] "" make ; +: ctag-strings ( seq1 -- seq2 ) + { } swap [ ctag suffix ] each ; + : ctags-write ( seq path -- ) - ascii [ [ ctag print ] each ] with-file-writer ; + >r ctag-strings r> ascii set-file-lines ; : (ctags) ( -- seq ) { } all-words [ From 0206babefd46a1605692f38e2b638c8bddcbaf6c Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Mon, 7 Jul 2008 23:23:44 +0200 Subject: [PATCH 56/77] Small documentation fixes in ctags --- extra/ctags/ctags-docs.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/ctags/ctags-docs.factor b/extra/ctags/ctags-docs.factor index 2da85bd43d..9d98cae0b3 100644 --- a/extra/ctags/ctags-docs.factor +++ b/extra/ctags/ctags-docs.factor @@ -5,6 +5,7 @@ ARTICLE: "ctags" "Ctags file" { $emphasis "ctags" } " generates a index file of every factor word in ctags format as supported by vi and other editors. More information can be found at " { $url "http://en.wikipedia.org/wiki/Ctags" } "." { $subsection ctags } { $subsection ctags-write } +{ $subsection ctag-strings } { $subsection ctag } ; HELP: ctags ( path -- ) @@ -19,9 +20,9 @@ HELP: ctags ( path -- ) } ; HELP: ctags-write ( seq path -- ) -{ $values { "seq" sequence } +{ $values { "alist" "an association list" } { "path" "a pathname string" } } -{ $description "Stores a " { $snippet "seq" } " in " { $snippet "path" } ". " { $snippet "seq" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" } +{ $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" } { $examples { $example "USING: kernel ctags ;" @@ -33,7 +34,7 @@ HELP: ctags-write ( seq path -- ) { $snippet "tags" } " file will contain a single line: if\\t/path/to/factor/extra/unix/unix.factor\\t91" } ; HELP: ctag-strings ( alist -- seq ) -{ $values { "alist" alist } +{ $values { "alist" "an association list" } { "seq" sequence } } { $description "Converts an " { $snippet "alist" } " with ctag format (a word as key and a sequence whose first element is a resource name and a second element is a line number as value) in a " { $snippet "seq" } " of ctag strings." } { $examples From 374d72e953da619357e4c76a44546091303c0f25 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Mon, 7 Jul 2008 23:28:22 +0200 Subject: [PATCH 57/77] Fix a small typo in columns documentation --- extra/columns/columns-docs.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/columns/columns-docs.factor b/extra/columns/columns-docs.factor index a2f0cccf3b..a5b26e3fd0 100644 --- a/extra/columns/columns-docs.factor +++ b/extra/columns/columns-docs.factor @@ -11,7 +11,7 @@ HELP: column HELP: ( seq n -- column ) { $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } } -{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of" { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } +{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of " { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." } { $examples { $example "USING: arrays prettyprint columns ;" From 423ad4503b286a1e204e09336cae7b5b75e51f3a Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Jul 2008 19:11:49 -0500 Subject: [PATCH 58/77] Minor oversights --- Makefile | 1 - core/bootstrap/image/image.factor | 2 ++ 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 5f7cdca06d..48d4e214db 100755 --- a/Makefile +++ b/Makefile @@ -3,7 +3,6 @@ AR = ar LD = ld EXECUTABLE = factor -VERSION = 0.91 IMAGE = factor.image BUNDLE = Factor.app diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index a8fcc712eb..5812a0f8e7 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -505,6 +505,8 @@ M: quotation ' jit-r>-word jit-swap jit-swap-word + jit-over + jit-over-word jit-fixnum-fast jit-fixnum-fast-word jit-fixnum>= From 70e370f69de600c593bc1188e21641d1c66a0ffb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 7 Jul 2008 19:26:58 -0500 Subject: [PATCH 59/77] Fix walker --- Makefile | 1 + extra/tools/walker/walker-tests.factor | 6 +++++- vm/quotations.c | 3 +++ 3 files changed, 9 insertions(+), 1 deletion(-) diff --git a/Makefile b/Makefile index 48d4e214db..769aeacb8c 100755 --- a/Makefile +++ b/Makefile @@ -3,6 +3,7 @@ AR = ar LD = ld EXECUTABLE = factor +VERSION = 0.92 IMAGE = factor.image BUNDLE = Factor.app diff --git a/extra/tools/walker/walker-tests.factor b/extra/tools/walker/walker-tests.factor index 7f154a4dbf..e002af8f6d 100755 --- a/extra/tools/walker/walker-tests.factor +++ b/extra/tools/walker/walker-tests.factor @@ -1,7 +1,7 @@ USING: tools.walker io io.streams.string kernel math math.private namespaces prettyprint sequences tools.test continuations math.parser threads arrays tools.walker.debug -generic.standard ; +generic.standard sequences.private kernel.private ; IN: tools.walker.tests [ { } ] [ @@ -50,6 +50,10 @@ IN: tools.walker.tests [ 5 6 number= ] test-walker ] unit-test +[ { 0 } ] [ + [ 0 { array-capacity } declare ] test-walker +] unit-test + [ { f } ] [ [ "XYZ" "XYZ" mismatch ] test-walker ] unit-test diff --git a/vm/quotations.c b/vm/quotations.c index 0f60eea3e1..7eab41688a 100755 --- a/vm/quotations.c +++ b/vm/quotations.c @@ -422,7 +422,10 @@ F_FIXNUM quot_code_offset_to_scan(CELL quot, F_FIXNUM offset) } if(jit_ignore_declare_p(untag_object(array),i)) { + if(offset == 0) return i; + i++; + break; } default: From 0051a50b75804799677c286f65e6f3c90f8899ac Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Mon, 7 Jul 2008 19:36:33 -0500 Subject: [PATCH 60/77] Move general shufflers and combinators into generalizations, move narray there too --- core/bootstrap/primitives.factor | 2 +- core/debugger/debugger.factor | 2 +- core/sequences/sequences-docs.factor | 4 +- core/sequences/sequences.factor | 12 ++ extra/arrays/lib/authors.txt | 1 - extra/arrays/lib/lib.factor | 10 -- extra/arrays/lib/summary.txt | 1 - extra/arrays/lib/tags.txt | 1 - extra/bake/bake.factor | 2 +- extra/bake/fry/fry-tests.factor | 2 +- extra/bitfields/bitfields.factor | 2 +- extra/combinators/cleave/cleave.factor | 2 +- extra/combinators/lib/lib-docs.factor | 43 ------ extra/combinators/lib/lib-tests.factor | 8 -- extra/combinators/lib/lib.factor | 22 +-- .../short-circuit/short-circuit.factor | 2 +- extra/descriptive/descriptive.factor | 2 +- .../generalizations-docs.factor | 136 ++++++++++++++++++ .../generalizations-tests.factor | 32 +++++ extra/generalizations/generalizations.factor | 56 ++++++++ extra/html/parser/analyzer/analyzer.factor | 4 +- extra/inverse/inverse.factor | 4 +- extra/koszul/koszul.factor | 12 +- extra/logging/logging.factor | 2 +- extra/math/blas/matrices/matrices.factor | 3 +- extra/math/blas/vectors/vectors.factor | 2 +- extra/math/vectors/vectors.factor | 2 +- extra/mortar/mortar.factor | 2 +- extra/multi-methods/multi-methods.factor | 2 +- extra/processing/processing.factor | 2 +- extra/reports/noise/noise.factor | 4 +- extra/sequences/lib/lib.factor | 18 +-- extra/shuffle/authors.txt | 2 - extra/shuffle/shuffle-docs.factor | 84 ----------- extra/shuffle/shuffle-tests.factor | 25 ---- extra/shuffle/shuffle.factor | 39 ----- extra/shuffle/summary.txt | 1 - extra/shuffle/tags.txt | 1 - extra/spheres/spheres.factor | 2 +- extra/springies/springies.factor | 2 +- extra/tools/memory/memory.factor | 4 +- extra/unix/unix.factor | 2 +- extra/windows/com/com-tests.factor | 2 +- extra/windows/com/syntax/syntax.factor | 4 +- extra/windows/com/wrapper/wrapper.factor | 2 +- extra/windows/user32/user32.factor | 2 +- 46 files changed, 279 insertions(+), 292 deletions(-) delete mode 100755 extra/arrays/lib/authors.txt delete mode 100644 extra/arrays/lib/lib.factor delete mode 100644 extra/arrays/lib/summary.txt delete mode 100644 extra/arrays/lib/tags.txt mode change 100644 => 100755 extra/bake/bake.factor mode change 100644 => 100755 extra/bitfields/bitfields.factor mode change 100644 => 100755 extra/combinators/cleave/cleave.factor mode change 100644 => 100755 extra/combinators/short-circuit/short-circuit.factor create mode 100755 extra/generalizations/generalizations-docs.factor create mode 100755 extra/generalizations/generalizations-tests.factor create mode 100755 extra/generalizations/generalizations.factor mode change 100644 => 100755 extra/math/blas/matrices/matrices.factor mode change 100644 => 100755 extra/math/blas/vectors/vectors.factor mode change 100644 => 100755 extra/mortar/mortar.factor mode change 100644 => 100755 extra/processing/processing.factor delete mode 100644 extra/shuffle/authors.txt delete mode 100755 extra/shuffle/shuffle-docs.factor delete mode 100755 extra/shuffle/shuffle-tests.factor delete mode 100644 extra/shuffle/shuffle.factor delete mode 100644 extra/shuffle/summary.txt delete mode 100644 extra/shuffle/tags.txt mode change 100644 => 100755 extra/spheres/spheres.factor mode change 100644 => 100755 extra/springies/springies.factor mode change 100644 => 100755 extra/tools/memory/memory.factor diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 235f3894a1..6498dfde60 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -512,7 +512,7 @@ tuple { "unimplemented" "kernel.private" } { "gc-reset" "memory" } } -dup length [ >r first2 r> make-primitive ] 2each +[ >r first2 r> make-primitive ] each-index ! Bump build number "build" "kernel" create build 1+ 1quotation define diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index f5316b0858..6759c43094 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -52,7 +52,7 @@ M: string error. print ; nl "The following restarts are available:" print nl - dup length [ restart. ] 2each + [ restart. ] each-index ] if ; : print-error ( error -- ) diff --git a/core/sequences/sequences-docs.factor b/core/sequences/sequences-docs.factor index dc8d7b9789..86fd9be3d7 100755 --- a/core/sequences/sequences-docs.factor +++ b/core/sequences/sequences-docs.factor @@ -43,8 +43,8 @@ ARTICLE: "sequences-integers" "Integer sequences and counted loops" $nl "For example, the " { $link each } " combinator, given an integer, simply calls a quotation that number of times, pushing a counter on each iteration that ranges from 0 up to that integer:" { $example "3 [ . ] each" "0\n1\n2" } -"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link 2each } ":" -{ $example "{ \"a\" \"b\" \"c\" } dup length [\n \"Index: \" write . \"Element: \" write .\n] 2each" "Index: 0\nElement: \"a\"\nIndex: 1\nElement: \"b\"\nIndex: 2\nElement: \"c\"" } +"A common idiom is to iterate over a sequence, while also maintaining a loop counter. This can be done using " { $link each-index } ", " { $link map-index } " and " { $link reduce-index } "." +$nl "Combinators that produce new sequences, such as " { $link map } ", will output an array if the input is an integer." ; ARTICLE: "sequences-access" "Accessing sequence elements" diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 7560c8f73e..1c6b96d0d5 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -426,6 +426,18 @@ PRIVATE> : follow ( obj quot -- seq ) >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline +: prepare-index ( seq quot -- seq n quot ) + >r dup length r> ; inline + +: each-index ( seq quot -- ) + prepare-index 2each ; inline + +: map-index ( seq quot -- ) + prepare-index 2map ; inline + +: reduce-index ( seq identity quot -- ) + swapd each-index ; inline + : index ( obj seq -- n ) [ = ] with find drop ; diff --git a/extra/arrays/lib/authors.txt b/extra/arrays/lib/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/extra/arrays/lib/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/extra/arrays/lib/lib.factor b/extra/arrays/lib/lib.factor deleted file mode 100644 index 6530e65ed6..0000000000 --- a/extra/arrays/lib/lib.factor +++ /dev/null @@ -1,10 +0,0 @@ - -USING: kernel arrays sequences sequences.private macros ; - -IN: arrays.lib - -MACRO: narray ( n -- quot ) - dup [ f ] curry - swap [ - [ swap [ set-nth-unsafe ] keep ] curry - ] map concat append ; diff --git a/extra/arrays/lib/summary.txt b/extra/arrays/lib/summary.txt deleted file mode 100644 index 5ecd994103..0000000000 --- a/extra/arrays/lib/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Non-core array words diff --git a/extra/arrays/lib/tags.txt b/extra/arrays/lib/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/extra/arrays/lib/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/extra/bake/bake.factor b/extra/bake/bake.factor old mode 100644 new mode 100755 index 4ce7bfb586..db77d92720 --- a/extra/bake/bake.factor +++ b/extra/bake/bake.factor @@ -1,7 +1,7 @@ USING: kernel parser namespaces sequences quotations arrays vectors splitting words math - macros arrays.lib combinators.lib combinators.conditional newfx ; + macros generalizations combinators.lib combinators.conditional newfx ; IN: bake diff --git a/extra/bake/fry/fry-tests.factor b/extra/bake/fry/fry-tests.factor index 289e1b12fe..13202a78f5 100755 --- a/extra/bake/fry/fry-tests.factor +++ b/extra/bake/fry/fry-tests.factor @@ -1,6 +1,6 @@ USING: tools.test math prettyprint kernel io arrays vectors sequences - arrays.lib bake bake.fry ; + generalizations bake bake.fry ; IN: bake.fry.tests diff --git a/extra/bitfields/bitfields.factor b/extra/bitfields/bitfields.factor old mode 100644 new mode 100755 index 410fd4bdec..76e8d7883d --- a/extra/bitfields/bitfields.factor +++ b/extra/bitfields/bitfields.factor @@ -1,6 +1,6 @@ USING: parser lexer kernel math sequences namespaces assocs summary words splitting math.parser arrays sequences.next mirrors -shuffle compiler.units ; +generalizations compiler.units ; IN: bitfields ! Example: diff --git a/extra/combinators/cleave/cleave.factor b/extra/combinators/cleave/cleave.factor old mode 100644 new mode 100755 index 9b8a790760..f5aeeff619 --- a/extra/combinators/cleave/cleave.factor +++ b/extra/combinators/cleave/cleave.factor @@ -1,6 +1,6 @@ USING: kernel combinators words quotations arrays sequences locals macros - shuffle combinators.lib arrays.lib fry ; + shuffle combinators.lib generalizations fry ; IN: combinators.cleave diff --git a/extra/combinators/lib/lib-docs.factor b/extra/combinators/lib/lib-docs.factor index ccb1fca9a1..fe2f3556ef 100755 --- a/extra/combinators/lib/lib-docs.factor +++ b/extra/combinators/lib/lib-docs.factor @@ -11,46 +11,3 @@ HELP: generate "[ 20 random-prime ] [ 4 mod 3 = ] generate ." "526367" } ; - -HELP: ndip -{ $values { "quot" quotation } { "n" number } } -{ $description "A generalisation of " { $link dip } " that can work " -"for any stack depth. The quotation will be called with a stack that " -"has 'n' items removed first. The 'n' items are then put back on the " -"stack. The quotation can consume and produce any number of items." -} -{ $examples - { $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } - { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } -} -{ $see-also dip 2dip } ; - -HELP: nslip -{ $values { "n" number } } -{ $description "A generalisation of " { $link slip } " that can work " -"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " -"removed from the stack, the quotation called, and the items restored." -} -{ $examples - { $example "USING: combinators.lib prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } -} -{ $see-also slip nkeep } ; - -HELP: nkeep -{ $values { "quot" quotation } { "n" number } } -{ $description "A generalisation of " { $link keep } " that can work " -"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " -"saved, the quotation called, and the items restored." -} -{ $examples - { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } -} -{ $see-also keep nslip } ; - -! HELP: && -! { $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } } -! { $description "Calls each quotation in turn; outputs " { $link f } " if one of the quotations output " { $link f } ", otherwise outputs " { $link t } ". As soon as a quotation outputs " { $link f } ", evaluation stops and subsequent quotations are not called." } ; - -! HELP: || -! { $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } } -! { $description "Calls each quotation in turn; outputs " { $link t } " if one of the quotations output " { $link t } ", otherwise outputs " { $link f } ". As soon as a quotation outputs " { $link t } ", evaluation stops and subsequent quotations are not called." } ; diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index e511e88fcc..89d3ed7f7d 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -5,14 +5,6 @@ IN: combinators.lib.tests [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test -[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer -{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test -[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer -{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test -[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test -[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test -[ [ dup 2^ 2array ] 5 napply ] must-infer - [ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test [ { "foo" "xbarx" } ] diff --git a/extra/combinators/lib/lib.factor b/extra/combinators/lib/lib.factor index 3fab4f62ae..4af12a9ad6 100755 --- a/extra/combinators/lib/lib.factor +++ b/extra/combinators/lib/lib.factor @@ -4,7 +4,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel combinators fry namespaces quotations hashtables sequences assocs arrays inference effects math math.ranges -arrays.lib shuffle macros continuations locals ; +generalizations macros continuations locals ; IN: combinators.lib @@ -12,30 +12,10 @@ IN: combinators.lib ! Generalized versions of core combinators ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -MACRO: ndip ( quot n -- ) dup saver -rot restorer 3append ; - -MACRO: nslip ( n -- ) dup saver [ call ] rot restorer 3append ; - : 4slip ( quot a b c d -- a b c d ) 4 nslip ; inline -MACRO: nkeep ( n -- ) - [ ] [ 1+ ] [ ] tri - '[ [ , ndup ] dip , -nrot , nslip ] ; - : 4keep ( w x y z quot -- w x y z ) 4 nkeep ; inline -MACRO: ncurry ( n -- ) [ curry ] n*quot ; - -MACRO:: nwith ( quot n -- ) - [let | n' [ n 1+ ] | - [ n' -nrot [ n' nrot quot call ] n ncurry ] ] ; - -MACRO: napply ( n -- ) - 2 [a,b] - [ [ 1- ] [ ] bi - '[ , ntuck , nslip ] ] - map concat >quotation [ call ] append ; - : 2with ( param1 param2 obj quot -- obj curry ) with with ; inline diff --git a/extra/combinators/short-circuit/short-circuit.factor b/extra/combinators/short-circuit/short-circuit.factor old mode 100644 new mode 100755 index c74a2ca4fb..a484e09de1 --- a/extra/combinators/short-circuit/short-circuit.factor +++ b/extra/combinators/short-circuit/short-circuit.factor @@ -1,6 +1,6 @@ USING: kernel combinators quotations arrays sequences assocs - locals shuffle macros fry ; + locals generalizations macros fry ; IN: combinators.short-circuit diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor index 3b55aa0521..4b40747e9f 100755 --- a/extra/descriptive/descriptive.factor +++ b/extra/descriptive/descriptive.factor @@ -1,6 +1,6 @@ USING: words kernel sequences combinators.lib locals locals.private accessors parser namespaces continuations -summary definitions arrays.lib arrays ; +summary definitions generalizations arrays ; IN: descriptive ERROR: descriptive-error args underlying word ; diff --git a/extra/generalizations/generalizations-docs.factor b/extra/generalizations/generalizations-docs.factor new file mode 100755 index 0000000000..decabdc89d --- /dev/null +++ b/extra/generalizations/generalizations-docs.factor @@ -0,0 +1,136 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup kernel sequences quotations +math ; +IN: generalizations + +HELP: npick +{ $values { "n" integer } } +{ $description "A generalization of " { $link dup } ", " +{ $link over } " and " { $link pick } " that can work " +"for any stack depth. The nth item down the stack will be copied and " +"placed on the top of the stack." +} +{ $examples + { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } +} +{ $see-also dup over pick } ; + +HELP: ndup +{ $values { "n" integer } } +{ $description "A generalization of " { $link dup } ", " +{ $link 2dup } " and " { $link 3dup } " that can work " +"for any number of items. The n topmost items on the stack will be copied and " +"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" } +} +{ $see-also dup 2dup 3dup } ; + +HELP: nnip +{ $values { "n" integer } } +{ $description "A generalization of " { $link nip } " and " { $link 2nip } +" that can work " +"for any number of items." +} +{ $examples + { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" } +} +{ $see-also nip 2nip } ; + +HELP: ndrop +{ $values { "n" integer } } +{ $description "A generalization of " { $link drop } +" that can work " +"for any number of items." +} +{ $examples + { $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" } +} +{ $see-also drop 2drop 3drop } ; + +HELP: nrot +{ $values { "n" integer } } +{ $description "A generalization of " { $link rot } " that works for any " +"number of items on the stack. " +} +{ $examples + { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } +} +{ $see-also rot -nrot } ; + +HELP: -nrot +{ $values { "n" integer } } +{ $description "A generalization of " { $link -rot } " that works for any " +"number of items on the stack. " +} +{ $examples + { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } +} +{ $see-also rot nrot } ; + +HELP: nrev +{ $values { "n" integer } } +{ $description "A generalization of " { $link spin } " that reverses any number of items at the top of the stack." +} +{ $examples + { $example "USING: prettyprint generalizations ;" "1 2 3 4 nrev .s" "4\n3\n2\n1\n" } +} +{ $see-also rot nrot } ; + +HELP: ndip +{ $values { "quot" quotation } { "n" number } } +{ $description "A generalization of " { $link dip } " that can work " +"for any stack depth. The quotation will be called with a stack that " +"has 'n' items removed first. The 'n' items are then put back on the " +"stack. The quotation can consume and produce any number of items." +} +{ $examples + { $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } + { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } +} +{ $see-also dip 2dip } ; + +HELP: nslip +{ $values { "n" number } } +{ $description "A generalization of " { $link slip } " that can work " +"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " +"removed from the stack, the quotation called, and the items restored." +} +{ $examples + { $example "USING: combinators.lib prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } +} +{ $see-also slip nkeep } ; + +HELP: nkeep +{ $values { "quot" quotation } { "n" number } } +{ $description "A generalization of " { $link keep } " that can work " +"for any stack depth. The first " { $snippet "n" } " items after the quotation will be " +"saved, the quotation called, and the items restored." +} +{ $examples + { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" } +} +{ $see-also keep nslip } ; + +ARTICLE: "generalizations" "Generalized shuffle words and combinators" +"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 narray } +{ $subsection ndup } +{ $subsection npick } +{ $subsection nrot } +{ $subsection -nrot } +{ $subsection nnip } +{ $subsection ndrop } +{ $subsection nrev } +{ $subsection ndip } +{ $subsection nslip } +{ $subsection nkeep } +{ $subsection ncurry } +{ $subsection nwith } +{ $subsection napply } ; + +ABOUT: "generalizations" diff --git a/extra/generalizations/generalizations-tests.factor b/extra/generalizations/generalizations-tests.factor new file mode 100755 index 0000000000..1210143094 --- /dev/null +++ b/extra/generalizations/generalizations-tests.factor @@ -0,0 +1,32 @@ +USING: tools.test generalizations kernel math arrays ; +IN: generalizations.tests + +{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test +{ 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test +{ 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test +{ 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test +[ 1 1 ndup ] must-infer +{ 1 1 } [ 1 1 ndup ] unit-test +{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test +{ 1 2 3 1 2 3 } [ 1 2 3 3 ndup ] unit-test +{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4 ndup ] unit-test +[ 1 2 2 nrot ] must-infer +{ 2 1 } [ 1 2 2 nrot ] unit-test +{ 2 3 1 } [ 1 2 3 3 nrot ] unit-test +{ 2 3 4 1 } [ 1 2 3 4 4 nrot ] unit-test +[ 1 2 2 -nrot ] must-infer +{ 2 1 } [ 1 2 2 -nrot ] unit-test +{ 3 1 2 } [ 1 2 3 3 -nrot ] unit-test +{ 4 1 2 3 } [ 1 2 3 4 4 -nrot ] unit-test +[ 1 2 3 4 3 nnip ] must-infer +{ 4 } [ 1 2 3 4 3 nnip ] unit-test +[ 1 2 3 4 4 ndrop ] must-infer +{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test + +[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer +{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test +[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer +{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test +[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test +[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test +[ [ dup 2^ 2array ] 5 napply ] must-infer diff --git a/extra/generalizations/generalizations.factor b/extra/generalizations/generalizations.factor new file mode 100755 index 0000000000..6cbb13518e --- /dev/null +++ b/extra/generalizations/generalizations.factor @@ -0,0 +1,56 @@ +! Copyright (C) 2007, 2008 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences sequences.private namespaces math math.ranges +combinators macros quotations fry locals arrays ; +IN: generalizations + +MACRO: narray ( n -- quot ) + dup [ f ] curry + swap [ + [ swap [ set-nth-unsafe ] keep ] curry + ] map concat append ; + +MACRO: npick ( n -- ) + 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; + +MACRO: ndup ( n -- ) + dup '[ , npick ] n*quot ; + +MACRO: nrot ( n -- ) + 1- dup saver swap [ r> swap ] n*quot append ; + +MACRO: -nrot ( n -- ) + 1- dup [ swap >r ] n*quot swap restorer append ; + +MACRO: ndrop ( n -- ) + [ drop ] n*quot ; + +: nnip ( n -- ) + swap >r ndrop r> ; inline + +MACRO: ntuck ( n -- ) + 2 + [ dupd -nrot ] curry ; + +MACRO: nrev ( n -- quot ) + 1 [a,b] [ '[ , -nrot ] ] map concat ; + +MACRO: ndip ( quot n -- ) + dup saver -rot restorer 3append ; + +MACRO: nslip ( n -- ) + dup saver [ call ] rot restorer 3append ; + +MACRO: nkeep ( n -- ) + [ ] [ 1+ ] [ ] tri + '[ [ , ndup ] dip , -nrot , nslip ] ; + +MACRO: ncurry ( n -- ) [ curry ] n*quot ; + +MACRO:: nwith ( quot n -- ) + [let | n' [ n 1+ ] | + [ n' -nrot [ n' nrot quot call ] n ncurry ] ] ; + +MACRO: napply ( n -- ) + 2 [a,b] + [ [ 1- ] keep '[ , ntuck , nslip ] ] + map concat >quotation [ call ] append ; diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor index f6fccd42ec..dca727b9dc 100755 --- a/extra/html/parser/analyzer/analyzer.factor +++ b/extra/html/parser/analyzer/analyzer.factor @@ -1,6 +1,6 @@ USING: assocs html.parser kernel math sequences strings ascii -arrays shuffle unicode.case namespaces splitting http -sequences.lib accessors io combinators http.client urls ; +arrays generalizations shuffle unicode.case namespaces splitting +http sequences.lib accessors io combinators http.client urls ; IN: html.parser.analyzer TUPLE: link attributes clickable ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 4a35fbab24..5a8ef4c787 100755 --- a/extra/inverse/inverse.factor +++ b/extra/inverse/inverse.factor @@ -1,10 +1,10 @@ ! Copyright (C) 2007, 2008 Daniel Ehrenberg. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel words summary slots quotations -sequences assocs math arrays inference effects shuffle +sequences assocs math arrays inference effects generalizations continuations debugger classes.tuple namespaces vectors bit-arrays byte-arrays strings sbufs math.functions macros -sequences.private combinators mirrors combinators.lib +sequences.private combinators mirrors combinators.short-circuit ; IN: inverse diff --git a/extra/koszul/koszul.factor b/extra/koszul/koszul.factor index 188cfaa1cf..37c2137433 100755 --- a/extra/koszul/koszul.factor +++ b/extra/koszul/koszul.factor @@ -257,11 +257,11 @@ DEFER: (d) [ laplacian-kernel ] graded-laplacian ; : graded-basis. ( seq -- ) - dup length [ + [ "=== Degree " write pprint ": dimension " write dup length . [ alt. ] each - ] 2each ; + ] each-index ; : bigraded-triple ( u-deg z-deg bigraded-basis -- triple ) #! d: C(u,z) ---> C(u+2,z-1) @@ -289,11 +289,11 @@ DEFER: (d) [ laplacian-kernel ] bigraded-laplacian ; : bigraded-basis. ( seq -- ) - dup length [ + [ "=== U-degree " write . - dup length [ + [ " === Z-degree " write pprint ": dimension " write dup length . [ " " write alt. ] each - ] 2each - ] 2each ; + ] each-index + ] each-index ; diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 37ea9ac507..78a3002906 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -3,7 +3,7 @@ USING: logging.server sequences namespaces concurrency.messaging words kernel arrays shuffle tools.annotations prettyprint.config prettyprint debugger io.streams.string -splitting continuations effects arrays.lib parser strings +splitting continuations effects generalizations parser strings quotations fry symbols accessors ; IN: logging diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor old mode 100644 new mode 100755 index 99f20b432b..c07dfca76d --- a/extra/math/blas/matrices/matrices.factor +++ b/extra/math/blas/matrices/matrices.factor @@ -2,7 +2,8 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.lib combinators.short-circuit fry kernel locals macros math math.blas.cblas math.blas.vectors math.blas.vectors.private math.complex math.functions math.order multi-methods qualified -sequences sequences.merged sequences.private shuffle symbols ; +sequences sequences.merged sequences.private generalizations +shuffle symbols ; QUALIFIED: syntax IN: math.blas.matrices diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor old mode 100644 new mode 100755 index 3c927318a6..18370f12c0 --- a/extra/math/blas/vectors/vectors.factor +++ b/extra/math/blas/vectors/vectors.factor @@ -1,7 +1,7 @@ USING: accessors alien alien.c-types arrays byte-arrays combinators combinators.short-circuit fry kernel macros math math.blas.cblas math.complex math.functions math.order multi-methods qualified -sequences sequences.private shuffle ; +sequences sequences.private generalizations ; QUALIFIED: syntax IN: math.blas.vectors diff --git a/extra/math/vectors/vectors.factor b/extra/math/vectors/vectors.factor index 5572a0cf53..b6ac459123 100755 --- a/extra/math/vectors/vectors.factor +++ b/extra/math/vectors/vectors.factor @@ -25,7 +25,7 @@ IN: math.vectors : normalize ( u -- v ) dup norm v/n ; : set-axis ( u v axis -- w ) - dup length [ >r zero? 2over ? r> swap nth ] 2map 2nip ; + [ >r zero? 2over ? r> swap nth ] map-index 2nip ; HINTS: vneg { array } ; HINTS: norm-sq { array } ; diff --git a/extra/mortar/mortar.factor b/extra/mortar/mortar.factor old mode 100644 new mode 100755 index 1b5b6f2393..5b7f3356c1 --- a/extra/mortar/mortar.factor +++ b/extra/mortar/mortar.factor @@ -1,6 +1,6 @@ USING: kernel io parser lexer words namespaces quotations arrays assocs sequences - splitting grouping math shuffle ; + splitting grouping math generalizations ; IN: mortar diff --git a/extra/multi-methods/multi-methods.factor b/extra/multi-methods/multi-methods.factor index c8128c33ee..69dca2affc 100755 --- a/extra/multi-methods/multi-methods.factor +++ b/extra/multi-methods/multi-methods.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: kernel math sequences vectors classes classes.algebra combinators arrays words assocs parser namespaces definitions -prettyprint prettyprint.backend quotations arrays.lib +prettyprint prettyprint.backend quotations generalizations debugger io compiler.units kernel.private effects accessors hashtables sorting shuffle math.order sets ; IN: multi-methods diff --git a/extra/processing/processing.factor b/extra/processing/processing.factor old mode 100644 new mode 100755 index e089b15e7e..fb9f321f47 --- a/extra/processing/processing.factor +++ b/extra/processing/processing.factor @@ -1,7 +1,7 @@ USING: kernel namespaces threads combinators sequences arrays math math.functions math.ranges random - opengl.gl opengl.glu vars multi-methods shuffle + opengl.gl opengl.glu vars multi-methods generalizations shuffle ui ui.gestures ui.gadgets diff --git a/extra/reports/noise/noise.factor b/extra/reports/noise/noise.factor index 32a43a4fb4..ff88abad61 100755 --- a/extra/reports/noise/noise.factor +++ b/extra/reports/noise/noise.factor @@ -1,7 +1,7 @@ -USING: accessors assocs math kernel shuffle combinators.lib +USING: accessors assocs math kernel shuffle generalizations words quotations arrays combinators sequences math.vectors io.styles prettyprint vocabs sorting io generic locals.private -math.statistics math.order ; +math.statistics math.order combinators.lib ; IN: reports.noise : badness ( word -- n ) diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor index 1debe3f91b..3b54abfeab 100755 --- a/extra/sequences/lib/lib.factor +++ b/extra/sequences/lib/lib.factor @@ -4,7 +4,8 @@ USING: combinators.lib kernel sequences math namespaces assocs random sequences.private shuffle math.functions arrays math.parser math.private sorting strings ascii macros -assocs.lib quotations hashtables math.order locals ; +assocs.lib quotations hashtables math.order locals +generalizations ; IN: sequences.lib : each-withn ( seq quot n -- ) nwith each ; inline @@ -24,21 +25,6 @@ MACRO: firstn ( n -- ) concat >quotation [ drop ] compose ; -: prepare-index ( seq quot -- seq n quot ) - >r dup length r> ; inline - -: each-index ( seq quot -- ) - #! quot: ( elt index -- ) - prepare-index 2each ; inline - -: map-index ( seq quot -- ) - #! quot: ( elt index -- obj ) - prepare-index 2map ; inline - -: reduce-index ( seq identity quot -- ) - #! quot: ( prev elt index -- next ) - swapd each-index ; inline - ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! : each-percent ( seq quot -- ) diff --git a/extra/shuffle/authors.txt b/extra/shuffle/authors.txt deleted file mode 100644 index 26093b451b..0000000000 --- a/extra/shuffle/authors.txt +++ /dev/null @@ -1,2 +0,0 @@ -Chris Double -Doug Coleman diff --git a/extra/shuffle/shuffle-docs.factor b/extra/shuffle/shuffle-docs.factor deleted file mode 100755 index 4caace3b00..0000000000 --- a/extra/shuffle/shuffle-docs.factor +++ /dev/null @@ -1,84 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup kernel sequences ; -IN: shuffle - -HELP: npick -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link dup } ", " -{ $link over } " and " { $link pick } " that can work " -"for any stack depth. The nth item down the stack will be copied and " -"placed on the top of the stack." -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } -} -{ $see-also dup over pick } ; - -HELP: ndup -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link dup } ", " -{ $link 2dup } " and " { $link 3dup } " that can work " -"for any number of items. The n topmost items on the stack will be copied and " -"placed on the top of the stack." -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } -} -{ $see-also dup 2dup 3dup } ; - -HELP: nnip -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link nip } " and " { $link 2nip } -" that can work " -"for any number of items." -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 nnip .s" "4" } -} -{ $see-also nip 2nip } ; - -HELP: ndrop -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link drop } -" that can work " -"for any number of items." -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 ndrop .s" "1" } -} -{ $see-also drop 2drop 3drop } ; - -HELP: nrot -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link rot } " that works for any " -"number of items on the stack. " -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } -} -{ $see-also rot -nrot } ; - -HELP: -nrot -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link -rot } " that works for any " -"number of items on the stack. " -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } -} -{ $see-also rot nrot } ; - -ARTICLE: { "shuffle" "overview" } "Extra shuffle words" -"A number of stack shuffling words for those rare times when you " -"need to deal with tricky stack situations and can't refactor the " -"code to work around it." -{ $subsection ndup } -{ $subsection npick } -{ $subsection nrot } -{ $subsection -nrot } -{ $subsection nnip } -{ $subsection ndrop } ; - -IN: shuffle -ABOUT: { "shuffle" "overview" } \ No newline at end of file diff --git a/extra/shuffle/shuffle-tests.factor b/extra/shuffle/shuffle-tests.factor deleted file mode 100755 index 9f2b8e01a9..0000000000 --- a/extra/shuffle/shuffle-tests.factor +++ /dev/null @@ -1,25 +0,0 @@ -USING: arrays shuffle kernel math tools.test inference words ; - -[ 8 ] [ 5 6 7 8 3nip ] unit-test -{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test -{ 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test -{ 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test -{ 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test -{ t } [ [ 1 1 ndup ] infer >boolean ] unit-test -{ 1 1 } [ 1 1 ndup ] unit-test -{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test -{ 1 2 3 1 2 3 } [ 1 2 3 3 ndup ] unit-test -{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4 ndup ] unit-test -{ t } [ [ 1 2 2 nrot ] infer >boolean ] unit-test -{ 2 1 } [ 1 2 2 nrot ] unit-test -{ 2 3 1 } [ 1 2 3 3 nrot ] unit-test -{ 2 3 4 1 } [ 1 2 3 4 4 nrot ] unit-test -{ t } [ [ 1 2 2 -nrot ] infer >boolean ] unit-test -{ 2 1 } [ 1 2 2 -nrot ] unit-test -{ 3 1 2 } [ 1 2 3 3 -nrot ] unit-test -{ 4 1 2 3 } [ 1 2 3 4 4 -nrot ] unit-test -{ t } [ [ 1 2 3 4 3 nnip ] infer >boolean ] unit-test -{ 4 } [ 1 2 3 4 3 nnip ] unit-test -{ t } [ [ 1 2 3 4 4 ndrop ] infer >boolean ] unit-test -{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test -[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor deleted file mode 100644 index 2366d15cff..0000000000 --- a/extra/shuffle/shuffle.factor +++ /dev/null @@ -1,39 +0,0 @@ -! Copyright (C) 2007 Chris Double, Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces math inference.transforms - combinators macros quotations math.ranges fry ; - -IN: shuffle - -MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; - -MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ; - -MACRO: nrot ( n -- ) 1- dup saver swap [ r> swap ] n*quot append ; - -MACRO: -nrot ( n -- ) 1- dup [ swap >r ] n*quot swap restorer append ; - -MACRO: ndrop ( n -- ) [ drop ] n*quot ; - -: nnip ( n -- ) swap >r ndrop r> ; inline - -MACRO: ntuck ( n -- ) 2 + '[ dup , -nrot ] ; - -: 2swap ( x y z t -- z t x y ) rot >r rot r> ; 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 - -MACRO: nrev ( n -- quot ) - [ 1+ ] map - reverse - [ [ -nrot ] curry ] map concat ; diff --git a/extra/shuffle/summary.txt b/extra/shuffle/summary.txt deleted file mode 100644 index 12c22b8ae0..0000000000 --- a/extra/shuffle/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Additional shuffle words diff --git a/extra/shuffle/tags.txt b/extra/shuffle/tags.txt deleted file mode 100644 index f4274299b1..0000000000 --- a/extra/shuffle/tags.txt +++ /dev/null @@ -1 +0,0 @@ -extensions diff --git a/extra/spheres/spheres.factor b/extra/spheres/spheres.factor old mode 100644 new mode 100755 index 9d06987bcd..dff7313eec --- a/extra/spheres/spheres.factor +++ b/extra/spheres/spheres.factor @@ -1,6 +1,6 @@ USING: kernel opengl.demo-support opengl.gl opengl.shaders opengl.framebuffers opengl multiline ui.gadgets accessors sequences ui.render ui math -arrays arrays.lib combinators ; +arrays generalizations combinators ; IN: spheres STRING: plane-vertex-shader diff --git a/extra/springies/springies.factor b/extra/springies/springies.factor old mode 100644 new mode 100755 index cd6e1a7cfb..1856115863 --- a/extra/springies/springies.factor +++ b/extra/springies/springies.factor @@ -1,6 +1,6 @@ USING: kernel combinators sequences arrays math math.vectors - shuffle vars ; + generalizations vars ; IN: springies diff --git a/extra/tools/memory/memory.factor b/extra/tools/memory/memory.factor old mode 100644 new mode 100755 index 83da7f22a8..f61694da78 --- a/extra/tools/memory/memory.factor +++ b/extra/tools/memory/memory.factor @@ -33,10 +33,10 @@ IN: tools.memory [ [ write-cell ] each ] with-row ; : (data-room.) ( -- ) - data-room 2 dup length [ + data-room 2 [ [ first2 ] [ number>string "Generation " prepend ] bi* write-total/used/free - ] 2each + ] each-index "Decks" write-total "Cards" write-total ; diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index 07eb2950fa..083700493d 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -4,7 +4,7 @@ USING: alien alien.c-types alien.syntax kernel libc structs sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader qualified - accessors inference macros locals shuffle arrays.lib + accessors inference macros locals generalizations unix.types debugger io prettyprint ; IN: unix diff --git a/extra/windows/com/com-tests.factor b/extra/windows/com/com-tests.factor index c04fd8f544..394bec2dfb 100755 --- a/extra/windows/com/com-tests.factor +++ b/extra/windows/com/com-tests.factor @@ -1,5 +1,5 @@ USING: kernel windows.com windows.com.syntax windows.ole32 -alien alien.syntax tools.test libc alien.c-types arrays.lib +alien alien.syntax tools.test libc alien.c-types namespaces arrays continuations accessors math windows.com.wrapper windows.com.wrapper.private destructors effects ; IN: windows.com.tests diff --git a/extra/windows/com/syntax/syntax.factor b/extra/windows/com/syntax/syntax.factor index e0ea65e8be..dd7d058a77 100755 --- a/extra/windows/com/syntax/syntax.factor +++ b/extra/windows/com/syntax/syntax.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types effects kernel windows.ole32 -parser lexer splitting grouping sequences.lib sequences namespaces -assocs quotations shuffle accessors words macros alien.syntax +parser lexer splitting grouping sequences namespaces +assocs quotations generalizations accessors words macros alien.syntax fry arrays ; IN: windows.com.syntax diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 266439ad79..79a945e7de 100755 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -1,6 +1,6 @@ USING: alien alien.c-types windows.com.syntax windows.com.syntax.private windows.com continuations kernel -sequences.lib namespaces windows.ole32 libc vocabs +namespaces windows.ole32 libc vocabs assocs accessors arrays sequences quotations combinators math words compiler.units destructors fry math.parser combinators.lib ; diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor index 49a04dcb48..1c1df52da8 100755 --- a/extra/windows/user32/user32.factor +++ b/extra/windows/user32/user32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax parser namespaces kernel math -windows.types shuffle math.bitfields alias ; +windows.types generalizations math.bitfields alias ; IN: windows.user32 ! HKL for ActivateKeyboardLayout From 400cde1fe638a380966a6c6751d04a98323d5b64 Mon Sep 17 00:00:00 2001 From: "U-SLAVA-DFB8FF805\\Slava" Date: Tue, 8 Jul 2008 10:18:23 -0500 Subject: [PATCH 61/77] Fix load error --- extra/windows/com/wrapper/wrapper.factor | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/extra/windows/com/wrapper/wrapper.factor b/extra/windows/com/wrapper/wrapper.factor index 79a945e7de..40c61dfbe7 100755 --- a/extra/windows/com/wrapper/wrapper.factor +++ b/extra/windows/com/wrapper/wrapper.factor @@ -1,9 +1,8 @@ USING: alien alien.c-types windows.com.syntax windows.com.syntax.private windows.com continuations kernel -namespaces windows.ole32 libc vocabs -assocs accessors arrays sequences quotations combinators -math words compiler.units destructors fry -math.parser combinators.lib ; +namespaces windows.ole32 libc vocabs assocs accessors arrays +sequences quotations combinators math words compiler.units +destructors fry math.parser generalizations ; IN: windows.com.wrapper TUPLE: com-wrapper vtbls disposed ; From 267a24c0ded8cb87e7c0824ebbc513d358f674ee Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 12:34:52 -0500 Subject: [PATCH 62/77] Oops --- extra/shuffle/authors.txt | 2 + extra/shuffle/shuffle-docs.factor | 84 ++++++++++++++++++++++++++++++ extra/shuffle/shuffle-tests.factor | 25 +++++++++ extra/shuffle/shuffle.factor | 39 ++++++++++++++ extra/shuffle/summary.txt | 1 + extra/shuffle/tags.txt | 1 + 6 files changed, 152 insertions(+) create mode 100644 extra/shuffle/authors.txt create mode 100755 extra/shuffle/shuffle-docs.factor create mode 100755 extra/shuffle/shuffle-tests.factor create mode 100644 extra/shuffle/shuffle.factor create mode 100644 extra/shuffle/summary.txt create mode 100644 extra/shuffle/tags.txt diff --git a/extra/shuffle/authors.txt b/extra/shuffle/authors.txt new file mode 100644 index 0000000000..26093b451b --- /dev/null +++ b/extra/shuffle/authors.txt @@ -0,0 +1,2 @@ +Chris Double +Doug Coleman diff --git a/extra/shuffle/shuffle-docs.factor b/extra/shuffle/shuffle-docs.factor new file mode 100755 index 0000000000..4caace3b00 --- /dev/null +++ b/extra/shuffle/shuffle-docs.factor @@ -0,0 +1,84 @@ +! Copyright (C) 2007 Chris Double. +! See http://factorcode.org/license.txt for BSD license. +USING: help.syntax help.markup kernel sequences ; +IN: shuffle + +HELP: npick +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link dup } ", " +{ $link over } " and " { $link pick } " that can work " +"for any stack depth. The nth item down the stack will be copied and " +"placed on the top of the stack." +} +{ $examples + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } +} +{ $see-also dup over pick } ; + +HELP: ndup +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link dup } ", " +{ $link 2dup } " and " { $link 3dup } " that can work " +"for any number of items. The n topmost items on the stack will be copied and " +"placed on the top of the stack." +} +{ $examples + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } +} +{ $see-also dup 2dup 3dup } ; + +HELP: nnip +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link nip } " and " { $link 2nip } +" that can work " +"for any number of items." +} +{ $examples + { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 nnip .s" "4" } +} +{ $see-also nip 2nip } ; + +HELP: ndrop +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link drop } +" that can work " +"for any number of items." +} +{ $examples + { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 ndrop .s" "1" } +} +{ $see-also drop 2drop 3drop } ; + +HELP: nrot +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link rot } " that works for any " +"number of items on the stack. " +} +{ $examples + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } +} +{ $see-also rot -nrot } ; + +HELP: -nrot +{ $values { "n" "a number" } } +{ $description "A generalisation of " { $link -rot } " that works for any " +"number of items on the stack. " +} +{ $examples + { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } +} +{ $see-also rot nrot } ; + +ARTICLE: { "shuffle" "overview" } "Extra shuffle words" +"A number of stack shuffling words for those rare times when you " +"need to deal with tricky stack situations and can't refactor the " +"code to work around it." +{ $subsection ndup } +{ $subsection npick } +{ $subsection nrot } +{ $subsection -nrot } +{ $subsection nnip } +{ $subsection ndrop } ; + +IN: shuffle +ABOUT: { "shuffle" "overview" } \ No newline at end of file diff --git a/extra/shuffle/shuffle-tests.factor b/extra/shuffle/shuffle-tests.factor new file mode 100755 index 0000000000..9f2b8e01a9 --- /dev/null +++ b/extra/shuffle/shuffle-tests.factor @@ -0,0 +1,25 @@ +USING: arrays shuffle kernel math tools.test inference words ; + +[ 8 ] [ 5 6 7 8 3nip ] unit-test +{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test +{ 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test +{ 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test +{ 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test +{ t } [ [ 1 1 ndup ] infer >boolean ] unit-test +{ 1 1 } [ 1 1 ndup ] unit-test +{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test +{ 1 2 3 1 2 3 } [ 1 2 3 3 ndup ] unit-test +{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4 ndup ] unit-test +{ t } [ [ 1 2 2 nrot ] infer >boolean ] unit-test +{ 2 1 } [ 1 2 2 nrot ] unit-test +{ 2 3 1 } [ 1 2 3 3 nrot ] unit-test +{ 2 3 4 1 } [ 1 2 3 4 4 nrot ] unit-test +{ t } [ [ 1 2 2 -nrot ] infer >boolean ] unit-test +{ 2 1 } [ 1 2 2 -nrot ] unit-test +{ 3 1 2 } [ 1 2 3 3 -nrot ] unit-test +{ 4 1 2 3 } [ 1 2 3 4 4 -nrot ] unit-test +{ t } [ [ 1 2 3 4 3 nnip ] infer >boolean ] unit-test +{ 4 } [ 1 2 3 4 3 nnip ] unit-test +{ t } [ [ 1 2 3 4 4 ndrop ] infer >boolean ] unit-test +{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test +[ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor new file mode 100644 index 0000000000..2366d15cff --- /dev/null +++ b/extra/shuffle/shuffle.factor @@ -0,0 +1,39 @@ +! Copyright (C) 2007 Chris Double, Doug Coleman. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces math inference.transforms + combinators macros quotations math.ranges fry ; + +IN: shuffle + +MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; + +MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ; + +MACRO: nrot ( n -- ) 1- dup saver swap [ r> swap ] n*quot append ; + +MACRO: -nrot ( n -- ) 1- dup [ swap >r ] n*quot swap restorer append ; + +MACRO: ndrop ( n -- ) [ drop ] n*quot ; + +: nnip ( n -- ) swap >r ndrop r> ; inline + +MACRO: ntuck ( n -- ) 2 + '[ dup , -nrot ] ; + +: 2swap ( x y z t -- z t x y ) rot >r rot r> ; 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 + +MACRO: nrev ( n -- quot ) + [ 1+ ] map + reverse + [ [ -nrot ] curry ] map concat ; diff --git a/extra/shuffle/summary.txt b/extra/shuffle/summary.txt new file mode 100644 index 0000000000..12c22b8ae0 --- /dev/null +++ b/extra/shuffle/summary.txt @@ -0,0 +1 @@ +Additional shuffle words diff --git a/extra/shuffle/tags.txt b/extra/shuffle/tags.txt new file mode 100644 index 0000000000..f4274299b1 --- /dev/null +++ b/extra/shuffle/tags.txt @@ -0,0 +1 @@ +extensions From 475ffb17ac9ea096d96cd21dcbb72fa86fe6e2a7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 12:35:42 -0500 Subject: [PATCH 63/77] Update --- extra/shuffle/shuffle.factor | 22 +--------------------- 1 file changed, 1 insertion(+), 21 deletions(-) diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor index 2366d15cff..9a0dfe0e88 100644 --- a/extra/shuffle/shuffle.factor +++ b/extra/shuffle/shuffle.factor @@ -1,24 +1,9 @@ ! Copyright (C) 2007 Chris Double, Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel sequences namespaces math inference.transforms - combinators macros quotations math.ranges fry ; +USING: kernel generalizations ; IN: shuffle -MACRO: npick ( n -- ) 1- dup saver [ dup ] rot [ r> swap ] n*quot 3append ; - -MACRO: ndup ( n -- ) dup [ npick ] curry n*quot ; - -MACRO: nrot ( n -- ) 1- dup saver swap [ r> swap ] n*quot append ; - -MACRO: -nrot ( n -- ) 1- dup [ swap >r ] n*quot swap restorer append ; - -MACRO: ndrop ( n -- ) [ drop ] n*quot ; - -: nnip ( n -- ) swap >r ndrop r> ; inline - -MACRO: ntuck ( n -- ) 2 + '[ dup , -nrot ] ; - : 2swap ( x y z t -- z t x y ) rot >r rot r> ; inline : nipd ( a b c -- b c ) rot drop ; inline @@ -32,8 +17,3 @@ MACRO: ntuck ( n -- ) 2 + '[ dup , -nrot ] ; : 4drop ( a b c d -- ) 3drop drop ; inline : tuckd ( x y z -- z x y z ) 2 ntuck ; inline - -MACRO: nrev ( n -- quot ) - [ 1+ ] map - reverse - [ [ -nrot ] curry ] map concat ; From 838bdb9438d7d417704945f105d9c6186fd47e59 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 12:44:25 -0500 Subject: [PATCH 64/77] ugh --- extra/shuffle/shuffle-docs.factor | 84 ------------------------------ extra/shuffle/shuffle-tests.factor | 23 +------- 2 files changed, 1 insertion(+), 106 deletions(-) delete mode 100755 extra/shuffle/shuffle-docs.factor diff --git a/extra/shuffle/shuffle-docs.factor b/extra/shuffle/shuffle-docs.factor deleted file mode 100755 index 4caace3b00..0000000000 --- a/extra/shuffle/shuffle-docs.factor +++ /dev/null @@ -1,84 +0,0 @@ -! Copyright (C) 2007 Chris Double. -! See http://factorcode.org/license.txt for BSD license. -USING: help.syntax help.markup kernel sequences ; -IN: shuffle - -HELP: npick -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link dup } ", " -{ $link over } " and " { $link pick } " that can work " -"for any stack depth. The nth item down the stack will be copied and " -"placed on the top of the stack." -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" } -} -{ $see-also dup over pick } ; - -HELP: ndup -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link dup } ", " -{ $link 2dup } " and " { $link 3dup } " that can work " -"for any number of items. The n topmost items on the stack will be copied and " -"placed on the top of the stack." -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" } -} -{ $see-also dup 2dup 3dup } ; - -HELP: nnip -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link nip } " and " { $link 2nip } -" that can work " -"for any number of items." -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 nnip .s" "4" } -} -{ $see-also nip 2nip } ; - -HELP: ndrop -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link drop } -" that can work " -"for any number of items." -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 3 ndrop .s" "1" } -} -{ $see-also drop 2drop 3drop } ; - -HELP: nrot -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link rot } " that works for any " -"number of items on the stack. " -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" } -} -{ $see-also rot -nrot } ; - -HELP: -nrot -{ $values { "n" "a number" } } -{ $description "A generalisation of " { $link -rot } " that works for any " -"number of items on the stack. " -} -{ $examples - { $example "USING: prettyprint shuffle ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" } -} -{ $see-also rot nrot } ; - -ARTICLE: { "shuffle" "overview" } "Extra shuffle words" -"A number of stack shuffling words for those rare times when you " -"need to deal with tricky stack situations and can't refactor the " -"code to work around it." -{ $subsection ndup } -{ $subsection npick } -{ $subsection nrot } -{ $subsection -nrot } -{ $subsection nnip } -{ $subsection ndrop } ; - -IN: shuffle -ABOUT: { "shuffle" "overview" } \ No newline at end of file diff --git a/extra/shuffle/shuffle-tests.factor b/extra/shuffle/shuffle-tests.factor index 9f2b8e01a9..b5168b903c 100755 --- a/extra/shuffle/shuffle-tests.factor +++ b/extra/shuffle/shuffle-tests.factor @@ -1,25 +1,4 @@ -USING: arrays shuffle kernel math tools.test inference words ; +USING: shuffle tools.test ; [ 8 ] [ 5 6 7 8 3nip ] unit-test -{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test -{ 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test -{ 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test -{ 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test -{ t } [ [ 1 1 ndup ] infer >boolean ] unit-test -{ 1 1 } [ 1 1 ndup ] unit-test -{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test -{ 1 2 3 1 2 3 } [ 1 2 3 3 ndup ] unit-test -{ 1 2 3 4 1 2 3 4 } [ 1 2 3 4 4 ndup ] unit-test -{ t } [ [ 1 2 2 nrot ] infer >boolean ] unit-test -{ 2 1 } [ 1 2 2 nrot ] unit-test -{ 2 3 1 } [ 1 2 3 3 nrot ] unit-test -{ 2 3 4 1 } [ 1 2 3 4 4 nrot ] unit-test -{ t } [ [ 1 2 2 -nrot ] infer >boolean ] unit-test -{ 2 1 } [ 1 2 2 -nrot ] unit-test -{ 3 1 2 } [ 1 2 3 3 -nrot ] unit-test -{ 4 1 2 3 } [ 1 2 3 4 4 -nrot ] unit-test -{ t } [ [ 1 2 3 4 3 nnip ] infer >boolean ] unit-test -{ 4 } [ 1 2 3 4 3 nnip ] unit-test -{ t } [ [ 1 2 3 4 4 ndrop ] infer >boolean ] unit-test -{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test [ 3 1 2 3 ] [ 1 2 3 tuckd ] unit-test From 776b245c39d5166224578c2f45fbd7411c094dba Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 13:22:57 -0500 Subject: [PATCH 65/77] Cleaning up some usages of -roll --- core/alien/c-types/c-types.factor | 4 ++-- core/kernel/kernel.factor | 3 +-- extra/unix/process/process.factor | 3 ++- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 92f5211b35..d6d0afcf76 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -199,8 +199,8 @@ M: long-long-type box-return ( type -- ) zero? not ; : >c-array ( seq type word -- ) - >r >r dup length dup r> dup -roll r> - [ execute ] 2curry 2each ; inline + [ [ dup length ] dip ] dip + [ [ execute ] 2curry each-index ] 2keep drop ; inline : >c-array-quot ( type vocab -- quot ) dupd set-nth-word [ >c-array ] 2curry ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index 023ded5e9c..6b785a61ba 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -64,8 +64,7 @@ DEFER: if : 2keep ( x y quot -- x y ) 2over 2slip ; inline -: 3keep ( x y z quot -- x y z ) - >r 3dup r> -roll 3slip ; inline +: 3keep ( x y z quot -- x y z ) >r 3dup r> -roll 3slip ; inline ! Cleavers : bi ( x p q -- ) diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index 644276ef7d..7d3d757705 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -37,7 +37,8 @@ FUNCTION: int execve ( char* path, char** argv, char** envp ) ; >r [ first ] [ ] bi r> exec-with-env ; : with-fork ( child parent -- ) - fork-process dup zero? -roll swap curry if ; inline + [ [ fork-process dup zero? ] dip [ drop ] prepose ] dip + if ; inline : SIGKILL 9 ; inline : SIGTERM 15 ; inline From 1c7d18bcc95e4d0518272976d339cbc0e5b264cb Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 13:33:08 -0500 Subject: [PATCH 66/77] Get rid of a -roll usage --- extra/calendar/calendar.factor | 42 +++++++++-------------------- extra/calendar/format/format.factor | 6 ++--- 2 files changed, 16 insertions(+), 32 deletions(-) diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index 6b1f02187d..e7b0b6f43a 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -303,41 +303,25 @@ GENERIC: days-in-year ( obj -- n ) M: integer days-in-year ( year -- n ) leap-year? 366 365 ? ; M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; -GENERIC: days-in-month ( obj -- n ) +: (days-in-month) ( year month -- n ) + dup 2 = [ drop leap-year? 29 28 ? ] [ nip day-counts nth ] if ; -M: array days-in-month ( obj -- n ) - first2 dup 2 = [ - drop leap-year? 29 28 ? - ] [ - nip day-counts nth - ] if ; +: days-in-month ( timestamp -- n ) + >date< drop (days-in-month) ; -M: timestamp days-in-month ( timestamp -- n ) - >date< drop 2array days-in-month ; - -GENERIC: day-of-week ( obj -- n ) - -M: timestamp day-of-week ( timestamp -- n ) +: day-of-week ( timestamp -- n ) >date< zeller-congruence ; -M: array day-of-week ( array -- n ) - first3 zeller-congruence ; - -GENERIC: day-of-year ( obj -- n ) - -M: array day-of-year ( array -- n ) - first3 - 3dup day-counts rot head-slice sum + - swap leap-year? [ - -roll - pick 3 1 >r r> +:: (day-of-year) ( year month day -- n ) + day-counts month head-slice sum day + + year leap-year? [ + year month day + year 3 1 after=? [ 1+ ] when - ] [ - >r 3drop r> - ] if ; + ] when ; -M: timestamp day-of-year ( timestamp -- n ) - >date< 3array day-of-year ; +: day-of-year ( timestamp -- n ) + >date< (day-of-year) ; : day-offset ( timestamp m -- timestamp n ) over day-of-week - ; inline diff --git a/extra/calendar/format/format.factor b/extra/calendar/format/format.factor index 15dee79006..e2b6a280ef 100755 --- a/extra/calendar/format/format.factor +++ b/extra/calendar/format/format.factor @@ -57,9 +57,9 @@ GENERIC: month. ( obj -- ) M: array month. ( pair -- ) first2 - [ month-names nth write bl number>string print ] 2keep - [ 1 zeller-congruence ] 2keep - 2array days-in-month day-abbreviations2 " " join print + [ month-names nth write bl number>string print ] + [ 1 zeller-congruence ] + [ (days-in-month) day-abbreviations2 " " join print ] 2tri over " " concat write [ [ 1+ day. ] keep From 94a613f688605eaa9c4fa0a5bc94efc1d47279cb Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Tue, 8 Jul 2008 20:40:37 +0200 Subject: [PATCH 67/77] Small change: use a better idiom --- extra/ctags/ctags.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/ctags/ctags.factor b/extra/ctags/ctags.factor index c8bf2272fb..23d9aeb90c 100644 --- a/extra/ctags/ctags.factor +++ b/extra/ctags/ctags.factor @@ -22,7 +22,7 @@ IN: ctags { } swap [ ctag suffix ] each ; : ctags-write ( seq path -- ) - >r ctag-strings r> ascii set-file-lines ; + [ ctag-strings ] dip ascii set-file-lines ; : (ctags) ( -- seq ) { } all-words [ From a950924a18d99926d2a0a9c51bcc25d6b0356f52 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 14:20:43 -0500 Subject: [PATCH 68/77] Fixes --- extra/combinators/lib/lib-tests.factor | 2 -- extra/generalizations/generalizations-docs.factor | 10 +++++----- extra/generalizations/generalizations-tests.factor | 4 +++- 3 files changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/combinators/lib/lib-tests.factor b/extra/combinators/lib/lib-tests.factor index 89d3ed7f7d..d61674280a 100755 --- a/extra/combinators/lib/lib-tests.factor +++ b/extra/combinators/lib/lib-tests.factor @@ -5,8 +5,6 @@ IN: combinators.lib.tests [ 5 ] [ [ 10 random ] [ 5 = ] generate ] unit-test [ t ] [ [ 10 random ] [ even? ] generate even? ] unit-test -[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test - [ { "foo" "xbarx" } ] [ { "oof" "bar" } { [ reverse ] [ "x" swap "x" 3append ] } parallel-call diff --git a/extra/generalizations/generalizations-docs.factor b/extra/generalizations/generalizations-docs.factor index decabdc89d..d2af13a9c3 100755 --- a/extra/generalizations/generalizations-docs.factor +++ b/extra/generalizations/generalizations-docs.factor @@ -75,7 +75,7 @@ HELP: nrev { $description "A generalization of " { $link spin } " that reverses any number of items at the top of the stack." } { $examples - { $example "USING: prettyprint generalizations ;" "1 2 3 4 nrev .s" "4\n3\n2\n1\n" } + { $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrev .s" "4\n3\n2\n1" } } { $see-also rot nrot } ; @@ -87,8 +87,8 @@ HELP: ndip "stack. The quotation can consume and produce any number of items." } { $examples - { $example "USING: combinators.lib kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" } - { $example "USING: combinators.lib kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" } + { $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" } } { $see-also dip 2dip } ; @@ -99,7 +99,7 @@ HELP: nslip "removed from the stack, the quotation called, and the items restored." } { $examples - { $example "USING: combinators.lib prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } + { $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" } } { $see-also slip nkeep } ; @@ -110,7 +110,7 @@ HELP: nkeep "saved, the quotation called, and the items restored." } { $examples - { $example "USING: combinators.lib 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" "99\n1\n2\n3\n4\n5" } } { $see-also keep nslip } ; diff --git a/extra/generalizations/generalizations-tests.factor b/extra/generalizations/generalizations-tests.factor index 1210143094..af010e2026 100755 --- a/extra/generalizations/generalizations-tests.factor +++ b/extra/generalizations/generalizations-tests.factor @@ -1,4 +1,4 @@ -USING: tools.test generalizations kernel math arrays ; +USING: tools.test generalizations kernel math arrays sequences ; IN: generalizations.tests { 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test @@ -30,3 +30,5 @@ IN: generalizations.tests [ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test [ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test [ [ dup 2^ 2array ] 5 napply ] must-infer + +[ { "xyc" "xyd" } ] [ "x" "y" { "c" "d" } [ 3append ] 2 nwith map ] unit-test From ed788fa49ca668f39f9112527f371e4d99d29ff8 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 14:23:27 -0500 Subject: [PATCH 69/77] Fix stack effect --- core/alien/c-types/c-types.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index d6d0afcf76..602b22881f 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -198,7 +198,7 @@ M: long-long-type box-return ( type -- ) : c-bool> ( int -- ? ) zero? not ; -: >c-array ( seq type word -- ) +: >c-array ( seq type word -- byte-array ) [ [ dup length ] dip ] dip [ [ execute ] 2curry each-index ] 2keep drop ; inline From cb4ce6c4dfca9f6f6a26198a11353895f15f443b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 14:26:37 -0500 Subject: [PATCH 70/77] Fix naming --- extra/webapps/planet/admin.xml | 8 +++--- extra/webapps/planet/edit-blog.xml | 4 +-- extra/webapps/planet/new-blog.xml | 2 +- extra/webapps/planet/planet-common.xml | 6 ++-- extra/webapps/planet/planet.factor | 40 +++++++++++++------------- extra/webapps/planet/planet.xml | 2 +- 6 files changed, 31 insertions(+), 31 deletions(-) diff --git a/extra/webapps/planet/admin.xml b/extra/webapps/planet/admin.xml index 192592489e..531332eada 100644 --- a/extra/webapps/planet/admin.xml +++ b/extra/webapps/planet/admin.xml @@ -2,12 +2,12 @@ - Planet Factor Administration + Concatenative Planet: Administration
  • - +
    • @@ -15,8 +15,8 @@
- Add Blog - | Update + Add Blog + | Update
diff --git a/extra/webapps/planet/edit-blog.xml b/extra/webapps/planet/edit-blog.xml index fd9c659f59..d1c7013c68 100644 --- a/extra/webapps/planet/edit-blog.xml +++ b/extra/webapps/planet/edit-blog.xml @@ -4,7 +4,7 @@ Edit Blog - + @@ -29,6 +29,6 @@ - Delete + Delete diff --git a/extra/webapps/planet/new-blog.xml b/extra/webapps/planet/new-blog.xml index 4a9638da03..6f75addda5 100644 --- a/extra/webapps/planet/new-blog.xml +++ b/extra/webapps/planet/new-blog.xml @@ -4,7 +4,7 @@ Edit Blog - +
diff --git a/extra/webapps/planet/planet-common.xml b/extra/webapps/planet/planet-common.xml index 6c0affd17f..f4e390056a 100644 --- a/extra/webapps/planet/planet-common.xml +++ b/extra/webapps/planet/planet-common.xml @@ -5,9 +5,9 @@
- Front Page - | Atom Feed - | Admin + Front Page + | Atom Feed + | Admin diff --git a/extra/webapps/planet/planet.factor b/extra/webapps/planet/planet.factor index ca74b7e642..10e706598e 100755 --- a/extra/webapps/planet/planet.factor +++ b/extra/webapps/planet/planet.factor @@ -17,13 +17,13 @@ furnace.auth furnace.syndication ; IN: webapps.planet -TUPLE: planet-factor < dispatcher ; +TUPLE: planet < dispatcher ; -SYMBOL: can-administer-planet-factor? +SYMBOL: can-administer-planet? -can-administer-planet-factor? define-capability +can-administer-planet? define-capability -TUPLE: planet-factor-admin < dispatcher ; +TUPLE: planet-admin < dispatcher ; TUPLE: blog id name www-url feed-url ; @@ -65,7 +65,7 @@ posting "POSTINGS" : ( -- action ) [ blogroll "blogroll" set-value ] >>init - { planet-factor "admin" } >>template ; + { planet "admin" } >>template ; : ( -- action ) @@ -74,12 +74,12 @@ posting "POSTINGS" postings "postings" set-value ] >>init - { planet-factor "planet" } >>template ; + { planet "planet" } >>template ; : ( -- action ) [ "Planet Factor" ] >>title - [ URL" $planet-factor" ] >>url + [ URL" $planet" ] >>url [ postings ] >>entries ; :: ( entry name -- entry' ) @@ -111,7 +111,7 @@ posting "POSTINGS" [ update-cached-postings - URL" $planet-factor/admin" + URL" $planet/admin" ] >>submit ; : ( -- action ) @@ -120,7 +120,7 @@ posting "POSTINGS" [ "id" value delete-tuples - URL" $planet-factor/admin" + URL" $planet/admin" ] >>submit ; : validate-blog ( -- ) @@ -136,7 +136,7 @@ posting "POSTINGS" : ( -- action ) - { planet-factor "new-blog" } >>template + { planet "new-blog" } >>template [ validate-blog ] >>validate @@ -146,7 +146,7 @@ posting "POSTINGS" [ insert-tuple ] [ - "$planet-factor/admin/edit-blog" >>path + "$planet/admin/edit-blog" >>path swap id>> "id" set-query-param ] @@ -161,7 +161,7 @@ posting "POSTINGS" "id" value select-tuple from-object ] >>init - { planet-factor "edit-blog" } >>template + { planet "edit-blog" } >>template [ validate-integer-id @@ -174,15 +174,15 @@ posting "POSTINGS" [ update-tuple ] [ - "$planet-factor/admin" >>path + "$planet/admin" >>path swap id>> "id" set-query-param ] tri ] >>submit ; -: ( -- responder ) - planet-factor-admin new-dispatcher +: ( -- responder ) + planet-admin new-dispatcher "blogroll" add-main-responder "update" add-responder "new-blog" add-responder @@ -190,15 +190,15 @@ posting "POSTINGS" "delete-blog" add-responder "administer Planet Factor" >>description - { can-administer-planet-factor? } >>capabilities ; + { can-administer-planet? } >>capabilities ; -: ( -- responder ) - planet-factor new-dispatcher +: ( -- responder ) + planet new-dispatcher "list" add-main-responder "feed.xml" add-responder - "admin" add-responder + "admin" add-responder - { planet-factor "planet-common" } >>template ; + { planet "planet-common" } >>template ; : start-update-task ( db params -- ) '[ , , [ update-cached-postings ] with-db ] 10 minutes every drop ; diff --git a/extra/webapps/planet/planet.xml b/extra/webapps/planet/planet.xml index fe4d23bd3b..340e6c4bee 100644 --- a/extra/webapps/planet/planet.xml +++ b/extra/webapps/planet/planet.xml @@ -2,7 +2,7 @@ - Planet Factor + Concatenative Planet
From 3e43c69918aa1c1f6b93359a4593011532d90901 Mon Sep 17 00:00:00 2001 From: Alfredo Beaumont Date: Tue, 8 Jul 2008 21:57:37 +0200 Subject: [PATCH 71/77] Fix examples' code and make them unchecked since they have side effects --- extra/ctags/ctags-docs.factor | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/extra/ctags/ctags-docs.factor b/extra/ctags/ctags-docs.factor index 9d98cae0b3..22d811ad3f 100644 --- a/extra/ctags/ctags-docs.factor +++ b/extra/ctags/ctags-docs.factor @@ -12,9 +12,9 @@ HELP: ctags ( path -- ) { $values { "path" "a pathname string" } } { $description "Generates a index file in ctags format and stores in " { $snippet "path" } "." } { $examples - { $example + { $unchecked-example "USING: ctags ;" - "\"tags\" ctags-write" + "\"tags\" ctags" "" } } ; @@ -24,7 +24,7 @@ HELP: ctags-write ( seq path -- ) { "path" "a pathname string" } } { $description "Stores a " { $snippet "alist" } " in " { $snippet "path" } ". " { $snippet "alist" } " must be an association list with ctags format: key must be a valid word and value a sequence whose first element is a resource name and second element is a line number" } { $examples - { $example + { $unchecked-example "USING: kernel ctags ;" "{ { if { \"resource:extra/unix/unix.factor\" 91 } } } \"tags\" ctags-write" "" @@ -38,9 +38,9 @@ HELP: ctag-strings ( alist -- seq ) { "seq" sequence } } { $description "Converts an " { $snippet "alist" } " with ctag format (a word as key and a sequence whose first element is a resource name and a second element is a line number as value) in a " { $snippet "seq" } " of ctag strings." } { $examples - { $example - "USING: kernel ctags ;" - "{ { if { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings" + { $unchecked-example + "USING: kernel ctags prettyprint ;" + "{ { if { \"resource:extra/unix/unix.factor\" 91 } } } ctag-strings ." "{ \"if\\t/path/to/factor/extra/unix/unix.factor\\t91\" }" } } ; @@ -50,8 +50,8 @@ HELP: ctag ( seq -- str ) { "str" string } } { $description "Outputs a string " { $snippet "str" } " in ctag format for sequence with two elements, first one must be a valid word and second one a sequence whose first element is a resource name and second element is a line number" } { $examples - { $example - "USING: kernel ctags ;" + { $unchecked-example + "USING: kernel ctags prettyprint ;" "{ if { \"resource:extra/unix/unix.factor\" 91 } } ctag ." "\"if\\t/path/to/factor/extra/unix/unix.factor\\t91\"" } From 3929c1239228e34425301acc8be03bfd2e173f1f Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 15:22:03 -0500 Subject: [PATCH 72/77] Add failing unit test for string encoding --- extra/db/tuples/tuples-tests.factor | 31 ++++++++++++++++++++++++++--- 1 file changed, 28 insertions(+), 3 deletions(-) diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 36e84187eb..2edf7552cb 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -4,7 +4,7 @@ USING: io.files kernel tools.test db db.tuples classes db.types continuations namespaces math math.ranges prettyprint calendar sequences db.sqlite math.intervals db.postgresql accessors random math.bitfields.lib -math.ranges strings sequences.lib urls ; +math.ranges strings sequences.lib urls fry ; IN: db.tuples.tests TUPLE: person the-id the-name the-number the-real @@ -201,10 +201,10 @@ TUPLE: annotation n paste-id summary author mode contents ; ! ] with-db : test-sqlite ( quot -- ) - >r "tuples-test.db" temp-file sqlite-db r> with-db ; + [ ] swap '[ "tuples-test.db" temp-file sqlite-db , with-db ] unit-test ; : test-postgresql ( quot -- ) - >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ; + [ ] swap '[ { "localhost" "postgres" "foob" "factor-test" } postgresql-db , with-db ] unit-test ; : test-repeated-insert [ ] [ person ensure-table ] unit-test @@ -463,6 +463,31 @@ fubbclass "FUBCLASS" { } define-persistent [ t ] [ fubbclass new select-tuples [ fubbclass? ] all? ] unit-test ; [ test-db-inheritance ] test-sqlite +[ test-db-inheritance ] test-postgresql + + +TUPLE: string-encoding-test id string ; + +string-encoding-test "STRING_ENCODING_TEST" { + { "id" "ID" +db-assigned-id+ } + { "string" "STRING" TEXT } +} define-persistent + +: test-string-encoding ( -- ) + [ ] [ string-encoding-test ensure-table ] unit-test + + [ ] [ + string-encoding-test new + "\u{copyright-sign}\u{bengali-letter-cha}" >>string + [ insert-tuple ] [ id>> "id" set ] bi + ] unit-test + + [ "\u{copyright-sign}\u{bengali-letter-cha}" ] [ + string-encoding-test new "id" get >>id select-tuple string>> + ] unit-test ; + +[ test-string-encoding ] test-sqlite +[ test-string-encoding ] test-postgresql ! Don't comment these out. These words must infer \ bind-tuple must-infer From 7248af54cc88cfd7b2a35cf9a1a203fe9adf6d3d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 15:22:44 -0500 Subject: [PATCH 73/77] Update for planet rename --- extra/websites/concatenative/concatenative.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index 6d65f10783..211dcb3c11 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -48,7 +48,7 @@ TUPLE: factor-website < dispatcher ; "blogs" add-responder "todo" add-responder "pastebin" add-responder - "planet" add-responder + "planet" add-responder "wiki" add-responder "wee-url" add-responder "user-admin" add-responder From 6ad09779cc3e20a33aa2d527606d62eb2e82f410 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 15:46:52 -0500 Subject: [PATCH 74/77] Literal aliens in source files are bade bad --- extra/db/pools/pools-tests.factor | 16 +++++++++++++++- extra/io/pools/pools.factor | 2 +- extra/windows/user32/user32.factor | 8 ++++---- 3 files changed, 20 insertions(+), 6 deletions(-) diff --git a/extra/db/pools/pools-tests.factor b/extra/db/pools/pools-tests.factor index f0534a1d34..34e072c3a5 100644 --- a/extra/db/pools/pools-tests.factor +++ b/extra/db/pools/pools-tests.factor @@ -1,8 +1,22 @@ IN: db.pools.tests -USING: db.pools tools.test ; +USING: db.pools tools.test continuations io.files namespaces +accessors kernel math destructors ; \ must-infer { 2 0 } [ [ ] with-db-pool ] must-infer-as { 1 0 } [ [ ] with-pooled-db ] must-infer-as + +! Test behavior after image save/load +USE: db.sqlite + +[ "pool-test.db" temp-file delete-file ] ignore-errors + +[ ] [ "pool-test.db" sqlite-db "pool" set ] unit-test + +[ ] [ "pool" get expired>> t >>expired drop ] unit-test + +[ ] [ 1000 [ "pool" get [ ] with-pooled-db ] times ] unit-test + +[ ] [ "pool" get dispose ] unit-test diff --git a/extra/io/pools/pools.factor b/extra/io/pools/pools.factor index 0e37e41a76..aa734e6809 100644 --- a/extra/io/pools/pools.factor +++ b/extra/io/pools/pools.factor @@ -9,7 +9,7 @@ TUPLE: pool connections disposed expired ; : check-pool ( pool -- ) dup check-disposed dup expired>> expired? [ - ALIEN: 31337 >>expired + 31337 >>expired connections>> delete-all ] [ drop ] if ; diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor index 1c1df52da8..241eddf9f0 100755 --- a/extra/windows/user32/user32.factor +++ b/extra/windows/user32/user32.factor @@ -1285,10 +1285,10 @@ FUNCTION: void SetLastErrorEx ( DWORD dwErrCode, DWORD dwType ) ; ! FUNCTION: SetWindowPlacement FUNCTION: BOOL SetWindowPos ( HWND hWnd, HWND hWndInsertAfter, int X, int Y, int cx, int cy, UINT uFlags ) ; -: HWND_BOTTOM ALIEN: 1 ; -: HWND_NOTOPMOST ALIEN: -2 ; -: HWND_TOP ALIEN: 0 ; -: HWND_TOPMOST ALIEN: -1 ; +: HWND_BOTTOM ( -- alien ) 1 ; +: HWND_NOTOPMOST ( -- alien ) -2 ; +: HWND_TOP ( -- alien ) 0 ; +: HWND_TOPMOST ( -- alien ) -1 ; ! FUNCTION: SetWindowRgn ! FUNCTION: SetWindowsHookA From 3b2f4d92d2c11e409fe12bae6246a4bf67486e00 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 15:50:12 -0500 Subject: [PATCH 75/77] Check if the handle has been disposed. This can happen if we close one end of a duplex stream --- extra/io/unix/backend/backend.factor | 7 +++++-- extra/io/windows/files/files.factor | 1 + extra/io/windows/nt/backend/backend.factor | 2 +- 3 files changed, 7 insertions(+), 3 deletions(-) diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 165747084e..b984b1f156 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -125,7 +125,8 @@ M: fd refill } cond ; M: unix (wait-to-read) ( port -- ) - dup dup handle>> refill dup + dup + dup handle>> dup check-disposed refill dup [ dupd wait-for-port (wait-to-read) ] [ 2drop ] if ; ! Writers @@ -144,7 +145,9 @@ M: fd drain } cond ; M: unix (wait-to-write) ( port -- ) - dup dup handle>> drain dup [ wait-for-port ] [ 2drop ] if ; + dup + dup handle>> dup check-disposed drain + dup [ wait-for-port ] [ 2drop ] if ; M: unix io-multiplex ( ms/f -- ) mx get-global wait-for-events ; diff --git a/extra/io/windows/files/files.factor b/extra/io/windows/files/files.factor index 419509f124..e25be71872 100755 --- a/extra/io/windows/files/files.factor +++ b/extra/io/windows/files/files.factor @@ -61,6 +61,7 @@ C: FileArgs : make-FileArgs ( port -- ) { + [ handle>> check-disposed ] [ handle>> handle>> ] [ buffer>> ] [ buffer>> buffer-length ] diff --git a/extra/io/windows/nt/backend/backend.factor b/extra/io/windows/nt/backend/backend.factor index 786275c736..e9df2ddab9 100755 --- a/extra/io/windows/nt/backend/backend.factor +++ b/extra/io/windows/nt/backend/backend.factor @@ -74,7 +74,7 @@ M: winnt add-completion ( win32-handle -- ) ] if ; M: win32-handle cancel-operation - handle>> CancelIo drop ; + [ check-disposed ] [ handle>> CancelIo drop ] bi ; M: winnt io-multiplex ( ms -- ) handle-overlapped [ 0 io-multiplex ] when ; From 75338b577cb39d836b0da548f6f1d08f9f08daf9 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 15:50:38 -0500 Subject: [PATCH 76/77] Rename from-now to hence --- extra/alarms/alarms-docs.factor | 2 +- extra/alarms/alarms.factor | 4 ++-- extra/calendar/calendar.factor | 4 ++-- extra/furnace/auth/login/login.factor | 3 +-- extra/furnace/cache/cache.factor | 4 ++-- extra/furnace/sessions/sessions.factor | 1 - extra/tetris/tetris.factor | 2 +- extra/ui/gestures/gestures.factor | 2 +- 8 files changed, 10 insertions(+), 12 deletions(-) diff --git a/extra/alarms/alarms-docs.factor b/extra/alarms/alarms-docs.factor index b25df236c9..f07a8b9a2d 100755 --- a/extra/alarms/alarms-docs.factor +++ b/extra/alarms/alarms-docs.factor @@ -10,7 +10,7 @@ HELP: add-alarm HELP: later { $values { "quot" quotation } { "dt" duration } { "alarm" alarm } } -{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } { $link from-now } "." } ; +{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ; HELP: cancel-alarm { $values { "alarm" alarm } } diff --git a/extra/alarms/alarms.factor b/extra/alarms/alarms.factor index ddc1d34121..a72960f20f 100755 --- a/extra/alarms/alarms.factor +++ b/extra/alarms/alarms.factor @@ -82,10 +82,10 @@ PRIVATE> [ register-alarm ] keep ; : later ( quot dt -- alarm ) - from-now f add-alarm ; + hence f add-alarm ; : every ( quot dt -- alarm ) - [ from-now ] keep add-alarm ; + [ hence ] keep add-alarm ; : cancel-alarm ( alarm -- ) alarm-entry [ alarms get-global heap-delete ] if-box? ; diff --git a/extra/calendar/calendar.factor b/extra/calendar/calendar.factor index e7b0b6f43a..0abc00b4a4 100755 --- a/extra/calendar/calendar.factor +++ b/extra/calendar/calendar.factor @@ -284,7 +284,7 @@ MEMO: unix-1970 ( -- timestamp ) : now ( -- timestamp ) gmt >local-time ; -: from-now ( dt -- timestamp ) now swap time+ ; +: hence ( dt -- timestamp ) now swap time+ ; : ago ( dt -- timestamp ) now swap time- ; : day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline @@ -357,7 +357,7 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ; M: timestamp sleep-until timestamp>millis sleep-until ; -M: duration sleep from-now sleep-until ; +M: duration sleep hence sleep-until ; { { [ os unix? ] [ "calendar.unix" ] } diff --git a/extra/furnace/auth/login/login.factor b/extra/furnace/auth/login/login.factor index 68161382c1..ce533bce64 100755 --- a/extra/furnace/auth/login/login.factor +++ b/extra/furnace/auth/login/login.factor @@ -40,10 +40,9 @@ M: login-realm modify-form ( responder -- ) permit-id get realm get name>> permit-id-key "$login-realm" resolve-base-path >>path realm get - [ timeout>> from-now >>expires ] [ domain>> >>domain ] [ secure>> >>secure ] - tri ; + bi ; : put-permit-cookie ( response -- response' ) put-cookie ; diff --git a/extra/furnace/cache/cache.factor b/extra/furnace/cache/cache.factor index a614a52548..68786a55ab 100644 --- a/extra/furnace/cache/cache.factor +++ b/extra/furnace/cache/cache.factor @@ -31,6 +31,6 @@ TUPLE: server-state-manager < filter-responder timeout ; new swap >>responder 20 minutes >>timeout ; inline - + : touch-state ( state manager -- ) - timeout>> from-now >>expires drop ; + timeout>> hence >>expires drop ; diff --git a/extra/furnace/sessions/sessions.factor b/extra/furnace/sessions/sessions.factor index 0ec9648a67..5590a9e55e 100755 --- a/extra/furnace/sessions/sessions.factor +++ b/extra/furnace/sessions/sessions.factor @@ -116,7 +116,6 @@ M: session-saver dispose : ( -- cookie ) session get id>> session-id-key "$sessions" resolve-base-path >>path - sessions get timeout>> from-now >>expires sessions get domain>> >>domain ; : put-session-cookie ( response -- response' ) diff --git a/extra/tetris/tetris.factor b/extra/tetris/tetris.factor index 02f8f240d2..c2f874598c 100644 --- a/extra/tetris/tetris.factor +++ b/extra/tetris/tetris.factor @@ -45,7 +45,7 @@ tetris-gadget H{ dup tetris-gadget-tetris maybe-update relayout-1 ; M: tetris-gadget graft* ( gadget -- ) - dup [ tick ] curry 100 milliseconds from-now 100 milliseconds add-alarm + dup [ tick ] curry 100 milliseconds every swap set-tetris-gadget-alarm ; M: tetris-gadget ungraft* ( gadget -- ) diff --git a/extra/ui/gestures/gestures.factor b/extra/ui/gestures/gestures.factor index 88bc2bcee7..5c00fbfdb0 100755 --- a/extra/ui/gestures/gestures.factor +++ b/extra/ui/gestures/gestures.factor @@ -121,7 +121,7 @@ SYMBOL: drag-timer : start-drag-timer ( -- ) hand-buttons get-global empty? [ [ drag-gesture ] - 300 milliseconds from-now + 300 milliseconds hence 100 milliseconds add-alarm drag-timer get-global >box ] when ; From 7c76046d3b65654306c08a7d0d539ea3e04d5bfd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 8 Jul 2008 16:15:51 -0500 Subject: [PATCH 77/77] Minor Wiki improvements --- extra/webapps/planet/mini-planet.xml | 14 ----- extra/webapps/wiki/initial-content/Farkup.txt | 63 +++++++++++++++++++ .../wiki/initial-content/Front Page.txt | 5 ++ extra/webapps/wiki/wiki-common.xml | 11 ++++ extra/webapps/wiki/wiki.factor | 29 +++++++-- .../concatenative/concatenative.factor | 2 +- 6 files changed, 105 insertions(+), 19 deletions(-) delete mode 100644 extra/webapps/planet/mini-planet.xml create mode 100644 extra/webapps/wiki/initial-content/Farkup.txt create mode 100644 extra/webapps/wiki/initial-content/Front Page.txt diff --git a/extra/webapps/planet/mini-planet.xml b/extra/webapps/planet/mini-planet.xml deleted file mode 100644 index 661c2dc0f7..0000000000 --- a/extra/webapps/planet/mini-planet.xml +++ /dev/null @@ -1,14 +0,0 @@ - - - - - - -

-
- Read More... -

- - - - diff --git a/extra/webapps/wiki/initial-content/Farkup.txt b/extra/webapps/wiki/initial-content/Farkup.txt new file mode 100644 index 0000000000..8814af6c0a --- /dev/null +++ b/extra/webapps/wiki/initial-content/Farkup.txt @@ -0,0 +1,63 @@ +Look at the source to this page by clicking *Edit* to compare the farkup language with resulting output. + += level 1 heading = + +== level 2 heading == + +=== level 3 heading === + +==== level 4 heading ==== + +Here is a paragraph of text, with _emphasized_ and *strong* text, together with an inline %code snippet%. Did you know that E=mc^2^, and L~2~ spaces are cool? Of course, if you want to include \_ special \* characters \^ you \~ can \% do that, too. + +You can make [[Wiki Links]] just like that, as well as links to external sites: [[http://sbcl.sourceforge.net]]. [[Factor|Custom link text]] can be used [[http://www.apple.com|with both types of links]]. + +Images can be embedded in the text: + +[[image:http://factorcode.org/graphics/logo.png]] + +- a list +- with three +- items + +|a table|with|four|columns| +|and|two|rows|...| + +Here is some code: + +[{HAI +CAN HAS STDIO? +VISIBLE "HAI WORLD!" +KTHXBYE}] + +There is syntax highlighting various languages, too: + +[factor{PEG: parse-request-line ( string -- triple ) + #! Triple is { method url version } + [ + 'space' , + 'http-method' , + 'space' , + 'url' , + 'space' , + 'http-version' , + 'space' , + ] seq* just ;}] + +Some Java: + +[java{/** + * Returns the extension of the specified filename, or an empty + * string if there is none. + * @param path The path + */ +public static String getFileExtension(String path) +{ + int fsIndex = getLastSeparatorIndex(path); + int index = path.lastIndexOf('.'); + // there could be a dot in the path and no file extension + if(index == -1 || index < fsIndex ) + return ""; + else + return path.substring(index); +}}] diff --git a/extra/webapps/wiki/initial-content/Front Page.txt b/extra/webapps/wiki/initial-content/Front Page.txt new file mode 100644 index 0000000000..37351eed38 --- /dev/null +++ b/extra/webapps/wiki/initial-content/Front Page.txt @@ -0,0 +1,5 @@ +Congratulations, you are now running your very own Wiki. + +You can now click *Edit* below and begin editing the content of the [[Front Page]]. This Wiki uses [[Farkup]] to mark up text. + +Two special article names are recognized by the Wiki: [[Sidebar]] and [[Footer]]. They do not exist by default, but if you create them, they will be visible on every page. diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml index 0abd36a7cd..5cddcee628 100644 --- a/extra/webapps/wiki/wiki-common.xml +++ b/extra/webapps/wiki/wiki-common.xml @@ -13,6 +13,7 @@ Front Page | All Articles | Recent Changes + | Random Article @@ -45,6 +46,16 @@ + + + +
+ + + + + +
diff --git a/extra/webapps/wiki/wiki.factor b/extra/webapps/wiki/wiki.factor index 77ee242668..3c87f3cd49 100644 --- a/extra/webapps/wiki/wiki.factor +++ b/extra/webapps/wiki/wiki.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors kernel hashtables calendar +USING: accessors kernel hashtables calendar random assocs namespaces splitting sequences sorting math.order present +io.files io.encodings.ascii syndication html.components html.forms http.server @@ -115,6 +116,14 @@ M: revision feed-entry-url id>> revision-url ; { wiki "view" } >>template ; +: ( -- action ) + + [ + article new select-tuples random + [ title>> ] [ "Front Page" ] if* + view-url + ] >>display ; + : amend-article ( revision article -- ) swap id>> >>revision update-tuple ; @@ -286,15 +295,15 @@ M: revision feed-entry-url id>> revision-url ; { wiki "page-common" } >>template ; : init-sidebar ( -- ) - "Sidebar" latest-revision [ - "sidebar" [ from-object ] nest-form - ] when* ; + "Sidebar" latest-revision [ "sidebar" [ from-object ] nest-form ] when* + "Footer" latest-revision [ "footer" [ from-object ] nest-form ] when* ; : ( -- dispatcher ) wiki new-dispatcher "" add-responder "view" add-responder "revision" add-responder + "random" add-responder "revisions" add-responder "revisions.atom" add-responder "diff" add-responder @@ -309,3 +318,15 @@ M: revision feed-entry-url id>> revision-url ; [ init-sidebar ] >>init { wiki "wiki-common" } >>template ; + +: init-wiki ( -- ) + "resource:extra/webapps/wiki/initial-content" directory* keys + [ + [ ascii file-contents ] [ file-name "." split1 drop ] bi + f + swap >>title + swap >>content + "slava" >>author + now >>date + add-revision + ] each ; diff --git a/extra/websites/concatenative/concatenative.factor b/extra/websites/concatenative/concatenative.factor index 211dcb3c11..1ae7f63a27 100644 --- a/extra/websites/concatenative/concatenative.factor +++ b/extra/websites/concatenative/concatenative.factor @@ -25,7 +25,7 @@ webapps.wee-url webapps.user-admin ; IN: websites.concatenative -: test-db ( -- db params ) "resource:test.db" sqlite-db ; +: test-db ( -- params db ) "resource:test.db" sqlite-db ; : init-factor-db ( -- ) test-db [