From da3677dafb208a3267ae4b654f621fbb678662c2 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 30 Aug 2008 18:54:04 -0700
Subject: [PATCH 01/46] Change -in-place words in math.blas to use the "!"
convention for destructive words. Update the math.blas documentation to match
the expectations of help.lint
---
basis/cocoa/views/views.factor | 23 ++++-
extra/math/blas/matrices/matrices-docs.factor | 93 ++++++++++---------
extra/math/blas/matrices/matrices.factor | 72 +++++++-------
extra/math/blas/vectors/vectors-docs.factor | 52 +++++------
extra/math/blas/vectors/vectors.factor | 30 +++---
5 files changed, 147 insertions(+), 123 deletions(-)
diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor
index ca631d5dea..8bfbe330b2 100644
--- a/basis/cocoa/views/views.factor
+++ b/basis/cocoa/views/views.factor
@@ -21,6 +21,10 @@ IN: cocoa.views
: NSOpenGLPFASampleBuffers 55 ;
: NSOpenGLPFASamples 56 ;
: NSOpenGLPFAAuxDepthStencil 57 ;
+: NSOpenGLPFAColorFloat 58 ;
+: NSOpenGLPFAMultisample 59 ;
+: NSOpenGLPFASupersample 60 ;
+: NSOpenGLPFASampleAlpha 61 ;
: NSOpenGLPFARendererID 70 ;
: NSOpenGLPFASingleRenderer 71 ;
: NSOpenGLPFANoRecovery 72 ;
@@ -34,25 +38,36 @@ IN: cocoa.views
: NSOpenGLPFACompliant 83 ;
: NSOpenGLPFAScreenMask 84 ;
: NSOpenGLPFAPixelBuffer 90 ;
+: NSOpenGLPFAAllowOfflineRenderers 96 ;
: NSOpenGLPFAVirtualScreenCount 128 ;
+: kCGLRendererGenericFloatID HEX: 00020400 ;
+
<PRIVATE
SYMBOL: +software-renderer+
+SYMBOL: +multisample+
PRIVATE>
: with-software-renderer ( quot -- )
- t +software-renderer+ set
- [ f +software-renderer+ set ]
- [ ] cleanup ; inline
+ t +software-renderer+ pick with-variable ; inline
+: with-multisample ( quot -- )
+ t +multisample+ pick with-variable ; inline
: <PixelFormat> ( -- pixelfmt )
NSOpenGLPixelFormat -> alloc [
NSOpenGLPFAWindow ,
NSOpenGLPFADoubleBuffer ,
NSOpenGLPFADepthSize , 16 ,
- +software-renderer+ get [ NSOpenGLPFARobust , ] when
+ +software-renderer+ get [
+ NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
+ ] when
+ +multisample+ get [
+ NSOpenGLPFASupersample ,
+ NSOpenGLPFASampleBuffers , 1 ,
+ NSOpenGLPFASamples , 8 ,
+ ] when
0 ,
] { } make >c-int-array
-> initWithAttributes:
diff --git a/extra/math/blas/matrices/matrices-docs.factor b/extra/math/blas/matrices/matrices-docs.factor
index ddd72a4a39..dc6a86017a 100644
--- a/extra/math/blas/matrices/matrices-docs.factor
+++ b/extra/math/blas/matrices/matrices-docs.factor
@@ -1,4 +1,4 @@
-USING: alien byte-arrays help.markup help.syntax math.blas.vectors sequences ;
+USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequences strings ;
IN: math.blas.matrices
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
@@ -52,13 +52,13 @@ ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
{ $subsection Mcols }
{ $subsection Msub }
"Matrix-vector products:"
-{ $subsection n*M.V+n*V-in-place }
+{ $subsection n*M.V+n*V! }
{ $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+M }
{ $subsection n*V(*)Vconj+M }
{ $subsection n*V(*)V }
@@ -66,12 +66,12 @@ ARTICLE: "math.blas.matrices" "BLAS interface matrix operations"
{ $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+n*M }
{ $subsection n*M.M }
{ $subsection M. }
"Scalar-matrix products:"
-{ $subsection n*M-in-place }
+{ $subsection n*M! }
{ $subsection n*M }
{ $subsection M*n }
{ $subsection M/n } ;
@@ -111,134 +111,135 @@ HELP: double-complex-blas-matrix
} related-words
HELP: Mwidth
-{ $values { "matrix" "a BLAS matrix inherited from " { $link blas-matrix-base } } { "width" "The number of columns" } }
+{ $values { "matrix" blas-matrix-base } { "width" integer } }
{ $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" } }
+{ $values { "matrix" blas-matrix-base } { "height" integer } }
{ $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 } } }
+HELP: n*M.V+n*V!
+{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "y=alpha*A.x+b*y" 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 "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 } } }
+HELP: n*V(*)V+M!
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)y+A" 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 "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 } } }
+HELP: n*V(*)Vconj+M!
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "A=alpha*x(*)yconj+A" 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 "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 } } }
-{ $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.M+n*M!
+{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "C=alpha*A.B+beta*C" 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." }
+{ $side-effects "C" } ;
HELP: <empty-matrix>
-{ $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 } } }
+{ $values { "rows" integer } { "cols" integer } { "exemplar" blas-vector-base blas-matrix-base } { "matrix" blas-matrix-base } }
{ $description "Create a matrix of all zeros with the given dimensions and the same element type as " { $snippet "exemplar" } "." } ;
{ <zero-vector> <empty-vector> <empty-matrix> } 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 } } }
+{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "beta" number } { "y" blas-vector-base } { "alpha*A.x+b*y" 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 } } }
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)y+A" 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 } } }
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "A" blas-matrix-base } { "alpha*x(*)yconj+A" 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 } } }
+{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "beta" number } { "C" blas-matrix-base } { "alpha*A.B+beta*C" 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 } } }
+{ $values { "alpha" number } { "A" blas-matrix-base } { "x" blas-vector-base } { "alpha*A.x" 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 } } }
+{ $values { "A" blas-matrix-base } { "x" blas-vector-base } { "A.x" 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
+{ n*M.V+n*V! 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 } } }
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)y" blas-matrix-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 } } }
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x(*)yconj" blas-matrix-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 } } }
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)y" blas-matrix-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 } } }
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x(*)yconj" blas-matrix-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
+{ n*V(*)V+M! n*V(*)Vconj+M! 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 } } }
+{ $values { "alpha" number } { "A" blas-matrix-base } { "B" blas-matrix-base } { "alpha*A.B" 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 } } }
+{ $values { "A" blas-matrix-base } { "B" blas-matrix-base } { "A.B" 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
+{ n*M.M+n*M! 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" } }
+{ $values { "matrix" blas-matrix-base } { "row" integer } { "col" integer } { "height" integer } { "width" integer } { "sub" blas-matrix-base } }
{ $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 } } }
+{ $values { "A" blas-matrix-base } { "rows" sequence } }
{ $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 } } }
+{ $values { "A" blas-matrix-base } { "cols" sequence } }
{ $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 } } }
+HELP: n*M!
+{ $values { "n" number } { "A" blas-matrix-base } { "A=n*A" blas-matrix-base } }
{ $description "Calculate the scalar-matrix product " { $snippet "nA" } " and overwrite the current contents of A with the result." }
{ $side-effects "A" } ;
HELP: n*M
-{ $values { "n" "a number" } { "A" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
+{ $values { "n" number } { "A" blas-matrix-base } { "n*A" 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" } }
+{ $values { "A" blas-matrix-base } { "n" number } { "A*n" 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" } }
+{ $values { "A" blas-matrix-base } { "n" number } { "A/n" blas-matrix-base } }
{ $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
+{ n*M! n*M M*n M/n } related-words
HELP: Mtranspose
-{ $values { "matrix" "A BLAS matrix inheriting from " { $link blas-matrix-base } } }
+{ $values { "matrix" blas-matrix-base } { "matrix^T" 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 } } }
+{ $values { "v" blas-vector-base blas-matrix-base } { "type" string } }
{ $description "Return the C type of the elements in the given BLAS vector or matrix." } ;
HELP: <empty-vector>
-{ $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" } "." } ;
+{ $values { "length" "The length of the new vector" } { "exemplar" blas-vector-base blas-matrix-base } { "vector" blas-vector-base } }
+{ $description "Return a vector of zeros with the given " { $snippet "length" } " and the same element type as " { $snippet "v" } "." } ;
diff --git a/extra/math/blas/matrices/matrices.factor b/extra/math/blas/matrices/matrices.factor
index c07dfca76d..41084c80d3 100755
--- a/extra/math/blas/matrices/matrices.factor
+++ b/extra/math/blas/matrices/matrices.factor
@@ -153,41 +153,45 @@ PRIVATE>
[ (flatten-complex-sequence) >c-double-array ] (>matrix)
<double-complex-blas-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 )
+GENERIC: n*M.V+n*V! ( alpha A x beta y -- y=alpha*A.x+b*y )
+GENERIC: n*V(*)V+M! ( alpha x y A -- A=alpha*x(*)y+A )
+GENERIC: n*V(*)Vconj+M! ( alpha x y A -- A=alpha*x(*)yconj+A )
+GENERIC: n*M.M+n*M! ( 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 }
+METHOD: n*M.V+n*V! { 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 }
+METHOD: n*M.V+n*V! { 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 }
+METHOD: n*M.V+n*V! { 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 }
+METHOD: n*M.V+n*V! { 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 }
+METHOD: n*V(*)V+M! { 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 }
+METHOD: n*V(*)V+M! { 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 }
+METHOD: n*V(*)V+M! { 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 }
+METHOD: n*V(*)V+M! { 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 }
+METHOD: n*V(*)Vconj+M! { real float-blas-vector float-blas-vector float-blas-matrix }
+ [ ] (prepare-ger) [ cblas_sger ] dip ;
+METHOD: n*V(*)Vconj+M! { real double-blas-vector double-blas-vector double-blas-matrix }
+ [ ] (prepare-ger) [ cblas_dger ] dip ;
+METHOD: n*V(*)Vconj+M! { 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 }
+METHOD: n*V(*)Vconj+M! { 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 }
+METHOD: n*M.M+n*M! { 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 }
+METHOD: n*M.M+n*M! { 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 }
+METHOD: n*M.M+n*M! { 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 }
+METHOD: n*M.M+n*M! { 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
@@ -206,36 +210,36 @@ syntax:M: blas-matrix-base clone
[ 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 ;
+ clone n*M.V+n*V! ;
: n*V(*)V+M ( alpha x y A -- alpha*x(*)y+A )
- clone n*V(*)V+M-in-place ;
+ clone n*V(*)V+M! ;
: n*V(*)Vconj+M ( alpha x y A -- alpha*x(*)yconj+A )
- clone n*V(*)Vconj+M-in-place ;
+ clone n*V(*)Vconj+M! ;
: n*M.M+n*M ( alpha A B beta C -- alpha*A.B+beta*C )
- clone n*M.M+n*M-in-place ;
+ clone n*M.M+n*M! ;
: n*M.V ( alpha A x -- alpha*A.x )
1.0 2over [ Mheight ] dip <empty-vector>
- n*M.V+n*V-in-place ; inline
+ n*M.V+n*V! ; inline
: M.V ( A x -- A.x )
1.0 -rot n*M.V ; inline
-: n*V(*)V ( n x y -- n*x(*)y )
+: n*V(*)V ( alpha x y -- alpha*x(*)y )
2dup [ length>> ] bi@ pick <empty-matrix>
- n*V(*)V+M-in-place ;
-: n*V(*)Vconj ( n x y -- n*x(*)yconj )
+ n*V(*)V+M! ;
+: n*V(*)Vconj ( alpha x y -- alpha*x(*)yconj )
2dup [ length>> ] bi@ pick <empty-matrix>
- n*V(*)Vconj+M-in-place ;
+ n*V(*)Vconj+M! ;
: 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 )
+: n*M.M ( alpha A B -- alpha*A.B )
2dup [ Mheight ] [ Mwidth ] bi* pick <empty-matrix>
- 1.0 swap n*M.M+n*M-in-place ;
+ 1.0 swap n*M.M+n*M! ;
: M. ( A B -- A.B )
1.0 -rot n*M.M ; inline
@@ -247,7 +251,7 @@ syntax:M: blas-matrix-base clone
height
width ;
-: Msub ( matrix row col height width -- submatrix )
+: Msub ( matrix row col height width -- sub )
5 npick dup transpose>>
[ nip [ [ swap ] 2dip swap ] when (Msub) ] 2keep
swap (blas-matrix-like) ;
@@ -281,14 +285,14 @@ syntax:M: blas-matrix-rowcol-sequence nth-unsafe
: Mrows ( A -- rows )
dup transpose>> [ (Mcols) ] [ (Mrows) ] if ;
-: Mcols ( A -- rows )
+: Mcols ( A -- cols )
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 -- A=n*A )
+ [ (Mcols) [ n*V! drop ] with each ] keep ;
: n*M ( n A -- n*A )
- clone n*M-in-place ; inline
+ clone n*M! ; inline
: M*n ( A n -- A*n )
swap n*M ; inline
diff --git a/extra/math/blas/vectors/vectors-docs.factor b/extra/math/blas/vectors/vectors-docs.factor
index 4fad9c7378..0595f00989 100644
--- a/extra/math/blas/vectors/vectors-docs.factor
+++ b/extra/math/blas/vectors/vectors-docs.factor
@@ -1,4 +1,4 @@
-USING: alien byte-arrays help.markup help.syntax sequences ;
+USING: alien byte-arrays help.markup help.syntax math sequences ;
IN: math.blas.vectors
ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
@@ -11,13 +11,13 @@ ARTICLE: "math.blas.vectors" "BLAS interface vector operations"
{ $subsection Viamax }
{ $subsection Vamax }
"Scalar-vector products:"
-{ $subsection n*V-in-place }
+{ $subsection n*V! }
{ $subsection n*V }
{ $subsection V*n }
{ $subsection V/n }
{ $subsection Vneg }
"Vector addition:"
-{ $subsection n*V+V-in-place }
+{ $subsection n*V+V! }
{ $subsection n*V+V }
{ $subsection V+ }
{ $subsection V- }
@@ -51,81 +51,81 @@ HELP: float-complex-blas-vector
HELP: double-complex-blas-vector
{ $class-description "A vector of single-precision floating-point complex values. Complex values are stored in memory as two consecutive float values, real part then imaginary part. For details on the tuple layout, see " { $link blas-vector-base } "." } ;
-HELP: 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 } } }
+HELP: n*V+V!
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "y=alpha*x+y" 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 "y" } ;
-HELP: n*V-in-place
-{ $values { "alpha" "a number" } { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+HELP: n*V!
+{ $values { "alpha" number } { "x" blas-vector-base } { "x=alpha*x" 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 "x" } ;
HELP: V.
-{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "y" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x.y" number } }
{ $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 } } }
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "xconj.y" number } }
{ $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 } } }
+{ $values { "x" blas-vector-base } { "norm" number } }
{ $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 } } }
+{ $values { "x" blas-vector-base } { "sum" number } }
{ $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 } } }
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x=y" blas-vector-base } { "y=x" blas-vector-base } }
{ $description "Swap the contents of " { $snippet "x" } " and " { $snippet "y" } " in place. Corresponds to the xSWAP routines in BLAS." }
{ $side-effects "x" "y" } ;
HELP: Viamax
-{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $values { "x" blas-vector-base } { "max-i" integer } }
{ $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 } } }
+{ $values { "x" blas-vector-base } { "max" number } }
{ $description "Return the value of the element in " { $snippet "x" } " with the largest norm-1. If more than one element has the same norm-1, returns the first element. Corresponds to the IxAMAX routines in BLAS." } ;
{ Viamax Vamax } related-words
HELP: <zero-vector>
-{ $values { "exemplar" "a BLAS vector inheriting from " { $link blas-vector-base } } }
+{ $values { "exemplar" blas-vector-base } { "zero" 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 <empty-vector> } "." } ;
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 } } }
+{ $values { "alpha" number } { "x" blas-vector-base } { "y" blas-vector-base } { "alpha*x+y" 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 } } }
+{ $values { "alpha" "a number" } { "x" blas-vector-base } { "alpha*x" 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 } } }
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x+y" 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 } } }
+{ $values { "x" blas-vector-base } { "y" blas-vector-base } { "x-y" 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." } ;
+{ $values { "x" blas-vector-base } { "-x" blas-vector-base } }
+{ $description "Negate the elements of " { $snippet "x" } " and return a freshly-allocated vector with the same length as " { $snippet "x" } " containing the result." } ;
HELP: V*n
-{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "alpha" "a number" } }
+{ $values { "x" blas-vector-base } { "alpha" number } { "x*alpha" 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/n
-{ $values { "x" "a BLAS vector inheriting from " { $link blas-vector-base } } { "alpha" "a number" } }
+{ $values { "x" blas-vector-base } { "alpha" number } { "x/alpha" blas-vector-base } }
{ $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
+{ n*V+V! n*V! 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." } ;
+{ $values { "v" blas-vector-base } { "start" integer } { "length" integer } { "sub" blas-vector-base } }
+{ $description "Slice a subvector out of " { $snippet "v" } " starting at " { $snippet "start" } " with the given " { $snippet "length" } ". The subvector will share storage with the parent vector." } ;
diff --git a/extra/math/blas/vectors/vectors.factor b/extra/math/blas/vectors/vectors.factor
index 18370f12c0..87bc6437c3 100755
--- a/extra/math/blas/vectors/vectors.factor
+++ b/extra/math/blas/vectors/vectors.factor
@@ -21,8 +21,8 @@ C: <double-blas-vector> double-blas-vector
C: <float-complex-blas-vector> float-complex-blas-vector
C: <double-complex-blas-vector> double-complex-blas-vector
-GENERIC: n*V+V-in-place ( alpha x y -- y=alpha*x+y )
-GENERIC: n*V-in-place ( alpha x -- x=alpha*x )
+GENERIC: n*V+V! ( alpha x y -- y=alpha*x+y )
+GENERIC: n*V! ( alpha x -- x=alpha*x )
GENERIC: V. ( x y -- x.y )
GENERIC: V.conj ( x y -- xconj.y )
@@ -202,30 +202,30 @@ METHOD: Vswap { float-complex-blas-vector float-complex-blas-vector }
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 }
+METHOD: n*V+V! { 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 }
+METHOD: n*V+V! { 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 }
+METHOD: n*V+V! { 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 }
+METHOD: n*V+V! { 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 }
+METHOD: n*V! { real float-blas-vector }
(prepare-scal) [ cblas_sscal ] dip ;
-METHOD: n*V-in-place { real double-blas-vector }
+METHOD: n*V! { real double-blas-vector }
(prepare-scal) [ cblas_dscal ] dip ;
-METHOD: n*V-in-place { number float-complex-blas-vector }
+METHOD: n*V! { number float-complex-blas-vector }
[ (>c-complex) ] dip
(prepare-scal) [ cblas_cscal ] dip ;
-METHOD: n*V-in-place { number double-complex-blas-vector }
+METHOD: n*V! { number double-complex-blas-vector }
[ (>z-complex) ] dip
(prepare-scal) [ cblas_zscal ] dip ;
-: 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
+: n*V+V ( alpha x y -- alpha*x+y ) clone n*V+V! ; inline
+: n*V ( alpha x -- alpha*x ) clone n*V! ; inline
: V+ ( x y -- x+y )
1.0 -rot n*V+V ; inline
@@ -251,6 +251,10 @@ METHOD: V. { double-complex-blas-vector double-complex-blas-vector }
(prepare-dot)
"CBLAS_Z" <c-object> [ cblas_zdotu_sub ] keep (z-complex>) ;
+METHOD: V.conj { float-blas-vector float-blas-vector }
+ (prepare-dot) cblas_sdot ;
+METHOD: V.conj { double-blas-vector double-blas-vector }
+ (prepare-dot) cblas_ddot ;
METHOD: V.conj { float-complex-blas-vector float-complex-blas-vector }
(prepare-dot)
"CBLAS_C" <c-object> [ cblas_cdotc_sub ] keep (c-complex>) ;
@@ -288,7 +292,7 @@ METHOD: Viamax { double-complex-blas-vector }
: Vamax ( x -- max )
[ Viamax ] keep nth ; inline
-: Vsub ( v start length -- vsub )
+: Vsub ( v start length -- sub )
rot [
[
nip [ inc>> ] [ element-type heap-size ] [ data>> ] tri
From 01e1092c8dfb736e4545a0c6b20ad49fb159c529 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 02:12:12 -0500
Subject: [PATCH 02/46] Fix PowerPC backend
---
basis/cpu/ppc/allot/allot.factor | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/basis/cpu/ppc/allot/allot.factor b/basis/cpu/ppc/allot/allot.factor
index 49c77c65ed..5868316577 100755
--- a/basis/cpu/ppc/allot/allot.factor
+++ b/basis/cpu/ppc/allot/allot.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel cpu.ppc.architecture cpu.ppc.assembler
kernel.private namespaces math sequences generic arrays
-generator generator.registers generator.fixup system layouts
+compiler.generator compiler.generator.registers
+compiler.generator.fixup system layouts
cpu.architecture alien ;
IN: cpu.ppc.allot
From cbc5bc1412e8b67d3f5e1e5d156a854f964a2dbf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 02:28:58 -0500
Subject: [PATCH 03/46] Fix multiline
---
basis/multiline/multiline.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/multiline/multiline.factor b/basis/multiline/multiline.factor
index 1cc418a1f6..67bcc55a06 100755
--- a/basis/multiline/multiline.factor
+++ b/basis/multiline/multiline.factor
@@ -5,7 +5,7 @@ accessors ;
IN: multiline
: next-line-text ( -- str )
- lexer get dup next-line text>> ;
+ lexer get dup next-line line-text>> ;
: (parse-here) ( -- )
next-line-text [
@@ -23,7 +23,7 @@ IN: multiline
parse-here 1quotation define-inline ; parsing
: (parse-multiline-string) ( start-index end-text -- end-index )
- lexer get text>> [
+ lexer get line-text>> [
2dup start
[ rot dupd >r >r swap subseq % r> r> length + ] [
rot tail % "\n" % 0
From e9d298b3edeec03046585a2df281d8a009876e5a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:51:01 -0500
Subject: [PATCH 04/46] new accessors
---
basis/documents/documents.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor
index 2eb2cc2762..cac7574e35 100755
--- a/basis/documents/documents.factor
+++ b/basis/documents/documents.factor
@@ -28,10 +28,10 @@ TUPLE: document < model locs ;
: update-locs ( loc document -- )
locs>> [ set-model ] with each ;
-: doc-line ( n document -- string ) model-value nth ;
+: doc-line ( n document -- string ) value>> nth ;
: doc-lines ( from to document -- slice )
- >r 1+ r> model-value <slice> ;
+ >r 1+ r> value>> <slice> ;
: start-on-line ( document from line# -- n1 )
>r dup first r> = [ nip second ] [ 2drop 0 ] if ;
@@ -99,7 +99,7 @@ TUPLE: document < model locs ;
>r >r >r "" r> r> r> set-doc-range ;
: last-line# ( document -- line )
- model-value length 1- ;
+ value>> length 1- ;
: validate-line ( line document -- line )
last-line# min 0 max ;
@@ -117,7 +117,7 @@ TUPLE: document < model locs ;
[ last-line# ] keep line-end ;
: validate-loc ( loc document -- newloc )
- over first over model-value length >= [
+ over first over value>> length >= [
nip doc-end
] [
over first 0 < [
@@ -128,7 +128,7 @@ TUPLE: document < model locs ;
] if ;
: doc-string ( document -- str )
- model-value "\n" join ;
+ value>> "\n" join ;
: set-doc-string ( string document -- )
>r string-lines V{ } like r> [ set-model ] keep
From c87d6be1a522640e40fd070ca65b468cd3e65a56 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:51:09 -0500
Subject: [PATCH 05/46] new accessors
---
basis/models/delay/delay.factor | 4 ++--
basis/models/history/history.factor | 10 +++++-----
2 files changed, 7 insertions(+), 7 deletions(-)
diff --git a/basis/models/delay/delay.factor b/basis/models/delay/delay.factor
index 22512942e3..a1d4ee9907 100755
--- a/basis/models/delay/delay.factor
+++ b/basis/models/delay/delay.factor
@@ -6,7 +6,7 @@ IN: models.delay
TUPLE: delay < model model timeout alarm ;
: update-delay-model ( delay -- )
- [ delay-model model-value ] keep set-model ;
+ [ model>> value>> ] keep set-model ;
: <delay> ( model timeout -- delay )
f delay new-model
@@ -15,7 +15,7 @@ TUPLE: delay < model model timeout alarm ;
[ add-dependency ] keep ;
: cancel-delay ( delay -- )
- delay-alarm [ cancel-alarm ] when* ;
+ alarm>> [ cancel-alarm ] when* ;
: start-delay ( delay -- )
dup
diff --git a/basis/models/history/history.factor b/basis/models/history/history.factor
index ab79d66eb6..fc90ada35a 100755
--- a/basis/models/history/history.factor
+++ b/basis/models/history/history.factor
@@ -14,7 +14,7 @@ TUPLE: history < model back forward ;
reset-history ;
: (add-history) ( history to -- )
- swap model-value dup [ swap push ] [ 2drop ] if ;
+ swap value>> dup [ swap push ] [ 2drop ] if ;
: go-back/forward ( history to from -- )
dup empty?
@@ -22,11 +22,11 @@ TUPLE: history < model back forward ;
[ >r dupd (add-history) r> pop swap set-model ] if ;
: go-back ( history -- )
- dup history-forward over history-back go-back/forward ;
+ dup [ forward>> ] [ back>> ] bi go-back/forward ;
: go-forward ( history -- )
- dup history-back over history-forward go-back/forward ;
+ dup [ back>> ] [ forward>> ] bi go-back/forward ;
: add-history ( history -- )
- dup history-forward delete-all
- dup history-back (add-history) ;
+ dup forward>> delete-all
+ dup back>> (add-history) ;
From b7fd4bb76593d109e56feed4602cd47b55a0d951 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:51:16 -0500
Subject: [PATCH 06/46] new accessors
---
basis/tools/walker/debug/debug.factor | 2 +-
basis/tools/walker/walker.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/tools/walker/debug/debug.factor b/basis/tools/walker/debug/debug.factor
index 2b252404d6..f2155ec125 100755
--- a/basis/tools/walker/debug/debug.factor
+++ b/basis/tools/walker/debug/debug.factor
@@ -27,5 +27,5 @@ IN: tools.walker.debug
p ?promise
variables>> walker-continuation swap at
- model-value data>>
+ value>> data>>
] ;
diff --git a/basis/tools/walker/walker.factor b/basis/tools/walker/walker.factor
index cb5283e797..9c6b87b439 100755
--- a/basis/tools/walker/walker.factor
+++ b/basis/tools/walker/walker.factor
@@ -163,7 +163,7 @@ SYMBOL: +stopped+
] change-frame ;
: status ( -- symbol )
- walker-status tget model-value ;
+ walker-status tget value>> ;
: set-status ( symbol -- )
walker-status tget set-model ;
From 7d1e346cec70dc70c886cf1d25ad120569dbe973 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:51:31 -0500
Subject: [PATCH 07/46] new accessors
---
extra/asn1/asn1.factor | 24 ++++++++++++------------
1 file changed, 12 insertions(+), 12 deletions(-)
diff --git a/extra/asn1/asn1.factor b/extra/asn1/asn1.factor
index 3509deb2fb..3c4aea028b 100644
--- a/extra/asn1/asn1.factor
+++ b/extra/asn1/asn1.factor
@@ -54,7 +54,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
: (set-tag) ( -- )
elements get id>> 31 bitand
- dup elements get set-element-tag
+ dup elements get (>>tag)
31 < [
[ "unsupported tag encoding: #{" %
get-id # "}" %
@@ -63,22 +63,22 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
: set-tagclass ( -- )
get-id -6 shift tag-classes nth
- elements get set-element-tagclass ;
+ elements get (>>tagclass) ;
: set-encoding ( -- )
get-id HEX: 20 bitand
zero? "primitive" "constructed" ?
- elements get set-element-encoding ;
+ elements get (>>encoding) ;
: set-content-length ( -- )
read1
dup 127 <= [
127 bitand read be>
- ] unless elements get set-element-contentlength ;
+ ] unless elements get (>>contentlength) ;
: set-newobj ( -- )
elements get contentlength>> read
- elements get set-element-newobj ;
+ elements get (>>newobj) ;
: set-objtype ( syntax -- )
builtin-syntax 2array [
@@ -86,7 +86,7 @@ TUPLE: element syntax id tag tagclass encoding contentlength newobj objtype ;
elements get encoding>> swap at
elements get tag>>
swap at [
- elements get set-element-objtype
+ elements get (>>objtype)
] when*
] each ;
@@ -96,15 +96,15 @@ SYMBOL: end
: (read-array) ( -- )
elements get id>> [
- elements get element-syntax read-ber
+ elements get syntax>> read-ber
dup end = [ drop ] [ , (read-array) ] if
] when ;
: read-array ( -- array ) [ (read-array) ] { } make ;
: set-case ( -- object )
- elements get element-newobj
- elements get element-objtype {
+ elements get newobj>>
+ elements get objtype>> {
{ "boolean" [ "\0" = not ] }
{ "string" [ "" or ] }
{ "integer" [ be> ] }
@@ -112,7 +112,7 @@ SYMBOL: end
} case ;
: set-id ( -- boolean )
- read1 dup elements get set-element-id ;
+ read1 dup elements get (>>id) ;
: read-ber ( syntax -- object )
element new
@@ -124,7 +124,7 @@ SYMBOL: end
set-encoding
set-content-length
set-newobj
- elements get element-syntax set-objtype
+ elements get syntax>> set-objtype
set-case
] [ end ] if ;
@@ -181,7 +181,7 @@ TUPLE: tag value ;
] with-scope ; inline
: set-tag ( value -- )
- tagnum get set-tag-value ;
+ tagnum get (>>value) ;
M: string >ber ( str -- byte-array )
tagnum get tag-value 1array "C" pack-native swap dup
From 41fc9eac0f3fdde868ef0972aa528ffd404df0fd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:51:43 -0500
Subject: [PATCH 08/46] new accessors
---
extra/coroutines/coroutines.factor | 17 +++++++++--------
1 file changed, 9 insertions(+), 8 deletions(-)
diff --git a/extra/coroutines/coroutines.factor b/extra/coroutines/coroutines.factor
index 3fad3adbaa..3c1f8490c4 100644
--- a/extra/coroutines/coroutines.factor
+++ b/extra/coroutines/coroutines.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2005 Chris Double, 2007 Clemens Hofreither.
! See http://factorcode.org/license.txt for BSD license.
+USING: kernel hashtables namespaces continuations quotations
+accessors ;
IN: coroutines
-USING: kernel hashtables namespaces continuations quotations ;
SYMBOL: current-coro
@@ -13,12 +14,12 @@ TUPLE: coroutine resumecc exitcc ;
[ swapd , , \ bind ,
"Coroutine has terminated illegally." , \ throw ,
] [ ] make
- over set-coroutine-resumecc ;
+ >>resumecc ;
: coresume ( v co -- result )
[
- over set-coroutine-exitcc
- coroutine-resumecc call
+ >>exitcc
+ resumecc>> call
#! At this point, the coroutine quotation must have terminated
#! normally (without calling coyield or coterminate). This shouldn't happen.
f over
@@ -31,8 +32,8 @@ TUPLE: coroutine resumecc exitcc ;
current-coro get
[
[ continue-with ] curry
- over set-coroutine-resumecc
- coroutine-exitcc continue-with
+ >>resumecc
+ exitcc>> continue-with
] callcc1 2nip ;
: coyield* ( v -- ) coyield drop ; inline
@@ -40,5 +41,5 @@ TUPLE: coroutine resumecc exitcc ;
: coterminate ( v -- )
current-coro get
- [ ] over set-coroutine-resumecc
- coroutine-exitcc continue-with ;
+ [ ] >>resumecc
+ exitcc>> continue-with ;
From b07cb1e8035df1a6c87e0d399f9efd7460e461b2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:51:55 -0500
Subject: [PATCH 09/46] new accessors
---
extra/db/mysql/lib/lib.factor | 2 +-
extra/db/sqlite/lib/lib.factor | 4 ++--
extra/db/sqlite/sqlite.factor | 2 +-
extra/db/tuples/tuples.factor | 2 +-
4 files changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor
index ca912f200d..47033c1c61 100644
--- a/extra/db/mysql/lib/lib.factor
+++ b/extra/db/mysql/lib/lib.factor
@@ -34,7 +34,7 @@ TUPLE: mysql-result-set ;
! =========================================================
: (mysql-query) ( mysql-connection query -- ret )
- >r mysql-db-handle r> mysql_query ;
+ >r db-handle>> r> mysql_query ;
! : (mysql-result) ( mysql-connection -- ret )
! [ mysql-db-handle mysql_use_result ] keep
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index d14e975ae1..03f424e8d4 100755
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -5,7 +5,7 @@ namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
io.backend db.errors present urls io.encodings.utf8
-io.encodings.string ;
+io.encodings.string accessors ;
IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ;
@@ -16,7 +16,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
: sqlite-statement-error ( -- * )
SQLITE_ERROR
- db get db-handle sqlite3_errmsg sqlite-sql-error ;
+ db get handle>> sqlite3_errmsg sqlite-sql-error ;
: sqlite-check-result ( n -- )
{
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 38a3899fc4..794ff5bacd 100755
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -90,7 +90,7 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
] keep bind-statement ;
: last-insert-id ( -- id )
- db get db-handle sqlite3_last_insert_rowid
+ db get handle>> sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-db insert-tuple* ( tuple statement -- )
diff --git a/extra/db/tuples/tuples.factor b/extra/db/tuples/tuples.factor
index 71cf878d2f..1b7ab24366 100755
--- a/extra/db/tuples/tuples.factor
+++ b/extra/db/tuples/tuples.factor
@@ -141,7 +141,7 @@ M: retryable execute-statement* ( statement type -- )
: update-tuple ( tuple -- )
dup class
- db get db-update-statements [ <update-tuple-statement> ] cache
+ db get update-statements>> [ <update-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: delete-tuples ( tuple -- )
From fbc1076ac2f780eb060db518240ab40ec7b2ac9c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:52:02 -0500
Subject: [PATCH 10/46] new accessors
---
extra/faq/faq.factor | 36 ++++++++++++++++++------------------
1 file changed, 18 insertions(+), 18 deletions(-)
diff --git a/extra/faq/faq.factor b/extra/faq/faq.factor
index 3cb17cf08b..47d3727703 100644
--- a/extra/faq/faq.factor
+++ b/extra/faq/faq.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: xml kernel sequences xml.utilities combinators.lib
math xml.data arrays assocs xml.generator xml.writer namespaces
-math.parser io ;
+math.parser io accessors ;
IN: faq
: find-after ( seq quot -- elem after )
@@ -21,16 +21,16 @@ C: <q/a> q/a
>r tag-children r> <q/a> ;
: q/a>li ( q/a -- li )
- [ q/a-question "strong" build-tag* f "br" build-tag* 2array ] keep
- q/a-answer append "li" build-tag* ;
+ [ question>> "strong" build-tag* f "br" build-tag* 2array ] keep
+ answer>> append "li" build-tag* ;
: xml>q/a ( xml -- q/a )
[ "question" tag-named tag-children ] keep
"answer" tag-named tag-children <q/a> ;
: q/a>xml ( q/a -- xml )
- [ q/a-question "question" build-tag* ] keep
- q/a-answer "answer" build-tag*
+ [ question>> "question" build-tag* ] keep
+ answer>> "answer" build-tag*
"\n" swap 3array "qa" build-tag* ;
! Lists of questions
@@ -43,23 +43,23 @@ C: <question-list> question-list
<question-list> ;
: question-list>xml ( question-list -- list )
- [ question-list-seq [ q/a>xml "\n" swap 2array ]
+ [ seq>> [ q/a>xml "\n" swap 2array ]
map concat "list" build-tag* ] keep
- question-list-title [ "title" pick set-at ] when* ;
+ title>> [ "title" pick set-at ] when* ;
: html>question-list ( h3 ol -- question-list )
>r [ children>string ] [ f ] if* r>
children-tags [ li>q/a ] map <question-list> ;
: question-list>h3 ( id question-list -- h3 )
- question-list-title [
+ title>> [
"h3" build-tag
swap number>string "id" pick set-at
] [ drop f ] if* ;
: question-list>html ( question-list start id -- h3/f ol )
-rot >r [ question-list>h3 ] keep
- question-list-seq [ q/a>li ] map "ol" build-tag* r>
+ seq>> [ q/a>li ] map "ol" build-tag* r>
number>string "start" pick set-at
"margin-left: 5em" "style" pick set-at ;
@@ -72,32 +72,32 @@ C: <faq> faq
first2 >r f prefix r> [ html>question-list ] 2map <faq> ;
: header, ( faq -- )
- dup faq-header ,
- faq-lists first 1 -1 question-list>html nip , ;
+ dup header>> ,
+ lists>> first 1 -1 question-list>html nip , ;
: br, ( -- )
"br" contained, nl, ;
: toc-link, ( question-list number -- )
number>string "#" prepend "href" swap 2array 1array
- "a" swap [ question-list-title , ] tag*, br, ;
+ "a" swap [ title>> , ] tag*, br, ;
: toc, ( faq -- )
"div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
"strong" [ "The big questions" , ] tag, br,
- faq-lists rest dup length [ toc-link, ] 2each
+ lists>> rest dup length [ toc-link, ] 2each
] tag*, ;
: faq-sections, ( question-lists -- )
- unclip question-list-seq length 1+ dupd
- [ question-list-seq length + ] accumulate nip
+ unclip seq>> length 1+ dupd
+ [ seq>> length + ] accumulate nip
0 -rot [ pick question-list>html [ , nl, ] bi@ 1+ ] 2each drop ;
: faq>html ( faq -- div )
"div" [
dup header,
dup toc,
- faq-lists faq-sections,
+ lists>> faq-sections,
] make-xml ;
: xml>faq ( xml -- faq )
@@ -106,8 +106,8 @@ C: <faq> faq
: faq>xml ( faq -- xml )
"faq" [
- "header" [ dup faq-header , ] tag,
- faq-lists [ question-list>xml , nl, ] each
+ "header" [ dup header>> , ] tag,
+ lists>> [ question-list>xml , nl, ] each
] make-xml ;
: read-write-faq ( xml-stream -- )
From cde71318abc8d9f8b18c045708d28c31b8c8269c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:52:11 -0500
Subject: [PATCH 11/46] new accessors
---
extra/math/erato/erato.factor | 14 +++++++-------
1 file changed, 7 insertions(+), 7 deletions(-)
diff --git a/extra/math/erato/erato.factor b/extra/math/erato/erato.factor
index b9d997c038..f836d71a99 100644
--- a/extra/math/erato/erato.factor
+++ b/extra/math/erato/erato.factor
@@ -1,7 +1,7 @@
! Copyright (c) 2007 Samuel Tardieu.
! See http://factorcode.org/license.txt for BSD license.
USING: bit-arrays kernel lists.lazy math math.functions math.primes.list
- math.ranges sequences ;
+ math.ranges sequences accessors ;
IN: math.erato
<PRIVATE
@@ -12,21 +12,21 @@ TUPLE: erato limit bits latest ;
2/ 1- ; inline
: is-prime ( n erato -- bool )
- >r ind r> erato-bits nth ; inline
+ >r ind r> bits>> nth ; inline
: indices ( n erato -- range )
- erato-limit ind over 3 * ind swap rot <range> ;
+ limit>> ind over 3 * ind swap rot <range> ;
: mark-multiples ( n erato -- )
- over sq over erato-limit <=
- [ [ indices ] keep erato-bits [ f -rot set-nth ] curry each ] [ 2drop ] if ;
+ over sq over limit>> <=
+ [ [ indices ] keep bits>> [ f -rot set-nth ] curry each ] [ 2drop ] if ;
: <erato> ( n -- erato )
dup ind 1+ <bit-array> 1 over set-bits erato boa ;
: next-prime ( erato -- prime/f )
- [ erato-latest 2 + ] keep [ set-erato-latest ] 2keep
- 2dup erato-limit <=
+ [ 2 + ] change-latest [ latest>> ] keep
+ 2dup limit>> <=
[
2dup is-prime [ dupd mark-multiples ] [ nip next-prime ] if
] [
From 9c62b5901ff5b3390779ae25836e5eda4f396948 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:52:18 -0500
Subject: [PATCH 12/46] new accessors
---
extra/oracle/oracle.factor | 14 +++++++-------
1 file changed, 7 insertions(+), 7 deletions(-)
diff --git a/extra/oracle/oracle.factor b/extra/oracle/oracle.factor
index 8ef169810a..e61a47a859 100644
--- a/extra/oracle/oracle.factor
+++ b/extra/oracle/oracle.factor
@@ -6,7 +6,7 @@
USING: alien alien.c-types alien.strings combinators kernel math
namespaces oracle.liboci prettyprint sequences
-io.encodings.ascii ;
+io.encodings.ascii accessors ;
IN: oracle
@@ -102,9 +102,9 @@ C: <connection> connection
: oci-log-on ( -- )
env get err get svc get
- con get connection-username dup length swap ascii malloc-string swap
- con get connection-password dup length swap ascii malloc-string swap
- con get connection-db dup length swap ascii malloc-string swap
+ con get username>> dup length swap ascii malloc-string swap
+ con get password>> dup length swap ascii malloc-string swap
+ con get db>> dup length swap ascii malloc-string swap
OCILogon check-result ;
! =========================================================
@@ -112,18 +112,18 @@ C: <connection> connection
! =========================================================
: attach-to-server ( -- )
- srv get err get con get connection-db dup length OCI_DEFAULT
+ srv get err get con get db>> dup length OCI_DEFAULT
OCIServerAttach check-result ;
: set-service-attribute ( -- )
svc get OCI_HTYPE_SVCCTX srv get 0 OCI_ATTR_SERVER err get OCIAttrSet check-result ;
: set-username-attribute ( -- )
- ses get OCI_HTYPE_SESSION con get connection-username dup length swap ascii malloc-string swap
+ ses get OCI_HTYPE_SESSION con get username>> dup length swap ascii malloc-string swap
OCI_ATTR_USERNAME err get OCIAttrSet check-result ;
: set-password-attribute ( -- )
- ses get OCI_HTYPE_SESSION con get connection-password dup length swap ascii malloc-string swap
+ ses get OCI_HTYPE_SESSION con get password>> dup length swap ascii malloc-string swap
OCI_ATTR_PASSWORD err get OCIAttrSet check-result ;
: set-attributes ( -- )
From 8769bad2c7631bdc99c8205ff2ab6ff8579a39a0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:56:40 -0500
Subject: [PATCH 13/46] accessors
---
extra/db/mysql/lib/lib.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor
index 47033c1c61..db8c08180b 100644
--- a/extra/db/mysql/lib/lib.factor
+++ b/extra/db/mysql/lib/lib.factor
@@ -3,7 +3,7 @@
! Adapted from mysql.h and mysql.c
! Tested with MySQL version - 5.0.24a
USING: kernel alien io prettyprint sequences
-namespaces arrays math db.mysql.ffi system ;
+namespaces arrays math db.mysql.ffi system accessors ;
IN: db.mysql.lib
SYMBOL: my-conn
From 521188ab05130d7244960db22a84075a63cfbdbd Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 02:59:33 -0500
Subject: [PATCH 14/46] new accessors
---
extra/odbc/odbc.factor | 10 +++++-----
1 file changed, 5 insertions(+), 5 deletions(-)
diff --git a/extra/odbc/odbc.factor b/extra/odbc/odbc.factor
index 5faca7109a..faa6c48354 100644
--- a/extra/odbc/odbc.factor
+++ b/extra/odbc/odbc.factor
@@ -213,7 +213,7 @@ C: <column> column
] if ;
: dereference-type-pointer ( byte-array column -- object )
- column-type {
+ type>> {
{ SQL-CHAR [ ascii alien>string ] }
{ SQL-VARCHAR [ ascii alien>string ] }
{ SQL-LONGVARCHAR [ ascii alien>string ] }
@@ -235,7 +235,7 @@ TUPLE: field value column ;
C: <field> field
: odbc-get-field ( statement column -- field )
- dup column? [ dupd odbc-describe-column ] unless dup >r column-number
+ dup column? [ dupd odbc-describe-column ] unless dup >r number>>
SQL-C-DEFAULT
8192 CHAR: \space <string> ascii string>alien dup >r
8192
@@ -244,15 +244,15 @@ C: <field> field
] [
r> drop r> [
"SQLGetData Failed for Column: " %
- dup column-name %
- " of type: " % dup column-type name>> %
+ dup name>> %
+ " of type: " % dup type>> name>> %
] "" make swap <field>
] if ;
: odbc-get-row-fields ( statement -- seq )
[
dup odbc-number-of-columns [
- 1+ odbc-get-field field-value ,
+ 1+ odbc-get-field value>> ,
] with each
] { } make ;
From c3d2c907f8fb87b99e196c9bfb4f8b8a7fc5818c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 03:05:41 -0500
Subject: [PATCH 15/46] accessors
---
extra/ftp/server/server.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/ftp/server/server.factor b/extra/ftp/server/server.factor
index c5a5449b25..21a32d1776 100644
--- a/extra/ftp/server/server.factor
+++ b/extra/ftp/server/server.factor
@@ -144,7 +144,7 @@ M: ftp-list service-command ( stream obj -- )
150 "Opening BINARY mode data connection for "
rot
[ file-name ] [
- " " swap file-info file-info-size number>string
+ " " swap file-info size>> number>string
"(" " bytes)." swapd 3append append
] bi 3append server-response ;
From 80bd7608ed0fd11ed9271dd82c046c9918c50f0a Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 03:06:25 -0500
Subject: [PATCH 16/46] fix docs
---
basis/io/mmap/mmap-docs.factor | 7 +++----
1 file changed, 3 insertions(+), 4 deletions(-)
diff --git a/basis/io/mmap/mmap-docs.factor b/basis/io/mmap/mmap-docs.factor
index 4ac85232b8..c774103fca 100755
--- a/basis/io/mmap/mmap-docs.factor
+++ b/basis/io/mmap/mmap-docs.factor
@@ -5,8 +5,8 @@ IN: io.mmap
HELP: mapped-file
{ $class-description "The class of memory-mapped files, opened by " { $link <mapped-file> } " and closed by " { $link close-mapped-file } ". The following two slots are of interest to users:"
{ $list
- { { $link mapped-file-length } " - the length of the mapped file area, in bytes" }
- { { $link mapped-file-address } " - an " { $link alien } " pointing at the file's memory area" }
+ { { $snippet "length" } " - the length of the mapped file area, in bytes" }
+ { { $snippet "address" } " - an " { $link alien } " pointing at the file's memory area" }
}
} ;
@@ -33,8 +33,7 @@ ARTICLE: "io.mmap" "Memory-mapped files"
$nl
"A utility combinator which wraps the above:"
{ $subsection with-mapped-file }
-"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly:"
-{ $subsection mapped-file-address }
+"Memory mapped files implement the " { $link "sequence-protocol" } " and present themselves as a sequence of bytes. The underlying memory area can also be accessed directly with the " { $snippet "address" } " slot." $nl
"Data can be read and written from the memory area using alien words. See " { $link "reading-writing-memory" } "." ;
ABOUT: "io.mmap"
From faa9c4c69c4683abdb16765950ef7997560f09a4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 03:07:23 -0500
Subject: [PATCH 17/46] move db.mysql
---
unmaintained/db/mysql/ffi/ffi.factor | 25 +++++++++
unmaintained/db/mysql/lib/lib.factor | 78 ++++++++++++++++++++++++++++
unmaintained/db/mysql/mysql.factor | 51 ++++++++++++++++++
3 files changed, 154 insertions(+)
create mode 100644 unmaintained/db/mysql/ffi/ffi.factor
create mode 100644 unmaintained/db/mysql/lib/lib.factor
create mode 100755 unmaintained/db/mysql/mysql.factor
diff --git a/unmaintained/db/mysql/ffi/ffi.factor b/unmaintained/db/mysql/ffi/ffi.factor
new file mode 100644
index 0000000000..c047393c99
--- /dev/null
+++ b/unmaintained/db/mysql/ffi/ffi.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+! Adapted from mysql.h and mysql.c
+! Tested with MySQL version - 5.0.24a
+USING: alien alien.syntax combinators kernel system ;
+IN: db.mysql.ffi
+
+<< "mysql" {
+ { [ os winnt? ] [ "libmySQL.dll" "stdcall" ] }
+ { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
+ { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
+} cond add-library >>
+
+LIBRARY: mysql
+
+FUNCTION: void* mysql_init ( void* mysql ) ;
+FUNCTION: char* mysql_error ( void* mysql ) ;
+FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ;
+FUNCTION: void mysql_close ( void* sock ) ;
+FUNCTION: int mysql_query ( void* mysql, char* q ) ;
+FUNCTION: void* mysql_use_result ( void* mysql ) ;
+FUNCTION: void mysql_free_result ( void* result ) ;
+FUNCTION: char** mysql_fetch_row ( void* result ) ;
+FUNCTION: int mysql_num_fields ( void* result ) ;
+FUNCTION: ulong mysql_affected_rows ( void* mysql ) ;
diff --git a/unmaintained/db/mysql/lib/lib.factor b/unmaintained/db/mysql/lib/lib.factor
new file mode 100644
index 0000000000..db8c08180b
--- /dev/null
+++ b/unmaintained/db/mysql/lib/lib.factor
@@ -0,0 +1,78 @@
+! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for license.
+! Adapted from mysql.h and mysql.c
+! Tested with MySQL version - 5.0.24a
+USING: kernel alien io prettyprint sequences
+namespaces arrays math db.mysql.ffi system accessors ;
+IN: db.mysql.lib
+
+SYMBOL: my-conn
+
+TUPLE: mysql-db handle host user password db port ;
+TUPLE: mysql-statement ;
+TUPLE: mysql-result-set ;
+
+: new-mysql ( -- conn )
+ f mysql_init ;
+
+: mysql-error ( mysql -- )
+ [ mysql_error throw ] when* ;
+
+! : mysql-connect ( mysql-connection -- )
+ ! new-mysql over set-mysql-db-handle
+ ! dup {
+ ! mysql-db-handle
+ ! mysql-db-host
+ ! mysql-db-user
+ ! mysql-db-password
+ ! mysql-db-db
+ ! mysql-db-port
+ ! } get-slots f 0 mysql_real_connect mysql-error ;
+
+! =========================================================
+! Low level mysql utility definitions
+! =========================================================
+
+: (mysql-query) ( mysql-connection query -- ret )
+ >r db-handle>> r> mysql_query ;
+
+! : (mysql-result) ( mysql-connection -- ret )
+ ! [ mysql-db-handle mysql_use_result ] keep
+ ! [ set-mysql-connection-resulthandle ] keep ;
+
+! : (mysql-affected-rows) ( mysql-connection -- n )
+ ! mysql-connection-mysqlconn mysql_affected_rows ;
+
+! : (mysql-free-result) ( mysql-connection -- )
+ ! mysql-connection-resulthandle drop ;
+
+! : (mysql-row) ( mysql-connection -- row )
+ ! mysql-connection-resulthandle mysql_fetch_row ;
+
+! : (mysql-num-cols) ( mysql-connection -- n )
+ ! mysql-connection-resulthandle mysql_num_fields ;
+
+! : mysql-char*-nth ( index object -- str )
+ ! #! Utility based on 'char*-nth' to perform an additional sanity check on the value
+ ! #! extracted from the array of strings.
+ ! void*-nth [ alien>char-string ] [ "" ] if* ;
+
+! : mysql-row>seq ( object n -- seq )
+ ! [ swap mysql-char*-nth ] map-with ;
+
+! : (mysql-result>seq) ( seq -- seq )
+ ! my-conn get (mysql-row) dup [
+ ! my-conn get (mysql-num-cols) mysql-row>seq
+ ! over push
+ ! (mysql-result>seq)
+ ! ] [ drop ] if
+ ! ! Perform needed cleanup on fetched results
+ ! my-conn get (mysql-free-result) ;
+
+! : mysql-query ( query -- ret )
+ ! >r my-conn get r> (mysql-query) drop
+ ! my-conn get (mysql-result) ;
+
+! : mysql-command ( query -- n )
+ ! mysql-query drop
+ ! my-conn get (mysql-affected-rows) ;
diff --git a/unmaintained/db/mysql/mysql.factor b/unmaintained/db/mysql/mysql.factor
new file mode 100755
index 0000000000..1767bf3d50
--- /dev/null
+++ b/unmaintained/db/mysql/mysql.factor
@@ -0,0 +1,51 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for license.
+USING: alien continuations destructors io kernel prettyprint
+sequences db db.mysql.ffi ;
+IN: db.mysql
+
+TUPLE: mysql-db handle host user password db port ;
+TUPLE: mysql-statement ;
+TUPLE: mysql-result-set ;
+
+M: mysql-db db-open ( mysql-db -- )
+ ;
+
+M: mysql-db dispose ( mysql-db -- )
+ mysql-db-handle mysql_close ;
+
+M: mysql-db <simple-statement> ( str in out -- statement )
+ 3drop f ;
+
+M: mysql-db <prepared-statement> ( str in out -- statement )
+ 3drop f ;
+
+M: mysql-statement prepare-statement ( statement -- )
+ drop ;
+
+M: mysql-statement bind-statement* ( statement -- )
+ drop ;
+
+M: mysql-statement query-results ( query -- result-set )
+ drop f ;
+
+M: mysql-result-set #rows ( result-set -- n )
+ drop 0 ;
+
+M: mysql-result-set #columns ( result-set -- n )
+ drop 0 ;
+
+M: mysql-result-set row-column ( result-set n -- obj )
+ 2drop f ;
+
+M: mysql-result-set advance-row ( result-set -- )
+ drop ;
+
+M: mysql-db begin-transaction ( -- )
+ ;
+
+M: mysql-db commit-transaction ( -- )
+ ;
+
+M: mysql-db rollback-transaction ( -- )
+ ;
From 3010765d12e73ebfe1b7dc376b1d65ed260ca7aa Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 03:07:41 -0500
Subject: [PATCH 18/46] delete old mysql
---
extra/db/mysql/ffi/ffi.factor | 25 -----------
extra/db/mysql/lib/lib.factor | 78 -----------------------------------
extra/db/mysql/mysql.factor | 51 -----------------------
3 files changed, 154 deletions(-)
delete mode 100644 extra/db/mysql/ffi/ffi.factor
delete mode 100644 extra/db/mysql/lib/lib.factor
delete mode 100755 extra/db/mysql/mysql.factor
diff --git a/extra/db/mysql/ffi/ffi.factor b/extra/db/mysql/ffi/ffi.factor
deleted file mode 100644
index c047393c99..0000000000
--- a/extra/db/mysql/ffi/ffi.factor
+++ /dev/null
@@ -1,25 +0,0 @@
-! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-! Adapted from mysql.h and mysql.c
-! Tested with MySQL version - 5.0.24a
-USING: alien alien.syntax combinators kernel system ;
-IN: db.mysql.ffi
-
-<< "mysql" {
- { [ os winnt? ] [ "libmySQL.dll" "stdcall" ] }
- { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
- { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
-} cond add-library >>
-
-LIBRARY: mysql
-
-FUNCTION: void* mysql_init ( void* mysql ) ;
-FUNCTION: char* mysql_error ( void* mysql ) ;
-FUNCTION: void* mysql_real_connect ( void* mysql, char* host, char* user, char* passwd, char* db, int port, char* unixsocket, long clientflag ) ;
-FUNCTION: void mysql_close ( void* sock ) ;
-FUNCTION: int mysql_query ( void* mysql, char* q ) ;
-FUNCTION: void* mysql_use_result ( void* mysql ) ;
-FUNCTION: void mysql_free_result ( void* result ) ;
-FUNCTION: char** mysql_fetch_row ( void* result ) ;
-FUNCTION: int mysql_num_fields ( void* result ) ;
-FUNCTION: ulong mysql_affected_rows ( void* mysql ) ;
diff --git a/extra/db/mysql/lib/lib.factor b/extra/db/mysql/lib/lib.factor
deleted file mode 100644
index db8c08180b..0000000000
--- a/extra/db/mysql/lib/lib.factor
+++ /dev/null
@@ -1,78 +0,0 @@
-! Copyright (C) 2007 Berlin Brown, 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for license.
-! Adapted from mysql.h and mysql.c
-! Tested with MySQL version - 5.0.24a
-USING: kernel alien io prettyprint sequences
-namespaces arrays math db.mysql.ffi system accessors ;
-IN: db.mysql.lib
-
-SYMBOL: my-conn
-
-TUPLE: mysql-db handle host user password db port ;
-TUPLE: mysql-statement ;
-TUPLE: mysql-result-set ;
-
-: new-mysql ( -- conn )
- f mysql_init ;
-
-: mysql-error ( mysql -- )
- [ mysql_error throw ] when* ;
-
-! : mysql-connect ( mysql-connection -- )
- ! new-mysql over set-mysql-db-handle
- ! dup {
- ! mysql-db-handle
- ! mysql-db-host
- ! mysql-db-user
- ! mysql-db-password
- ! mysql-db-db
- ! mysql-db-port
- ! } get-slots f 0 mysql_real_connect mysql-error ;
-
-! =========================================================
-! Low level mysql utility definitions
-! =========================================================
-
-: (mysql-query) ( mysql-connection query -- ret )
- >r db-handle>> r> mysql_query ;
-
-! : (mysql-result) ( mysql-connection -- ret )
- ! [ mysql-db-handle mysql_use_result ] keep
- ! [ set-mysql-connection-resulthandle ] keep ;
-
-! : (mysql-affected-rows) ( mysql-connection -- n )
- ! mysql-connection-mysqlconn mysql_affected_rows ;
-
-! : (mysql-free-result) ( mysql-connection -- )
- ! mysql-connection-resulthandle drop ;
-
-! : (mysql-row) ( mysql-connection -- row )
- ! mysql-connection-resulthandle mysql_fetch_row ;
-
-! : (mysql-num-cols) ( mysql-connection -- n )
- ! mysql-connection-resulthandle mysql_num_fields ;
-
-! : mysql-char*-nth ( index object -- str )
- ! #! Utility based on 'char*-nth' to perform an additional sanity check on the value
- ! #! extracted from the array of strings.
- ! void*-nth [ alien>char-string ] [ "" ] if* ;
-
-! : mysql-row>seq ( object n -- seq )
- ! [ swap mysql-char*-nth ] map-with ;
-
-! : (mysql-result>seq) ( seq -- seq )
- ! my-conn get (mysql-row) dup [
- ! my-conn get (mysql-num-cols) mysql-row>seq
- ! over push
- ! (mysql-result>seq)
- ! ] [ drop ] if
- ! ! Perform needed cleanup on fetched results
- ! my-conn get (mysql-free-result) ;
-
-! : mysql-query ( query -- ret )
- ! >r my-conn get r> (mysql-query) drop
- ! my-conn get (mysql-result) ;
-
-! : mysql-command ( query -- n )
- ! mysql-query drop
- ! my-conn get (mysql-affected-rows) ;
diff --git a/extra/db/mysql/mysql.factor b/extra/db/mysql/mysql.factor
deleted file mode 100755
index 1767bf3d50..0000000000
--- a/extra/db/mysql/mysql.factor
+++ /dev/null
@@ -1,51 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for license.
-USING: alien continuations destructors io kernel prettyprint
-sequences db db.mysql.ffi ;
-IN: db.mysql
-
-TUPLE: mysql-db handle host user password db port ;
-TUPLE: mysql-statement ;
-TUPLE: mysql-result-set ;
-
-M: mysql-db db-open ( mysql-db -- )
- ;
-
-M: mysql-db dispose ( mysql-db -- )
- mysql-db-handle mysql_close ;
-
-M: mysql-db <simple-statement> ( str in out -- statement )
- 3drop f ;
-
-M: mysql-db <prepared-statement> ( str in out -- statement )
- 3drop f ;
-
-M: mysql-statement prepare-statement ( statement -- )
- drop ;
-
-M: mysql-statement bind-statement* ( statement -- )
- drop ;
-
-M: mysql-statement query-results ( query -- result-set )
- drop f ;
-
-M: mysql-result-set #rows ( result-set -- n )
- drop 0 ;
-
-M: mysql-result-set #columns ( result-set -- n )
- drop 0 ;
-
-M: mysql-result-set row-column ( result-set n -- obj )
- 2drop f ;
-
-M: mysql-result-set advance-row ( result-set -- )
- drop ;
-
-M: mysql-db begin-transaction ( -- )
- ;
-
-M: mysql-db commit-transaction ( -- )
- ;
-
-M: mysql-db rollback-transaction ( -- )
- ;
From 57927837603c3a9e299d9d3179e602e937d7bc73 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 05:19:16 -0500
Subject: [PATCH 19/46] Fix dodgy method overloading
---
core/compiler/units/units.factor | 17 +++++++++++++----
core/definitions/definitions.factor | 20 +++-----------------
core/sorting/sorting-tests.factor | 4 +++-
3 files changed, 19 insertions(+), 22 deletions(-)
diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor
index 78799287f5..fa29a5a519 100755
--- a/core/compiler/units/units.factor
+++ b/core/compiler/units/units.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel continuations assocs namespaces
sequences words vocabs definitions hashtables init sets
-math.order classes classes.algebra ;
+math math.order classes classes.algebra ;
IN: compiler.units
SYMBOL: old-definitions
@@ -73,11 +73,20 @@ GENERIC: definitions-changed ( assoc obj -- )
SYMBOL: outdated-tuples
SYMBOL: update-tuples-hook
+: dependency>= ( how1 how2 -- ? )
+ [
+ {
+ called-dependency
+ flushed-dependency
+ inlined-dependency
+ } index
+ ] bi@ >= ;
+
: strongest-dependency ( how1 how2 -- how )
- [ called-dependency or ] bi@ max ;
+ [ called-dependency or ] bi@ [ dependency>= ] most ;
: weakest-dependency ( how1 how2 -- how )
- [ inlined-dependency or ] bi@ min ;
+ [ inlined-dependency or ] bi@ [ dependency>= not ] most ;
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
@@ -89,7 +98,7 @@ SYMBOL: update-tuples-hook
#! don't have to recompile words that folded this away.
[ compiled-usage ]
[ "flushable" word-prop inlined-dependency flushed-dependency ? ] bi
- [ after=? nip ] curry assoc-filter ;
+ [ dependency>= nip ] curry assoc-filter ;
: compiled-usages ( assoc -- assocs )
[ drop word? ] assoc-filter
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index d9e9732488..2b8646fda4 100755
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -5,23 +5,9 @@ USING: kernel sequences namespaces assocs graphs math math.order ;
ERROR: no-compilation-unit definition ;
-SINGLETON: inlined-dependency
-SINGLETON: flushed-dependency
-SINGLETON: called-dependency
-
-UNION: dependency
-inlined-dependency
-flushed-dependency
-called-dependency ;
-
-M: dependency <=>
- [
- {
- called-dependency
- flushed-dependency
- inlined-dependency
- } index
- ] bi@ <=> ;
+SYMBOL: inlined-dependency
+SYMBOL: flushed-dependency
+SYMBOL: called-dependency
SYMBOL: changed-definitions
diff --git a/core/sorting/sorting-tests.factor b/core/sorting/sorting-tests.factor
index 63e193c89f..74cbe3b532 100755
--- a/core/sorting/sorting-tests.factor
+++ b/core/sorting/sorting-tests.factor
@@ -1,5 +1,5 @@
USING: sorting sequences kernel math math.order random
-tools.test vectors sets ;
+tools.test vectors sets vocabs ;
IN: sorting.tests
[ { } ] [ { } natural-sort ] unit-test
@@ -24,3 +24,5 @@ unit-test
[ { { 1 "a" } { 1 "b" } { 1 "c" } { 1 "e" } { 2 "d" } } ]
[ { { 1 "a" } { 1 "b" } { 1 "c" } { 2 "d" } { 1 "e" } } sort-keys ] unit-test
+
+[ ] [ all-words natural-sort drop ] unit-test
From dd45c26234a6da78ac5673d59f0f2cbd0ae6d484 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 05:40:29 -0500
Subject: [PATCH 20/46] Oops, we weren't doing TCO in some cases
---
.../tree/finalization/finalization.factor | 18 ++++++++++++++++++
basis/compiler/tree/optimizer/optimizer.factor | 2 ++
.../benchmark/empty-loop-0/empty-loop-0.factor | 2 +-
.../benchmark/empty-loop-2/empty-loop-2.factor | 2 +-
4 files changed, 22 insertions(+), 2 deletions(-)
create mode 100644 basis/compiler/tree/finalization/finalization.factor
diff --git a/basis/compiler/tree/finalization/finalization.factor b/basis/compiler/tree/finalization/finalization.factor
new file mode 100644
index 0000000000..08734ec095
--- /dev/null
+++ b/basis/compiler/tree/finalization/finalization.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors sequences
+compiler.tree compiler.tree.combinators ;
+IN: compiler.tree.finalization
+
+GENERIC: finalize* ( node -- nodes )
+
+M: #copy finalize* drop f ;
+
+M: #shuffle finalize*
+ dup shuffle-effect
+ [ in>> ] [ out>> ] bi sequence=
+ [ drop f ] when ;
+
+M: node finalize* ;
+
+: finalize ( nodes -- nodes' ) [ finalize* ] map-nodes ;
diff --git a/basis/compiler/tree/optimizer/optimizer.factor b/basis/compiler/tree/optimizer/optimizer.factor
index 5d0b8d089b..593c13b277 100644
--- a/basis/compiler/tree/optimizer/optimizer.factor
+++ b/basis/compiler/tree/optimizer/optimizer.factor
@@ -11,6 +11,7 @@ compiler.tree.strength-reduction
compiler.tree.loop.detection
compiler.tree.loop.inversion
compiler.tree.branch-fusion
+compiler.tree.finalization
compiler.tree.checker ;
IN: compiler.tree.optimizer
@@ -25,6 +26,7 @@ IN: compiler.tree.optimizer
unbox-tuples
compute-def-use
remove-dead-code
+ finalize
! strength-reduce
! USE: kernel
! compute-def-use
diff --git a/extra/benchmark/empty-loop-0/empty-loop-0.factor b/extra/benchmark/empty-loop-0/empty-loop-0.factor
index 65390e84f2..1922274cac 100644
--- a/extra/benchmark/empty-loop-0/empty-loop-0.factor
+++ b/extra/benchmark/empty-loop-0/empty-loop-0.factor
@@ -5,6 +5,6 @@ IN: benchmark.empty-loop-0
dup 0 fixnum< [ drop ] [ 1 fixnum-fast empty-loop-0 ] if ;
: empty-loop-main ( -- )
- 5000000 empty-loop-0 ;
+ 50000000 empty-loop-0 ;
MAIN: empty-loop-main
diff --git a/extra/benchmark/empty-loop-2/empty-loop-2.factor b/extra/benchmark/empty-loop-2/empty-loop-2.factor
index f7d66b04ab..f09aee6ada 100644
--- a/extra/benchmark/empty-loop-2/empty-loop-2.factor
+++ b/extra/benchmark/empty-loop-2/empty-loop-2.factor
@@ -5,6 +5,6 @@ IN: benchmark.empty-loop-2
[ drop ] each ;
: empty-loop-main ( -- )
- 5000000 empty-loop-2 ;
+ 50000000 empty-loop-2 ;
MAIN: empty-loop-main
From b73bc690847543d3a9b093160de4e4a41b779925 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 05:50:02 -0500
Subject: [PATCH 21/46] Fix PPC again, oops
---
basis/cpu/ppc/intrinsics/intrinsics.factor | 83 +++++++++++-----------
1 file changed, 42 insertions(+), 41 deletions(-)
diff --git a/basis/cpu/ppc/intrinsics/intrinsics.factor b/basis/cpu/ppc/intrinsics/intrinsics.factor
index bf990e1447..6413cf839c 100755
--- a/basis/cpu/ppc/intrinsics/intrinsics.factor
+++ b/basis/cpu/ppc/intrinsics/intrinsics.factor
@@ -5,9 +5,10 @@ cpu.ppc.assembler cpu.ppc.architecture cpu.ppc.allot
cpu.architecture kernel kernel.private math math.private
namespaces sequences words generic quotations byte-arrays
hashtables hashtables.private compiler.generator
-compiler.generator.registers generator.fixup sequences.private
-sbufs vectors system layouts math.floats.private classes
-slots.private combinators compiler.constants ;
+compiler.generator.registers compiler.generator.fixup
+sequences.private sbufs vectors system layouts
+math.floats.private classes slots.private combinators
+compiler.constants ;
IN: cpu.ppc.intrinsics
: %slot-literal-known-tag
@@ -436,44 +437,44 @@ IN: cpu.ppc.intrinsics
{ +clobber+ { "n" } }
} define-intrinsic
-\ (tuple) [
- tuple "layout" get size>> 2 + cells %allot
- ! Store layout
- "layout" get 12 load-indirect
- 12 11 cell STW
- ! Store tagged ptr in reg
- "tuple" get tuple %store-tagged
-] H{
- { +input+ { { [ ] "layout" } } }
- { +scratch+ { { f "tuple" } } }
- { +output+ { "tuple" } }
-} define-intrinsic
-
-\ (array) [
- array "n" get 2 + cells %allot
- ! Store length
- "n" operand 12 LI
- 12 11 cell STW
- ! Store tagged ptr in reg
- "array" get object %store-tagged
-] H{
- { +input+ { { [ ] "n" } } }
- { +scratch+ { { f "array" } } }
- { +output+ { "array" } }
-} define-intrinsic
-
-\ (byte-array) [
- byte-array "n" get 2 cells + %allot
- ! Store length
- "n" operand 12 LI
- 12 11 cell STW
- ! Store tagged ptr in reg
- "array" get object %store-tagged
-] H{
- { +input+ { { [ ] "n" } } }
- { +scratch+ { { f "array" } } }
- { +output+ { "array" } }
-} define-intrinsic
+! \ (tuple) [
+! tuple "layout" get size>> 2 + cells %allot
+! ! Store layout
+! "layout" get 12 load-indirect
+! 12 11 cell STW
+! ! Store tagged ptr in reg
+! "tuple" get tuple %store-tagged
+! ] H{
+! { +input+ { { [ ] "layout" } } }
+! { +scratch+ { { f "tuple" } } }
+! { +output+ { "tuple" } }
+! } define-intrinsic
+!
+! \ (array) [
+! array "n" get 2 + cells %allot
+! ! Store length
+! "n" operand 12 LI
+! 12 11 cell STW
+! ! Store tagged ptr in reg
+! "array" get object %store-tagged
+! ] H{
+! { +input+ { { [ ] "n" } } }
+! { +scratch+ { { f "array" } } }
+! { +output+ { "array" } }
+! } define-intrinsic
+!
+! \ (byte-array) [
+! byte-array "n" get 2 cells + %allot
+! ! Store length
+! "n" operand 12 LI
+! 12 11 cell STW
+! ! Store tagged ptr in reg
+! "array" get object %store-tagged
+! ] H{
+! { +input+ { { [ ] "n" } } }
+! { +scratch+ { { f "array" } } }
+! { +output+ { "array" } }
+! } define-intrinsic
\ <ratio> [
ratio 3 cells %allot
From ca5caafefe7a6136344d84940283fc28976643ca Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 06:02:15 -0500
Subject: [PATCH 22/46] Fix
---
extra/benchmark/empty-loop-1/empty-loop-1.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/benchmark/empty-loop-1/empty-loop-1.factor b/extra/benchmark/empty-loop-1/empty-loop-1.factor
index 36d8722732..16303b4b4d 100644
--- a/extra/benchmark/empty-loop-1/empty-loop-1.factor
+++ b/extra/benchmark/empty-loop-1/empty-loop-1.factor
@@ -5,6 +5,6 @@ IN: benchmark.empty-loop-1
[ drop ] each-integer ;
: empty-loop-main ( -- )
- 5000000 empty-loop-1 ;
+ 50000000 empty-loop-1 ;
MAIN: empty-loop-main
From 0c304b8fc667d815c94759e797049337bf072709 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 07:45:33 -0500
Subject: [PATCH 23/46] Removing old accessor usages from core and basis
---
basis/alien/arrays/arrays.factor | 2 +-
basis/alien/c-types/c-types.factor | 67 ++++++++++++++++---
basis/alien/structs/structs-docs.factor | 4 +-
basis/alien/structs/structs-tests.factor | 2 +-
basis/alien/structs/structs.factor | 8 +--
basis/bootstrap/stage2.factor | 4 +-
.../generator/registers/registers.factor | 42 ++++++------
.../cpu/ppc/architecture/architecture.factor | 15 +++--
basis/cpu/ppc/ppc.factor | 15 +++--
basis/cpu/x86/32/32.factor | 6 +-
basis/cpu/x86/64/64.factor | 4 +-
.../cpu/x86/architecture/architecture.factor | 6 +-
basis/debugger/debugger.factor | 10 +--
basis/help/definitions/definitions.factor | 22 +++---
basis/help/syntax/syntax.factor | 7 +-
basis/help/topics/topics-tests.factor | 2 +-
basis/help/topics/topics.factor | 6 +-
basis/io/ports/ports.factor | 2 +-
basis/models/models-docs.factor | 7 +-
basis/peg/parsers/parsers.factor | 2 +-
basis/prettyprint/backend/backend.factor | 2 +-
basis/prettyprint/prettyprint.factor | 2 +-
basis/prettyprint/sections/sections.factor | 10 +--
basis/tools/vocabs/browser/browser.factor | 12 ++--
core/assocs/assocs.factor | 2 +-
core/classes/mixin/mixin.factor | 13 ++--
core/continuations/continuations.factor | 2 +-
core/io/encodings/encodings.factor | 4 +-
core/source-files/source-files.factor | 4 +-
core/syntax/syntax.factor | 4 +-
core/vocabs/vocabs.factor | 59 ++++++++++++----
31 files changed, 212 insertions(+), 135 deletions(-)
diff --git a/basis/alien/arrays/arrays.factor b/basis/alien/arrays/arrays.factor
index 0f756e0ad0..71c3fd6ff2 100644
--- a/basis/alien/arrays/arrays.factor
+++ b/basis/alien/arrays/arrays.factor
@@ -10,7 +10,7 @@ M: array c-type ;
M: array heap-size unclip heap-size [ * ] reduce ;
-M: array c-type-align first c-type c-type-align ;
+M: array c-type-align first c-type-align ;
M: array c-type-stack-align? drop f ;
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index a9b39f80ab..f44941d88f 100755
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -37,6 +37,7 @@ ERROR: no-c-type name ;
dup string? [ (c-type) ] when
] when ;
+! C type protocol
GENERIC: c-type ( name -- type ) foldable
: resolve-pointer-type ( name -- name )
@@ -62,6 +63,60 @@ M: string c-type ( name -- type )
] ?if
] if ;
+GENERIC: c-type-boxer ( name -- boxer )
+
+M: c-type c-type-boxer boxer>> ;
+
+M: string c-type-boxer c-type c-type-boxer ;
+
+GENERIC: c-type-boxer-quot ( name -- quot )
+
+M: c-type c-type-boxer-quot boxer-quot>> ;
+
+M: string c-type-boxer-quot c-type c-type-boxer-quot ;
+
+GENERIC: c-type-unboxer ( name -- boxer )
+
+M: c-type c-type-unboxer unboxer>> ;
+
+M: string c-type-unboxer c-type c-type-unboxer ;
+
+GENERIC: c-type-unboxer-quot ( name -- quot )
+
+M: c-type c-type-unboxer-quot unboxer-quot>> ;
+
+M: string c-type-unboxer-quot c-type c-type-unboxer-quot ;
+
+GENERIC: c-type-reg-class ( name -- reg-class )
+
+M: c-type c-type-reg-class reg-class>> ;
+
+M: string c-type-reg-class c-type c-type-reg-class ;
+
+GENERIC: c-type-getter ( name -- quot )
+
+M: c-type c-type-getter getter>> ;
+
+M: string c-type-getter c-type c-type-getter ;
+
+GENERIC: c-type-setter ( name -- quot )
+
+M: c-type c-type-setter setter>> ;
+
+M: string c-type-setter c-type c-type-setter ;
+
+GENERIC: c-type-align ( name -- n )
+
+M: c-type c-type-align align>> ;
+
+M: string c-type-align c-type c-type-align ;
+
+GENERIC: c-type-stack-align? ( name -- ? )
+
+M: c-type c-type-stack-align? stack-align?>> ;
+
+M: string c-type-stack-align? c-type c-type-stack-align? ;
+
: c-type-box ( n type -- )
dup c-type-reg-class
swap c-type-boxer [ "No boxer" throw ] unless*
@@ -72,10 +127,6 @@ M: string c-type ( name -- type )
swap c-type-unboxer [ "No unboxer" throw ] unless*
%unbox ;
-M: string c-type-align c-type c-type-align ;
-
-M: string c-type-stack-align? c-type c-type-stack-align? ;
-
GENERIC: box-parameter ( n ctype -- )
M: c-type box-parameter c-type-box ;
@@ -107,25 +158,25 @@ GENERIC: heap-size ( type -- size ) foldable
M: string heap-size c-type heap-size ;
-M: c-type heap-size c-type-size ;
+M: c-type heap-size size>> ;
GENERIC: stack-size ( type -- size ) foldable
M: string stack-size c-type stack-size ;
-M: c-type stack-size c-type-size ;
+M: c-type stack-size size>> ;
GENERIC: byte-length ( seq -- n ) flushable
M: byte-array byte-length length ;
: c-getter ( name -- quot )
- c-type c-type-getter [
+ c-type-getter [
[ "Cannot read struct fields with type" throw ]
] unless* ;
: c-setter ( name -- quot )
- c-type c-type-setter [
+ c-type-setter [
[ "Cannot write struct fields with type" throw ]
] unless* ;
diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor
index 2c464cc74c..6f83885d9f 100755
--- a/basis/alien/structs/structs-docs.factor
+++ b/basis/alien/structs/structs-docs.factor
@@ -1,5 +1,5 @@
IN: alien.structs
-USING: alien.c-types strings help.markup help.syntax
+USING: accessors alien.c-types strings help.markup help.syntax
alien.syntax sequences io arrays slots.deprecated
kernel words slots assocs namespaces accessors ;
@@ -67,7 +67,7 @@ M: word slot-specs "slots" word-prop ;
first dup "writing" word-prop [ slot-specs ] keep
$spec-writer ;
-M: string slot-specs c-type struct-type-fields ;
+M: string slot-specs c-type fields>> ;
M: array ($instance) first ($instance) " array" write ;
diff --git a/basis/alien/structs/structs-tests.factor b/basis/alien/structs/structs-tests.factor
index bfdcd31b99..8c7d9f9b29 100644
--- a/basis/alien/structs/structs-tests.factor
+++ b/basis/alien/structs/structs-tests.factor
@@ -7,7 +7,7 @@ C-STRUCT: bar
{ { "int" 8 } "y" } ;
[ 36 ] [ "bar" heap-size ] unit-test
-[ t ] [ \ <displaced-alien> "bar" c-type c-type-getter memq? ] unit-test
+[ t ] [ \ <displaced-alien> "bar" c-type-getter memq? ] unit-test
C-STRUCT: align-test
{ "int" "x" }
diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor
index 51283e2956..e6a363941d 100755
--- a/basis/alien/structs/structs.factor
+++ b/basis/alien/structs/structs.factor
@@ -6,7 +6,7 @@ slots.deprecated alien.c-types cpu.architecture ;
IN: alien.structs
: align-offset ( offset type -- offset )
- c-type c-type-align align ;
+ c-type-align align ;
: struct-offsets ( specs -- size )
0 [
@@ -24,7 +24,7 @@ IN: alien.structs
[ reader>> ]
[
class>>
- [ c-getter ] [ c-type c-type-boxer-quot ] bi append
+ [ c-getter ] [ c-type-boxer-quot ] bi append
] tri
define-struct-slot-word ;
@@ -44,9 +44,9 @@ IN: alien.structs
TUPLE: struct-type size align fields ;
-M: struct-type heap-size struct-type-size ;
+M: struct-type heap-size size>> ;
-M: struct-type c-type-align struct-type-align ;
+M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;
diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index 08da2ae14b..2388d7b8f0 100755
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors init command-line namespaces words debugger io
+USING: accessors init namespaces words io
kernel.private math memory continuations kernel io.files
io.backend system parser vocabs sequences prettyprint
vocabs.loader combinators splitting source-files strings
definitions assocs compiler.errors compiler.units
-math.parser generic sets ;
+math.parser generic sets debugger command-line ;
IN: bootstrap.stage2
SYMBOL: bootstrap-time
diff --git a/basis/compiler/generator/registers/registers.factor b/basis/compiler/generator/registers/registers.factor
index 2452b19e11..e460f5558b 100755
--- a/basis/compiler/generator/registers/registers.factor
+++ b/basis/compiler/generator/registers/registers.factor
@@ -69,23 +69,21 @@ TUPLE: ds-loc n class ;
: <ds-loc> ( n -- loc ) f ds-loc boa ;
-M: ds-loc minimal-ds-loc* ds-loc-n min ;
-M: ds-loc operand-class* ds-loc-class ;
-M: ds-loc set-operand-class set-ds-loc-class ;
+M: ds-loc minimal-ds-loc* n>> min ;
M: ds-loc live-loc?
- over ds-loc? [ [ ds-loc-n ] bi@ = not ] [ 2drop t ] if ;
+ over ds-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
! A retain stack location.
TUPLE: rs-loc n class ;
: <rs-loc> ( n -- loc ) f rs-loc boa ;
-M: rs-loc operand-class* rs-loc-class ;
-M: rs-loc set-operand-class set-rs-loc-class ;
M: rs-loc live-loc?
- over rs-loc? [ [ rs-loc-n ] bi@ = not ] [ 2drop t ] if ;
+ over rs-loc? [ [ n>> ] bi@ = not ] [ 2drop t ] if ;
UNION: loc ds-loc rs-loc ;
+M: loc operand-class* class>> ;
+M: loc set-operand-class (>>class) ;
M: loc move-spec drop loc ;
INSTANCE: loc value
@@ -106,12 +104,12 @@ M: cached set-operand-class vreg>> set-operand-class ;
M: cached operand-class* vreg>> operand-class* ;
M: cached move-spec drop cached ;
M: cached live-vregs* vreg>> live-vregs* ;
-M: cached live-loc? cached-loc live-loc? ;
+M: cached live-loc? loc>> live-loc? ;
M: cached (lazy-load) >r vreg>> r> (lazy-load) ;
M: cached lazy-store
- 2dup cached-loc live-loc?
+ 2dup loc>> live-loc?
[ "live-locs" get at %move ] [ 2drop ] if ;
-M: cached minimal-ds-loc* cached-loc minimal-ds-loc* ;
+M: cached minimal-ds-loc* loc>> minimal-ds-loc* ;
INSTANCE: cached value
@@ -121,48 +119,48 @@ TUPLE: tagged vreg class ;
: <tagged> ( vreg -- tagged )
f tagged boa ;
-M: tagged v>operand tagged-vreg v>operand ;
-M: tagged set-operand-class set-tagged-class ;
-M: tagged operand-class* tagged-class ;
+M: tagged v>operand vreg>> v>operand ;
+M: tagged set-operand-class (>>class) ;
+M: tagged operand-class* class>> ;
M: tagged move-spec drop f ;
-M: tagged live-vregs* tagged-vreg , ;
+M: tagged live-vregs* vreg>> , ;
INSTANCE: tagged value
! Unboxed alien pointers
TUPLE: unboxed-alien vreg ;
C: <unboxed-alien> unboxed-alien
-M: unboxed-alien v>operand unboxed-alien-vreg v>operand ;
+M: unboxed-alien v>operand vreg>> v>operand ;
M: unboxed-alien operand-class* drop simple-alien ;
M: unboxed-alien move-spec class ;
-M: unboxed-alien live-vregs* unboxed-alien-vreg , ;
+M: unboxed-alien live-vregs* vreg>> , ;
INSTANCE: unboxed-alien value
TUPLE: unboxed-byte-array vreg ;
C: <unboxed-byte-array> unboxed-byte-array
-M: unboxed-byte-array v>operand unboxed-byte-array-vreg v>operand ;
+M: unboxed-byte-array v>operand vreg>> v>operand ;
M: unboxed-byte-array operand-class* drop c-ptr ;
M: unboxed-byte-array move-spec class ;
-M: unboxed-byte-array live-vregs* unboxed-byte-array-vreg , ;
+M: unboxed-byte-array live-vregs* vreg>> , ;
INSTANCE: unboxed-byte-array value
TUPLE: unboxed-f vreg ;
C: <unboxed-f> unboxed-f
-M: unboxed-f v>operand unboxed-f-vreg v>operand ;
+M: unboxed-f v>operand vreg>> v>operand ;
M: unboxed-f operand-class* drop \ f ;
M: unboxed-f move-spec class ;
-M: unboxed-f live-vregs* unboxed-f-vreg , ;
+M: unboxed-f live-vregs* vreg>> , ;
INSTANCE: unboxed-f value
TUPLE: unboxed-c-ptr vreg ;
C: <unboxed-c-ptr> unboxed-c-ptr
-M: unboxed-c-ptr v>operand unboxed-c-ptr-vreg v>operand ;
+M: unboxed-c-ptr v>operand vreg>> v>operand ;
M: unboxed-c-ptr operand-class* drop c-ptr ;
M: unboxed-c-ptr move-spec class ;
-M: unboxed-c-ptr live-vregs* unboxed-c-ptr-vreg , ;
+M: unboxed-c-ptr live-vregs* vreg>> , ;
INSTANCE: unboxed-c-ptr value
diff --git a/basis/cpu/ppc/architecture/architecture.factor b/basis/cpu/ppc/architecture/architecture.factor
index 0b570907ab..00bdb4b7c9 100755
--- a/basis/cpu/ppc/architecture/architecture.factor
+++ b/basis/cpu/ppc/architecture/architecture.factor
@@ -1,10 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types cpu.ppc.assembler cpu.architecture generic
-kernel kernel.private math memory namespaces sequences words
-assocs compiler.generator compiler.generator.registers
-compiler.generator.fixup system layouts classes words.private
-alien combinators compiler.constants math.order ;
+USING: accessors alien.c-types cpu.ppc.assembler
+cpu.architecture generic kernel kernel.private math memory
+namespaces sequences words assocs compiler.generator
+compiler.generator.registers compiler.generator.fixup system
+layouts classes words.private alien combinators
+compiler.constants math.order ;
IN: cpu.ppc.architecture
! PowerPC register assignments
@@ -65,8 +66,8 @@ M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
GENERIC: loc>operand ( loc -- reg n )
-M: ds-loc loc>operand ds-loc-n cells neg ds-reg swap ;
-M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
+M: ds-loc loc>operand n>> cells neg ds-reg swap ;
+M: rs-loc loc>operand n>> cells neg rs-reg swap ;
M: immediate load-literal
[ v>operand ] bi@ LOAD ;
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index eede86085b..1577945118 100755
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -1,14 +1,15 @@
-USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture
-namespaces alien.c-types kernel system combinators ;
+USING: accessors cpu.ppc.architecture cpu.ppc.intrinsics
+cpu.architecture namespaces alien.c-types kernel system
+combinators ;
{
{ [ os macosx? ] [
- 4 "longlong" c-type set-c-type-align
- 4 "ulonglong" c-type set-c-type-align
- 4 "double" c-type set-c-type-align
+ 4 "longlong" c-type (>>align)
+ 4 "ulonglong" c-type (>>align)
+ 4 "double" c-type (>>align)
] }
{ [ os linux? ] [
- t "longlong" c-type set-c-type-stack-align?
- t "ulonglong" c-type set-c-type-stack-align?
+ t "longlong" c-type (>>stack-align?)
+ t "ulonglong" c-type (>>stack-align?)
] }
} cond
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 504707777a..6f255893db 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -259,9 +259,9 @@ M: x86.32 %cleanup ( alien-node -- )
M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
os windows? [
- cell "longlong" c-type set-c-type-align
- cell "ulonglong" c-type set-c-type-align
- 4 "double" c-type set-c-type-align
+ cell "longlong" c-type (>>align)
+ cell "ulonglong" c-type (>>align)
+ 4 "double" c-type (>>align)
] unless
: (sse2?) ( -- ? ) "Intrinsic" throw ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 0ba3b93730..c1697f1d98 100755
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -174,10 +174,10 @@ USE: cpu.x86.intrinsics
! The ABI for passing structs by value is pretty messed up
<< "void*" c-type clone "__stack_value" define-primitive-type
-stack-params "__stack_value" c-type set-c-type-reg-class >>
+stack-params "__stack_value" c-type (>>reg-class) >>
: struct-types&offset ( struct-type -- pairs )
- struct-type-fields [
+ fields>> [
[ class>> ] [ offset>> ] bi 2array
] map ;
diff --git a/basis/cpu/x86/architecture/architecture.factor b/basis/cpu/x86/architecture/architecture.factor
index 52ad68baf1..69bc685364 100755
--- a/basis/cpu/x86/architecture/architecture.factor
+++ b/basis/cpu/x86/architecture/architecture.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays cpu.x86.assembler
+USING: accessors alien alien.c-types arrays cpu.x86.assembler
cpu.x86.assembler.private cpu.architecture kernel kernel.private
math memory namespaces sequences words compiler.generator
compiler.generator.registers compiler.generator.fixup system
@@ -16,8 +16,8 @@ HOOK: stack-save-reg cpu ( -- reg )
: reg-stack ( n reg -- op ) swap cells neg [+] ;
-M: ds-loc v>operand ds-loc-n ds-reg reg-stack ;
-M: rs-loc v>operand rs-loc-n rs-reg reg-stack ;
+M: ds-loc v>operand n>> ds-reg reg-stack ;
+M: rs-loc v>operand n>> rs-reg reg-stack ;
M: int-regs %save-param-reg drop >r stack@ r> MOV ;
M: int-regs %load-param-reg drop swap stack@ MOV ;
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 51ef806ebe..06c410c0e4 100755
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -207,7 +207,7 @@ M: no-case summary
M: slice-error error.
"Cannot create slice because " write
- slice-error-reason print ;
+ reason>> print ;
M: bounds-error summary drop "Sequence index out of bounds" ;
@@ -232,14 +232,14 @@ M: immutable summary drop "Sequence is immutable" ;
M: redefine-error error.
"Re-definition of " write
- redefine-error-def . ;
+ def>> . ;
M: undefined summary
drop "Calling a deferred word before it has been defined" ;
M: no-compilation-unit error.
"Attempting to define " write
- no-compilation-unit-definition pprint
+ definition>> pprint
" outside of a compilation unit" print ;
M: no-vocab summary
@@ -299,9 +299,9 @@ M: string expected>string ;
M: unexpected error.
"Expected " write
- dup unexpected-want expected>string write
+ dup want>> expected>string write
" but got " write
- unexpected-got expected>string print ;
+ got>> expected>string print ;
M: lexer-error error.
[ lexer-dump ] [ error>> error. ] bi ;
diff --git a/basis/help/definitions/definitions.factor b/basis/help/definitions/definitions.factor
index 4d942ae3a9..e5202e1306 100755
--- a/basis/help/definitions/definitions.factor
+++ b/basis/help/definitions/definitions.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: definitions help help.topics help.syntax
+USING: accessors definitions help help.topics help.syntax
prettyprint.backend prettyprint words kernel effects ;
IN: help.definitions
@@ -8,30 +8,30 @@ IN: help.definitions
M: link definer drop \ ARTICLE: \ ; ;
-M: link where link-name article article-loc ;
+M: link where name>> article loc>> ;
-M: link set-where link-name article set-article-loc ;
+M: link set-where name>> article (>>loc) ;
-M: link forget* link-name remove-article ;
+M: link forget* name>> remove-article ;
M: link definition article-content ;
M: link synopsis*
dup definer.
- dup link-name pprint*
+ dup name>> pprint*
article-title pprint* ;
M: word-link definer drop \ HELP: \ ; ;
-M: word-link where link-name "help-loc" word-prop ;
+M: word-link where name>> "help-loc" word-prop ;
-M: word-link set-where link-name swap "help-loc" set-word-prop ;
+M: word-link set-where name>> swap "help-loc" set-word-prop ;
-M: word-link definition link-name "help" word-prop ;
+M: word-link definition name>> "help" word-prop ;
M: word-link synopsis*
dup definer.
- link-name dup pprint-word
+ name>> dup pprint-word
stack-effect. ;
-M: word-link forget* link-name remove-word-help ;
+M: word-link forget* name>> remove-word-help ;
diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor
index 65120a5d01..42d5ba1781 100755
--- a/basis/help/syntax/syntax.factor
+++ b/basis/help/syntax/syntax.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel parser sequences words help help.topics
-namespaces vocabs definitions compiler.units ;
+USING: accessors arrays kernel parser sequences words help
+help.topics namespaces vocabs definitions compiler.units ;
IN: help.syntax
: HELP:
@@ -16,7 +16,6 @@ IN: help.syntax
over add-article >link r> remember-definition ; parsing
: ABOUT:
- scan-object
in get vocab
dup changed-definition
- set-vocab-help ; parsing
+ scan-object >>help drop ; parsing
diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor
index 745988c077..c52d5e347f 100644
--- a/basis/help/topics/topics-tests.factor
+++ b/basis/help/topics/topics-tests.factor
@@ -34,6 +34,6 @@ SYMBOL: foo
] unit-test
[ { "testfile" 2 } ]
-[ { "test" 1 } articles get at article-loc ] unit-test
+[ { "test" 1 } articles get at loc>> ] unit-test
[ ] [ { "test" 1 } remove-article ] unit-test
diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor
index 14a6c3f8ad..cdb32b18ee 100755
--- a/basis/help/topics/topics.factor
+++ b/basis/help/topics/topics.factor
@@ -34,6 +34,8 @@ SYMBOL: article-xref
article-xref global [ H{ } assoc-like ] change-at
GENERIC: article-name ( topic -- string )
+GENERIC: article-title ( topic -- string )
+GENERIC: article-content ( topic -- content )
GENERIC: article-parent ( topic -- parent )
GENERIC: set-article-parent ( parent topic -- )
@@ -42,7 +44,9 @@ TUPLE: article title content loc ;
: <article> ( title content -- article )
f \ article boa ;
-M: article article-name article-title ;
+M: article article-name title>> ;
+M: article article-title title>> ;
+M: article article-content content>> ;
ERROR: no-article name ;
diff --git a/basis/io/ports/ports.factor b/basis/io/ports/ports.factor
index 006e0e7881..909b2dcf3b 100755
--- a/basis/io/ports/ports.factor
+++ b/basis/io/ports/ports.factor
@@ -109,7 +109,7 @@ M: output-port stream-write1
M: output-port stream-write
dup check-disposed
- over length over buffer>> buffer-size > [
+ over length over buffer>> size>> > [
[ buffer>> size>> <groups> ]
[ [ stream-write ] curry ] bi
each
diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor
index 8decf3251c..97e4557ada 100755
--- a/basis/models/models-docs.factor
+++ b/basis/models/models-docs.factor
@@ -63,12 +63,7 @@ HELP: set-model
{ $values { "value" object } { "model" model } }
{ $description "Changes the value of a model and calls " { $link model-changed } " on all observers registered with " { $link add-connection } "." } ;
-{ set-model set-model-value change-model (change-model) } related-words
-
-HELP: set-model-value ( value model -- )
-{ $values { "value" object } { "model" model } }
-{ $description "Changes the value of a model 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 set-model } ", which notifies observers." } ;
+{ set-model change-model (change-model) } related-words
HELP: change-model
{ $values { "model" model } { "quot" "a quotation with stack effect " { $snippet "( obj -- newobj )" } } }
diff --git a/basis/peg/parsers/parsers.factor b/basis/peg/parsers/parsers.factor
index 6342deb79e..93de40d672 100755
--- a/basis/peg/parsers/parsers.factor
+++ b/basis/peg/parsers/parsers.factor
@@ -17,7 +17,7 @@ TUPLE: just-parser p1 ;
M: just-parser (compile) ( parser -- quot )
- just-parser-p1 compile-parser just-pattern curry ;
+ p1>> compile-parser just-pattern curry ;
: just ( parser -- parser )
just-parser boa wrap-peg ;
diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor
index 111bcfdafc..8e5e932666 100755
--- a/basis/prettyprint/backend/backend.factor
+++ b/basis/prettyprint/backend/backend.factor
@@ -105,7 +105,7 @@ M: sbuf pprint*
dup "SBUF\" " "\"" pprint-string ;
M: pathname pprint*
- dup pathname-string "P\" " "\"" pprint-string ;
+ dup string>> "P\" " "\"" pprint-string ;
! Sequences
: nesting-limit? ( -- ? )
diff --git a/basis/prettyprint/prettyprint.factor b/basis/prettyprint/prettyprint.factor
index 49881f2e9f..63a44d85d4 100755
--- a/basis/prettyprint/prettyprint.factor
+++ b/basis/prettyprint/prettyprint.factor
@@ -172,7 +172,7 @@ M: hook-generic synopsis*
[ definer. ]
[ seeing-word ]
[ pprint-word ]
- [ "combination" word-prop hook-combination-var pprint* ]
+ [ "combination" word-prop var>> pprint* ]
[ stack-effect. ]
} cleave ;
diff --git a/basis/prettyprint/sections/sections.factor b/basis/prettyprint/sections/sections.factor
index aed476b5c6..13c86ea994 100644
--- a/basis/prettyprint/sections/sections.factor
+++ b/basis/prettyprint/sections/sections.factor
@@ -205,7 +205,7 @@ TUPLE: text < section string ;
swap >>style
swap >>string ;
-M: text short-section text-string write ;
+M: text short-section string>> write ;
M: text long-section short-section ;
@@ -291,17 +291,13 @@ SYMBOL: next
: split-groups ( ? -- ) [ t , ] when ;
-M: f section-start-group? drop t ;
-
-M: f section-end-group? drop f ;
-
: split-before ( section -- )
- [ section-start-group? prev get section-end-group? and ]
+ [ start-group?>> prev get [ end-group?>> ] [ t ] if* and ]
[ flow? prev get flow? not and ]
bi or split-groups ;
: split-after ( section -- )
- section-end-group? split-groups ;
+ [ end-group?>> ] [ f ] if* split-groups ;
: group-flow ( seq -- newseq )
[
diff --git a/basis/tools/vocabs/browser/browser.factor b/basis/tools/vocabs/browser/browser.factor
index 55a96c8b7d..a771a35735 100755
--- a/basis/tools/vocabs/browser/browser.factor
+++ b/basis/tools/vocabs/browser/browser.factor
@@ -181,12 +181,12 @@ M: vocab-spec article-parent drop "vocab-index" ;
M: vocab-tag >link ;
M: vocab-tag article-title
- vocab-tag-name "Vocabularies tagged ``" swap "''" 3append ;
+ name>> "Vocabularies tagged ``" swap "''" 3append ;
-M: vocab-tag article-name vocab-tag-name ;
+M: vocab-tag article-name name>> ;
M: vocab-tag article-content
- \ $tagged-vocabs swap vocab-tag-name 2array ;
+ \ $tagged-vocabs swap name>> 2array ;
M: vocab-tag article-parent drop "vocab-index" ;
@@ -195,12 +195,12 @@ M: vocab-tag summary article-title ;
M: vocab-author >link ;
M: vocab-author article-title
- vocab-author-name "Vocabularies by " prepend ;
+ name>> "Vocabularies by " prepend ;
-M: vocab-author article-name vocab-author-name ;
+M: vocab-author article-name name>> ;
M: vocab-author article-content
- \ $authored-vocabs swap vocab-author-name 2array ;
+ \ $authored-vocabs swap name>> 2array ;
M: vocab-author article-parent drop "vocab-index" ;
diff --git a/core/assocs/assocs.factor b/core/assocs/assocs.factor
index 56567fab85..7415bd0eb2 100755
--- a/core/assocs/assocs.factor
+++ b/core/assocs/assocs.factor
@@ -210,7 +210,7 @@ M: enum at*
M: enum set-at seq>> set-nth ;
-M: enum delete-at enum-seq delete-nth ;
+M: enum delete-at seq>> delete-nth ;
M: enum >alist ( enum -- alist )
seq>> [ length ] keep zip ;
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index a7770e2eb2..3a92d5193c 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -78,8 +78,8 @@ TUPLE: mixin-instance loc class mixin ;
M: mixin-instance equal?
{
{ [ over mixin-instance? not ] [ f ] }
- { [ 2dup [ mixin-instance-class ] bi@ = not ] [ f ] }
- { [ 2dup [ mixin-instance-mixin ] bi@ = not ] [ f ] }
+ { [ 2dup [ class>> ] bi@ = not ] [ f ] }
+ { [ 2dup [ mixin>> ] bi@ = not ] [ f ] }
[ t ]
} cond 2nip ;
@@ -91,15 +91,14 @@ M: mixin-instance hashcode*
swap >>mixin
swap >>class ;
-M: mixin-instance where mixin-instance-loc ;
+M: mixin-instance where loc>> ;
-M: mixin-instance set-where set-mixin-instance-loc ;
+M: mixin-instance set-where (>>loc) ;
M: mixin-instance definer drop \ INSTANCE: f ;
M: mixin-instance definition drop f ;
M: mixin-instance forget*
- dup mixin-instance-class
- swap mixin-instance-mixin dup mixin-class?
- [ remove-mixin-instance ] [ 2drop ] if ;
+ [ class>> ] [ mixin>> ] bi
+ mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;
diff --git a/core/continuations/continuations.factor b/core/continuations/continuations.factor
index 1d3c061a42..bfa3848186 100755
--- a/core/continuations/continuations.factor
+++ b/core/continuations/continuations.factor
@@ -178,7 +178,7 @@ M: condition compute-restarts
[ error>> compute-restarts ]
[
[ restarts>> ]
- [ condition-continuation [ <restart> ] curry ] bi
+ [ continuation>> [ <restart> ] curry ] bi
{ } assoc>map
] bi append ;
diff --git a/core/io/encodings/encodings.factor b/core/io/encodings/encodings.factor
index 15ee233dbc..36cec298bd 100755
--- a/core/io/encodings/encodings.factor
+++ b/core/io/encodings/encodings.factor
@@ -130,9 +130,9 @@ M: encoder stream-write1
M: encoder stream-write
>encoder< decoder-write ;
-M: encoder dispose encoder-stream dispose ;
+M: encoder dispose stream>> dispose ;
-M: encoder stream-flush encoder-stream stream-flush ;
+M: encoder stream-flush stream>> stream-flush ;
INSTANCE: encoder plain-writer
PRIVATE>
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index aa2cd563a5..767c2a1f79 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -56,7 +56,7 @@ ERROR: invalid-source-file-path path ;
] [ 2drop ] if
] assoc-each ;
-M: pathname where pathname-string 1 2array ;
+M: pathname where string>> 1 2array ;
: forget-source ( path -- )
[
@@ -69,7 +69,7 @@ M: pathname where pathname-string 1 2array ;
bi ;
M: pathname forget*
- pathname-string forget-source ;
+ string>> forget-source ;
: rollback-source-file ( file -- )
[
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index ce84943328..e156832923 100755
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays byte-arrays byte-vectors
+USING: accessors alien arrays byte-arrays byte-vectors
definitions generic hashtables kernel math namespaces parser
lexer sequences strings strings.parser sbufs vectors
words quotations io assocs splitting classes.tuple
@@ -193,7 +193,7 @@ IN: bootstrap.syntax
"))" parse-effect parsed
] define-syntax
- "MAIN:" [ scan-word in get vocab set-vocab-main ] define-syntax
+ "MAIN:" [ scan-word in get vocab (>>main) ] define-syntax
"<<" [
[
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index fedd6de3b7..1bdbe3ce14 100755
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -16,44 +16,78 @@ source-loaded? docs-loaded? ;
swap >>name
H{ } clone >>words ;
+GENERIC: vocab-name ( vocab-spec -- name )
+
GENERIC: vocab ( vocab-spec -- vocab )
M: vocab vocab ;
M: object vocab ( name -- vocab ) vocab-name dictionary get at ;
+M: vocab vocab-name name>> ;
+
M: string vocab-name ;
+GENERIC: vocab-words ( vocab-spec -- words )
+
+M: vocab vocab-words words>> ;
+
M: object vocab-words vocab vocab-words ;
+M: f vocab-words ;
+
+GENERIC: vocab-help ( vocab-spec -- help )
+
+M: vocab vocab-help help>> ;
+
M: object vocab-help vocab vocab-help ;
+M: f vocab-help ;
+
+GENERIC: vocab-main ( vocab-spec -- main )
+
+M: vocab vocab-main main>> ;
+
M: object vocab-main vocab vocab-main ;
+M: f vocab-main ;
+
+GENERIC: vocab-source-loaded? ( vocab-spec -- ? )
+
+M: vocab vocab-source-loaded? source-loaded?>> ;
+
M: object vocab-source-loaded?
vocab vocab-source-loaded? ;
+M: f vocab-source-loaded? ;
+
+GENERIC: set-vocab-source-loaded? ( ? vocab-spec -- )
+
+M: vocab set-vocab-source-loaded? (>>source-loaded?) ;
+
M: object set-vocab-source-loaded?
vocab set-vocab-source-loaded? ;
+M: f set-vocab-source-loaded? 2drop ;
+
+GENERIC: vocab-docs-loaded? ( vocab-spec -- ? )
+
+M: vocab vocab-docs-loaded? docs-loaded?>> ;
+
M: object vocab-docs-loaded?
vocab vocab-docs-loaded? ;
+M: f vocab-docs-loaded? ;
+
+GENERIC: set-vocab-docs-loaded? ( ? vocab-spec -- )
+
+M: vocab set-vocab-docs-loaded? (>>docs-loaded?) ;
+
M: object set-vocab-docs-loaded?
vocab set-vocab-docs-loaded? ;
-M: f vocab-words ;
-
-M: f vocab-source-loaded? ;
-
-M: f set-vocab-source-loaded? 2drop ;
-
-M: f vocab-docs-loaded? ;
-
M: f set-vocab-docs-loaded? 2drop ;
-M: f vocab-help ;
-
: create-vocab ( name -- vocab )
dictionary get [ <vocab> ] cache ;
@@ -90,10 +124,9 @@ TUPLE: vocab-link name ;
: <vocab-link> ( name -- vocab-link )
vocab-link boa ;
-M: vocab-link hashcode*
- vocab-link-name hashcode* ;
+M: vocab-link hashcode* name>> hashcode* ;
-M: vocab-link vocab-name vocab-link-name ;
+M: vocab-link vocab-name name>> ;
UNION: vocab-spec vocab vocab-link ;
From 20380e613ec483ac4e54570f0f2cf0e7ad8c2344 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 07:55:34 -0500
Subject: [PATCH 24/46] Fix typo
---
core/classes/mixin/mixin.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor
index 3a92d5193c..56e995899b 100755
--- a/core/classes/mixin/mixin.factor
+++ b/core/classes/mixin/mixin.factor
@@ -101,4 +101,4 @@ M: mixin-instance definition drop f ;
M: mixin-instance forget*
[ class>> ] [ mixin>> ] bi
- mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;
+ dup mixin-class? [ remove-mixin-instance ] [ 2drop ] if ;
From 9389f3091c232dee2a4beaaa0869b8cc18387ec7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 08:12:27 -0500
Subject: [PATCH 25/46] Fix a bug in help lint
---
basis/help/lint/lint.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index 61d9827a48..14d3420a68 100755
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -131,7 +131,7 @@ M: help-error error.
: run-help-lint ( prefix -- alist )
[
all-vocabs-seq [ vocab-name ] map "all-vocabs" set
- articles get keys "group-articles" set
+ group-articles "vocab-articles" set
child-vocabs
[ dup check-vocab ] { } map>assoc
[ nip empty? not ] assoc-filter
From 6717d3743e1e3ed43d9cf8ff5e0e0da601ff6b17 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 09:03:03 -0500
Subject: [PATCH 26/46] Fix escape analysis bug; speedup on fib4 benchmark
---
.../allocations/allocations.factor | 3 +++
.../recursive/recursive.factor | 24 ++++++++++---------
.../tree/escape-analysis/simple/simple.factor | 2 +-
.../tree/normalization/normalization.factor | 3 ++-
.../tuple-unboxing-tests.factor | 7 ++++++
extra/benchmark/fib4/fib4.factor | 6 ++---
6 files changed, 29 insertions(+), 16 deletions(-)
diff --git a/basis/compiler/tree/escape-analysis/allocations/allocations.factor b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
index 100ced5acd..4c197d7fc0 100644
--- a/basis/compiler/tree/escape-analysis/allocations/allocations.factor
+++ b/basis/compiler/tree/escape-analysis/allocations/allocations.factor
@@ -103,6 +103,9 @@ DEFER: copy-value
[ [ allocation copy-allocation ] dip record-allocation ]
2bi ;
+: copy-values ( from to -- )
+ [ copy-value ] 2each ;
+
: copy-slot-value ( out slot# in -- )
allocation {
{ [ dup not ] [ 3drop ] }
diff --git a/basis/compiler/tree/escape-analysis/recursive/recursive.factor b/basis/compiler/tree/escape-analysis/recursive/recursive.factor
index 3d8d15e5ec..059ac1de02 100644
--- a/basis/compiler/tree/escape-analysis/recursive/recursive.factor
+++ b/basis/compiler/tree/escape-analysis/recursive/recursive.factor
@@ -42,24 +42,26 @@ IN: compiler.tree.escape-analysis.recursive
] 2bi ;
M: #recursive escape-analysis* ( #recursive -- )
+ [ label>> return>> in-d>> introduce-values ]
[
- child>>
- [ first out-d>> introduce-values ]
- [ first analyze-recursive-phi ]
- [ (escape-analysis) ]
- tri
- ] until-fixed-point ;
+ [
+ child>>
+ [ first out-d>> introduce-values ]
+ [ first analyze-recursive-phi ]
+ [ (escape-analysis) ]
+ tri
+ ] until-fixed-point
+ ] bi ;
M: #enter-recursive escape-analysis* ( #enter-recursive -- )
#! Handled by #recursive
drop ;
-: return-allocations ( node -- allocations )
- label>> return>> node-input-allocations ;
-
M: #call-recursive escape-analysis* ( #call-label -- )
- [ ] [ return-allocations ] [ node-output-allocations ] tri
- [ check-fixed-point ] [ drop swap out-d>> record-allocations ] 3bi ;
+ [ ] [ label>> return>> ] [ node-output-allocations ] tri
+ [ [ node-input-allocations ] dip check-fixed-point ]
+ [ drop swap [ in-d>> ] [ out-d>> ] bi* copy-values ]
+ 3bi ;
M: #return-recursive escape-analysis* ( #return-recursive -- )
[ call-next-method ]
diff --git a/basis/compiler/tree/escape-analysis/simple/simple.factor b/basis/compiler/tree/escape-analysis/simple/simple.factor
index 58d721b602..d69f6cab9e 100644
--- a/basis/compiler/tree/escape-analysis/simple/simple.factor
+++ b/basis/compiler/tree/escape-analysis/simple/simple.factor
@@ -13,7 +13,7 @@ IN: compiler.tree.escape-analysis.simple
M: #terminate escape-analysis* drop ;
-M: #renaming escape-analysis* inputs/outputs [ copy-value ] 2each ;
+M: #renaming escape-analysis* inputs/outputs copy-values ;
M: #introduce escape-analysis* out-d>> unknown-allocations ;
diff --git a/basis/compiler/tree/normalization/normalization.factor b/basis/compiler/tree/normalization/normalization.factor
index 98ec4ee3f0..12c7a60ec8 100644
--- a/basis/compiler/tree/normalization/normalization.factor
+++ b/basis/compiler/tree/normalization/normalization.factor
@@ -204,5 +204,6 @@ M: node normalize* ;
H{ } clone rename-map set
dup [ collect-label-info ] each-node
dup count-introductions make-values
- [ (normalize) ] [ nip #introduce ] 2bi prefix
+ [ (normalize) ] [ nip ] 2bi
+ dup empty? [ drop ] [ #introduce prefix ] if
rename-node-values ;
diff --git a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
index 8135572bb1..334fcb11f0 100644
--- a/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
+++ b/basis/compiler/tree/tuple-unboxing/tuple-unboxing-tests.factor
@@ -46,3 +46,10 @@ TUPLE: empty-tuple ;
[ bleach-node ] curry [ ] compose impeach-node ; inline recursive
[ ] [ [ [ ] bleach-node ] test-unboxing ] unit-test
+
+TUPLE: box { i read-only } ;
+
+: box-test ( m -- n )
+ dup box-test i>> swap box-test drop box boa ; inline recursive
+
+[ ] [ [ T{ box f 34 } box-test i>> ] test-unboxing ] unit-test
diff --git a/extra/benchmark/fib4/fib4.factor b/extra/benchmark/fib4/fib4.factor
index 580be0d0ec..c988e5722e 100644
--- a/extra/benchmark/fib4/fib4.factor
+++ b/extra/benchmark/fib4/fib4.factor
@@ -1,7 +1,7 @@
USING: accessors math kernel debugger ;
IN: benchmark.fib4
-TUPLE: box i ;
+TUPLE: box { i read-only } ;
C: <box> box
@@ -15,8 +15,8 @@ C: <box> box
i>> 1- <box>
tuple-fib
swap i>> swap i>> + <box>
- ] if ;
+ ] if ; inline recursive
-: fib-main ( -- ) T{ box f 34 } tuple-fib T{ box f 9227465 } assert= ;
+: fib-main ( -- ) T{ box f 34 } tuple-fib i>> 9227465 assert= ;
MAIN: fib-main
From 18d629a916970773f417263dd9be15e88d6ee8fb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 09:22:36 -0500
Subject: [PATCH 27/46] Add failing unit test
---
basis/compiler/tests/folding.factor | 30 +++++++++++++++++++++++++++++
1 file changed, 30 insertions(+)
create mode 100644 basis/compiler/tests/folding.factor
diff --git a/basis/compiler/tests/folding.factor b/basis/compiler/tests/folding.factor
new file mode 100644
index 0000000000..d6868fd034
--- /dev/null
+++ b/basis/compiler/tests/folding.factor
@@ -0,0 +1,30 @@
+USING: eval tools.test compiler.units vocabs multiline words
+kernel classes.mixin arrays ;
+IN: compiler.tests
+
+! Calls to generic words were not folded away.
+
+[ ] [ [ "compiler.tests.redefine11" forget-vocab ] with-compilation-unit ] unit-test
+
+[ ] [
+ <"
+ USING: math arrays ;
+ IN: compiler.tests.folding
+ GENERIC: foldable-generic ( a -- b ) foldable
+ M: integer foldable-generic f <array> ;
+ "> eval
+] unit-test
+
+[ ] [
+ <"
+ USING: math arrays ;
+ IN: compiler.tests.folding
+ : fold-test ( -- x ) 10 foldable-generic ;
+ "> eval
+] unit-test
+
+[ t ] [
+ "fold-test" "compiler.tests.folding" lookup execute
+ "fold-test" "compiler.tests.folding" lookup execute
+ eq?
+] unit-test
From cb69b593c9304d5ad2035ea9acc505f6f5d45ac0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 10:09:21 -0500
Subject: [PATCH 28/46] use bi
---
basis/help/markup/markup.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index e3cefb7992..d65eb8fc88 100755
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -143,13 +143,13 @@ M: f print-element drop ;
link-style get [ write-object ] with-style ;
: ($link) ( article -- )
- [ dup article-name swap >link write-link ] ($span) ;
+ [ [ article-name ] [ >link ] bi write-link ] ($span) ;
: $link ( element -- )
first ($link) ;
: ($long-link) ( object -- )
- dup article-title swap >link write-link ;
+ [ article-title ] [ >link ] bi write-link ;
: ($subsection) ( element quot -- )
[
From 12adca0b1d4d4104be7af176fb2b79bec38fd9f9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 10:09:35 -0500
Subject: [PATCH 29/46] fix docs
---
basis/models/compose/compose-docs.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/models/compose/compose-docs.factor b/basis/models/compose/compose-docs.factor
index 8c07b2f09e..0f88499618 100755
--- a/basis/models/compose/compose-docs.factor
+++ b/basis/models/compose/compose-docs.factor
@@ -20,7 +20,7 @@ $nl
HELP: <compose>
{ $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." }
+{ $description "Creates a new instance of " { $link compose } ". The value of the new compose model is obtained by mapping the " { $snippet "value" } " slot accessor over the given sequence of models." }
{ $examples "See the example in the documentation for " { $link compose } "." } ;
ARTICLE: "models-compose" "Composed models"
From 1cc5f7eb41bd7929e10c6ccc0c40170d249c0426 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 12:59:27 -0500
Subject: [PATCH 30/46] beginning-of-day -> midnight, add noon word, docs
---
basis/calendar/calendar-docs.factor | 101 +++++++++++++++++++++++++++-
basis/calendar/calendar.factor | 19 +++---
2 files changed, 110 insertions(+), 10 deletions(-)
diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor
index 19427b7c79..734c19f045 100644
--- a/basis/calendar/calendar-docs.factor
+++ b/basis/calendar/calendar-docs.factor
@@ -28,4 +28,103 @@ HELP: <date>
HELP: month-names
{ $values { "array" array } }
-{ $description "Returns an array with the English names of all the months. January has a index of 1 instead of 0." } ;
+{ $description "Returns an array with the English names of all the months." }
+{ $warning "Do not use this array for looking up a month name directly. Use month-name instead." } ;
+
+HELP: month-name
+{ $values { "n" integer } { "string" string } }
+{ $description "Looks up the month name and returns it as a string. January has an index of 1 instead of zero." } ;
+
+HELP: month-abbreviations
+{ $values { "array" array } }
+{ $description "Returns an array with the English abbreviated names of all the months." }
+{ $warning "Do not use this array for looking up a month name directly. Use month-abbreviation instead." } ;
+
+HELP: month-abbreviation
+{ $values { "n" integer } { "string" string } }
+{ $description "Looks up the abbreviated month name and returns it as a string. January has an index of 1 instead of zero." } ;
+
+
+HELP: day-names
+{ $values { "array" array } }
+{ $description "Returns an array with the English names of the days of the week." } ;
+
+HELP: day-name
+{ $values { "n" integer } { "string" string } }
+{ $description "Looks up the day name and returns it as a string." } ;
+
+HELP: day-abbreviations2
+{ $values { "array" array } }
+{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is two characters long." } ;
+
+HELP: day-abbreviation2
+{ $values { "n" integer } { "string" string } }
+{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is two characters long." } ;
+
+HELP: day-abbreviations3
+{ $values { "array" array } }
+{ $description "Returns an array with the abbreviated English names of the days of the week. This abbreviation is three characters long." } ;
+
+HELP: day-abbreviation3
+{ $values { "n" integer } { "string" string } }
+{ $description "Looks up the abbreviated day name and returns it as a string. This abbreviation is three characters long." } ;
+
+{
+ day-name day-names
+ day-abbreviation2 day-abbreviations2
+ day-abbreviation3 day-abbreviations3
+} related-words
+
+HELP: average-month
+{ $values { "ratio" ratio } }
+{ $description "The length of an average month averaged over 400 years. Used internally for adding an arbitrary real number of months to a timestamp." } ;
+
+HELP: months-per-year
+{ $values { "integer" integer } }
+{ $description "Returns the number of months in a year." } ;
+
+HELP: days-per-year
+{ $values { "ratio" ratio } }
+{ $description "Returns the number of days in a year averaged over 400 years. Used internally for adding an arbitrary real number of days to a timestamp." } ;
+
+HELP: hours-per-year
+{ $values { "ratio" ratio } }
+{ $description "Returns the number of hours in a year averaged over 400 years. Used internally for adding an arbitrary real number of hours to a timestamp." } ;
+
+HELP: minutes-per-year
+{ $values { "ratio" ratio } }
+{ $description "Returns the number of minutes in a year averaged over 400 years. Used internally for adding an arbitrary real number of minutes to a timestamp." } ;
+
+HELP: seconds-per-year
+{ $values { "integer" integer } }
+{ $description "Returns the number of seconds in a year averaged over 400 years. Used internally for adding an arbitrary real number of seconds to a timestamp." } ;
+
+HELP: julian-day-number
+{ $values { "year" integer } { "month" integer } { "day" integer } { "n" integer } }
+{ $description "Calculates the Julian day number from a year, month, and day. The difference between two Julian day numbers is the number of days that have elapsed between the two corresponding dates." }
+{ $warning "Not valid before year -4800 BCE." } ;
+
+HELP: julian-day-number>date
+{ $values { "n" integer } { "year" integer } { "month" integer } { "day" integer } }
+{ $description "Converts from a Julian day number back to a year, month, and day." } ;
+{ julian-day-number julian-day-number>date } related-words
+
+HELP: >date<
+{ $values { "timestamp" timestamp } { "year" integer } { "month" integer } { "day" integer } }
+{ $description "Explodes a " { $snippet "timestamp" } " into its year, month, and day components." }
+{ $examples { $example "USING: arrays calendar prettyprint ;"
+ "2010 8 24 <date> >date< 3array ."
+ "{ 2010 8 24 }"
+ }
+} ;
+
+HELP: >time<
+{ $values { "timestamp" timestamp } { "hour" integer } { "minute" integer } { "second" integer } }
+{ $description "Explodes a " { $snippet "timestamp" } " into its hour, minute, and second components." }
+{ $examples { $example "USING: arrays calendar prettyprint ;"
+ "now noon >time< 3array ."
+ "{ 12 0 0 }"
+ }
+} ;
+
+{ >date< >time< } related-words
diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index 402542de3b..af0ced7ed2 100755
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -57,7 +57,7 @@ PRIVATE>
"Jul" "Aug" "Sep" "Oct" "Nov" "Dec"
} ;
-: month-abbreviation ( n -- array )
+: month-abbreviation ( n -- string )
check-month 1- month-abbreviations nth ;
: day-names ( -- array )
@@ -377,23 +377,24 @@ M: timestamp days-in-year ( timestamp -- n ) year>> days-in-year ;
: friday ( timestamp -- timestamp ) 5 day-this-week ;
: saturday ( timestamp -- timestamp ) 6 day-this-week ;
-: beginning-of-day ( timestamp -- new-timestamp )
- clone
- 0 >>hour
- 0 >>minute
- 0 >>second ; inline
+: midnight ( timestamp -- new-timestamp )
+ clone 0 >>hour 0 >>minute 0 >>second ; inline
+
+: noon ( timestamp -- new-timestamp )
+ midnight 12 >>hour ; inline
: beginning-of-month ( timestamp -- new-timestamp )
- beginning-of-day 1 >>day ;
+ midnight 1 >>day ;
: beginning-of-week ( timestamp -- new-timestamp )
- beginning-of-day sunday ;
+ midnight sunday ;
: beginning-of-year ( timestamp -- new-timestamp )
beginning-of-month 1 >>month ;
: time-since-midnight ( timestamp -- duration )
- dup beginning-of-day time- ;
+ dup midnight time- ;
+
M: timestamp sleep-until timestamp>millis sleep-until ;
From 36828477f76cfeaecde0a08fca9d88e4ab0b3457 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 15:54:00 -0500
Subject: [PATCH 31/46] more docs
---
basis/calendar/calendar-docs.factor | 75 ++++++++++++++++++++++++++++-
basis/calendar/calendar.factor | 52 +++++++++++---------
2 files changed, 104 insertions(+), 23 deletions(-)
diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor
index 734c19f045..4adf635d99 100644
--- a/basis/calendar/calendar-docs.factor
+++ b/basis/calendar/calendar-docs.factor
@@ -8,7 +8,7 @@ HELP: duration
{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers." } ;
HELP: timestamp
-{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } "." } ;
+{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two timestamps with the " { $link <=> } " word." } ;
{ timestamp duration } related-words
@@ -128,3 +128,76 @@ HELP: >time<
} ;
{ >date< >time< } related-words
+
+HELP: instant
+{ $values { "duration" duration } }
+{ $description "Pushes a " { $snippet "duration" } " of zero seconds." } ;
+
+HELP: years
+{ $values { "x" number } { "duration" duration } }
+{ $description } ;
+{ year years } related-words
+
+HELP: months
+{ $values { "x" number } { "duration" duration } }
+{ $description } ;
+{ month months } related-words
+
+HELP: days
+{ $values { "x" number } { "duration" duration } }
+{ $description } ;
+{ day days } related-words
+
+HELP: weeks
+{ $values { "x" number } { "duration" duration } }
+{ $description } ;
+{ week weeks } related-words
+
+HELP: hours
+{ $values { "x" number } { "duration" duration } }
+{ $description } ;
+{ hour hours } related-words
+
+HELP: minutes
+{ $values { "x" number } { "duration" duration } }
+{ $description } ;
+{ minute minutes } related-words
+
+HELP: seconds
+{ $values { "x" number } { "duration" duration } }
+{ $description } ;
+{ second seconds } related-words
+
+HELP: milliseconds
+{ $values { "x" number } { "duration" duration } }
+{ $description } ;
+{ millisecond milliseconds } related-words
+
+HELP: leap-year?
+{ $values { "obj" object } { "?" "a boolean" } }
+{ $description "Returns " { $link t } " if the object represents a leap year." }
+{ $examples
+ { $example "USING: calendar prettyprint ;"
+ "2008 leap-year? ."
+ "t"
+ }
+ { $example "USING: calendar prettyprint ;"
+ "2010 1 1 <date> leap-year? ."
+ "f"
+ }
+} ;
+
+HELP: time+
+{ $values { "time1" "timestamp or duration" } { "time2" "timestamp or duration" } { "time3" "timestamp or duration" } }
+{ $description "Adds two durations to produce a duration or adds a timestamp and a duration to produce a timestamp. The calculation takes timezones into account." }
+{ $examples
+ { $example "USING: calendar math.order prettyprint ;"
+ "10 months 2 months time+ 1 year <=> ."
+ "+eq+"
+ }
+ { $example "USING: calendar math.order prettyprint ;"
+ "2010 1 1 <date> 3 days time+ days>> ."
+ "4"
+ }
+} ;
+
diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index af0ced7ed2..fd99464bd3 100755
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -3,7 +3,7 @@
USING: arrays kernel math math.functions namespaces sequences
strings system vocabs.loader calendar.backend threads
accessors combinators locals classes.tuple math.order
-memoize summary combinators.short-circuit ;
+memoize summary combinators.short-circuit alias ;
IN: calendar
TUPLE: duration
@@ -116,15 +116,23 @@ PRIVATE>
: >time< ( timestamp -- hour minute second )
[ hour>> ] [ minute>> ] [ second>> ] tri ;
-MEMO: instant ( -- dt ) 0 0 0 0 0 0 <duration> ;
-: years ( n -- dt ) instant clone swap >>year ;
-: months ( n -- dt ) instant clone swap >>month ;
-: days ( n -- dt ) instant clone swap >>day ;
-: weeks ( n -- dt ) 7 * days ;
-: hours ( n -- dt ) instant clone swap >>hour ;
-: minutes ( n -- dt ) instant clone swap >>minute ;
-: seconds ( n -- dt ) instant clone swap >>second ;
-: milliseconds ( n -- dt ) 1000 / seconds ;
+MEMO: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
+: years ( x -- duration ) instant clone swap >>year ;
+: months ( x -- duration ) instant clone swap >>month ;
+: days ( x -- duration ) instant clone swap >>day ;
+: weeks ( x -- duration ) 7 * days ;
+: hours ( x -- duration ) instant clone swap >>hour ;
+: minutes ( x -- duration ) instant clone swap >>minute ;
+: seconds ( x -- duration ) instant clone swap >>second ;
+: milliseconds ( x -- duration ) 1000 / seconds ;
+ALIAS: year years
+ALIAS: month months
+ALIAS: day days
+ALIAS: week weeks
+ALIAS: hour hours
+ALIAS: minute minutes
+ALIAS: second seconds
+ALIAS: millisecond milliseconds
GENERIC: leap-year? ( obj -- ? )
@@ -218,7 +226,7 @@ M: number +second ( timestamp n -- timestamp )
PRIVATE>
-GENERIC# time+ 1 ( time dt -- time )
+GENERIC# time+ 1 ( time1 time2 -- time3 )
M: timestamp time+
>r clone r> (time+) drop ;
@@ -236,8 +244,8 @@ M: duration time+
2drop <duration>
] if ;
-: dt>years ( dt -- x )
- #! Uses average month/year length since dt loses calendar
+: dt>years ( duration -- x )
+ #! Uses average month/year length since duration loses calendar
#! data
0 swap
{
@@ -251,12 +259,12 @@ M: duration time+
M: duration <=> [ dt>years ] compare ;
-: dt>months ( dt -- x ) dt>years months-per-year * ;
-: dt>days ( dt -- x ) dt>years days-per-year * ;
-: dt>hours ( dt -- x ) dt>years hours-per-year * ;
-: dt>minutes ( dt -- x ) dt>years minutes-per-year * ;
-: dt>seconds ( dt -- x ) dt>years seconds-per-year * ;
-: dt>milliseconds ( dt -- x ) dt>seconds 1000 * ;
+: dt>months ( duration -- x ) dt>years months-per-year * ;
+: dt>days ( duration -- x ) dt>years days-per-year * ;
+: dt>hours ( duration -- x ) dt>years hours-per-year * ;
+: dt>minutes ( duration -- x ) dt>years minutes-per-year * ;
+: dt>seconds ( duration -- x ) dt>years seconds-per-year * ;
+: dt>milliseconds ( duration -- x ) dt>seconds 1000 * ;
GENERIC: time- ( time1 time2 -- time )
@@ -296,7 +304,7 @@ M: timestamp time-
} 2cleave <duration>
] if ;
-: before ( dt -- -dt )
+: before ( duration -- -duration )
-1 time* ;
M: duration time-
@@ -324,8 +332,8 @@ MEMO: unix-1970 ( -- timestamp )
: now ( -- timestamp ) gmt >local-time ;
-: hence ( dt -- timestamp ) now swap time+ ;
-: ago ( dt -- timestamp ) now swap time- ;
+: hence ( duration -- timestamp ) now swap time+ ;
+: ago ( duration -- timestamp ) now swap time- ;
: day-counts { 0 31 28 31 30 31 30 31 31 30 31 30 31 } ; inline
From 610a70c3d280d7cfb81782c09f6d05dba1accd71 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 15:58:12 -0500
Subject: [PATCH 32/46] fix docs
---
basis/calendar/calendar-docs.factor | 8 ++++----
1 file changed, 4 insertions(+), 4 deletions(-)
diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor
index 4adf635d99..5ff3ef6cc1 100644
--- a/basis/calendar/calendar-docs.factor
+++ b/basis/calendar/calendar-docs.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math strings help.markup help.syntax
-calendar.backend ;
+calendar.backend math.order ;
IN: calendar
HELP: duration
-{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers." } ;
+{ $description "A duration is a period of time years, months, days, hours, minutes, and seconds. All duration slots can store " { $link real } " numbers. Compare two timestamps with the " { $link <=> } " word." } ;
HELP: timestamp
{ $description "A timestamp is a date and a time with a timezone offset. Timestamp slots must store integers except for " { $snippet "seconds" } ", which stores reals, and " { $snippet "gmt-offset" } ", which stores a " { $link duration } ". Compare two timestamps with the " { $link <=> } " word." } ;
@@ -195,8 +195,8 @@ HELP: time+
"10 months 2 months time+ 1 year <=> ."
"+eq+"
}
- { $example "USING: calendar math.order prettyprint ;"
- "2010 1 1 <date> 3 days time+ days>> ."
+ { $example "USING: accessors calendar math.order prettyprint ;"
+ "2010 1 1 <date> 3 days time+ day>> ."
"4"
}
} ;
From 31c5e57ab270604053c614209414a78c7d875fd9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 16:17:46 -0500
Subject: [PATCH 33/46] new accessors
---
basis/ui/tools/browser/browser.factor | 6 +++---
basis/ui/tools/debugger/debugger.factor | 2 +-
basis/ui/tools/search/search.factor | 4 ++--
basis/ui/tools/traceback/traceback.factor | 8 ++++----
basis/ui/tools/walker/walker.factor | 4 ++--
5 files changed, 12 insertions(+), 12 deletions(-)
diff --git a/basis/ui/tools/browser/browser.factor b/basis/ui/tools/browser/browser.factor
index 8f180714c8..33523701aa 100755
--- a/basis/ui/tools/browser/browser.factor
+++ b/basis/ui/tools/browser/browser.factor
@@ -39,17 +39,17 @@ M: browser-gadget ungraft*
: showing-definition? ( defspec assoc -- ? )
[ key? ] 2keep
- [ >r dup word-link? [ link-name ] when r> key? ] 2keep
+ [ >r dup word-link? [ name>> ] when r> key? ] 2keep
>r dup vocab-link? [ vocab ] when r> key?
or or ;
M: browser-gadget definitions-changed ( assoc browser -- )
history>>
- dup model-value rot showing-definition?
+ dup value>> rot showing-definition?
[ notify-connections ] [ drop ] if ;
: help-action ( browser-gadget -- link )
- history>> model-value >link ;
+ history>> value>> >link ;
: com-follow ( link -- ) browser-gadget call-tool ;
diff --git a/basis/ui/tools/debugger/debugger.factor b/basis/ui/tools/debugger/debugger.factor
index 203406c6cb..5a3ad01d2e 100644
--- a/basis/ui/tools/debugger/debugger.factor
+++ b/basis/ui/tools/debugger/debugger.factor
@@ -11,7 +11,7 @@ USING: accessors arrays ui ui.commands ui.gestures ui.gadgets
IN: ui.tools.debugger
: <restart-list> ( restarts restart-hook -- gadget )
- [ restart-name ] rot <model> <list> ;
+ [ name>> ] rot <model> <list> ;
TUPLE: debugger < track restarts ;
diff --git a/basis/ui/tools/search/search.factor b/basis/ui/tools/search/search.factor
index 407484ba97..89f238b574 100755
--- a/basis/ui/tools/search/search.factor
+++ b/basis/ui/tools/search/search.factor
@@ -118,7 +118,7 @@ M: live-search pref-dim* drop { 400 200 } ;
: <source-file-search> ( string files -- gadget )
source-file-candidates
- f [ pathname-string ] <live-search> ;
+ f [ string>> ] <live-search> ;
: all-source-files ( -- seq )
source-files get keys natural-sort ;
@@ -146,7 +146,7 @@ M: live-search pref-dim* drop { 400 200 } ;
: <history-search> ( string seq -- gadget )
history-candidates
- f [ input-string ] <live-search> ;
+ f [ string>> ] <live-search> ;
: listener-history ( listener -- seq )
listener-gadget-input interactor-history <reversed> ;
diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor
index 05cb043e49..06ebb7eb4e 100755
--- a/basis/ui/tools/traceback/traceback.factor
+++ b/basis/ui/tools/traceback/traceback.factor
@@ -9,15 +9,15 @@ USING: accessors continuations kernel models namespaces
IN: ui.tools.traceback
: <callstack-display> ( model -- gadget )
- [ [ continuation-call callstack. ] when* ]
+ [ [ call>> callstack. ] when* ]
t "Call stack" <labelled-pane> ;
: <datastack-display> ( model -- gadget )
- [ [ continuation-data stack. ] when* ]
+ [ [ data>> stack. ] when* ]
t "Data stack" <labelled-pane> ;
: <retainstack-display> ( model -- gadget )
- [ [ continuation-retain stack. ] when* ]
+ [ [ return>> stack. ] when* ]
t "Retain stack" <labelled-pane> ;
TUPLE: traceback-gadget < track ;
@@ -39,7 +39,7 @@ M: traceback-gadget pref-dim* drop { 550 600 } ;
dup <toolbar> f track-add ;
: <namestack-display> ( model -- gadget )
- [ [ continuation-name namestack. ] when* ]
+ [ [ name>> namestack. ] when* ]
<pane-control> ;
: <variables-gadget> ( model -- gadget )
diff --git a/basis/ui/tools/walker/walker.factor b/basis/ui/tools/walker/walker.factor
index c667e6918d..767be92687 100755
--- a/basis/ui/tools/walker/walker.factor
+++ b/basis/ui/tools/walker/walker.factor
@@ -41,7 +41,7 @@ M: walker-gadget focusable-child*
: walker-state-string ( status thread -- string )
[
"Thread: " %
- dup thread-name %
+ dup name>> %
" (" %
swap {
{ +stopped+ "Stopped" }
@@ -92,7 +92,7 @@ walker-gadget "toolbar" f {
[ swap walker-for-thread? ] curry find-window ;
: walker-window ( status continuation thread -- )
- [ <walker-gadget> ] [ thread-name ] bi open-status-window ;
+ [ <walker-gadget> ] [ name>> ] bi open-status-window ;
[
dup find-walker-window dup
From 39c5b13b50f513cd15703580612c4dfa6cbf8d1c Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 16:18:02 -0500
Subject: [PATCH 34/46] new accessors
---
basis/ui/freetype/freetype.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/freetype/freetype.factor b/basis/ui/freetype/freetype.factor
index 7bda548a26..d2dfe56ed4 100755
--- a/basis/ui/freetype/freetype.factor
+++ b/basis/ui/freetype/freetype.factor
@@ -184,7 +184,7 @@ M: freetype-renderer string-height ( open-font string -- h )
: draw-char ( open-font sprites char loc -- )
GL_MODELVIEW [
0 0 glTranslated
- char-sprite sprite-dlist glCallList
+ char-sprite dlist>> glCallList
] do-matrix ;
: char-widths ( open-font string -- widths )
From ab83333b5161da3fffc8c315cd02b5fbf491680d Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 16:19:24 -0500
Subject: [PATCH 35/46] new accessors
---
basis/ui/gadgets/editors/editors.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 06a8b4886a..8142297318 100755
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -55,9 +55,9 @@ M: editor ungraft*
dup caret>> deactivate-editor-model
dup mark>> deactivate-editor-model ;
-: editor-caret* ( editor -- loc ) caret>> model-value ;
+: editor-caret* ( editor -- loc ) caret>> value>> ;
-: editor-mark* ( editor -- loc ) mark>> model-value ;
+: editor-mark* ( editor -- loc ) mark>> value>> ;
: set-caret ( loc editor -- )
[ model>> validate-loc ] keep
@@ -501,7 +501,7 @@ TUPLE: field < wrapper field-model editor ;
swap >>field-model ;
M: field graft*
- [ [ field-model>> model-value ] [ editor>> ] bi set-editor-string ]
+ [ [ field-model>> value>> ] [ editor>> ] bi set-editor-string ]
[ dup editor>> model>> add-connection ]
bi ;
From 24bf9e3f9c63e007bca46bc2255e81eb17ce4ebc Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 16:21:18 -0500
Subject: [PATCH 36/46] new accessors
---
basis/ui/gadgets/gadgets.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
index bcf908571c..15850ae357 100755
--- a/basis/ui/gadgets/gadgets.factor
+++ b/basis/ui/gadgets/gadgets.factor
@@ -50,7 +50,7 @@ M: gadget model-changed 2drop ;
dup model>> dup [ 2dup remove-connection ] when 2drop ;
: control-value ( control -- value )
- model>> model-value ;
+ model>> value>> ;
: set-control-value ( value control -- )
model>> set-model ;
From f7c27f4127effd2418c699ffae7cf6a44b3d4bc9 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 16:22:25 -0500
Subject: [PATCH 37/46] new accessors
---
basis/ui/gadgets/incremental/incremental.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/gadgets/incremental/incremental.factor b/basis/ui/gadgets/incremental/incremental.factor
index 77b88959c9..3291a1c42a 100755
--- a/basis/ui/gadgets/incremental/incremental.factor
+++ b/basis/ui/gadgets/incremental/incremental.factor
@@ -41,7 +41,7 @@ M: incremental pref-dim*
swap set-rect-loc ;
: prefer-incremental ( gadget -- )
- dup forget-pref-dim dup pref-dim swap set-rect-dim ;
+ dup forget-pref-dim dup pref-dim >>dim drop ;
: add-incremental ( gadget incremental -- )
not-in-layout
From d2861cae6e132d91deba91164bbb74169016f18f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 16:24:40 -0500
Subject: [PATCH 38/46] fix accessor. oops
---
basis/ui/tools/traceback/traceback.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/tools/traceback/traceback.factor b/basis/ui/tools/traceback/traceback.factor
index 06ebb7eb4e..92c5e09a88 100755
--- a/basis/ui/tools/traceback/traceback.factor
+++ b/basis/ui/tools/traceback/traceback.factor
@@ -17,7 +17,7 @@ IN: ui.tools.traceback
t "Data stack" <labelled-pane> ;
: <retainstack-display> ( model -- gadget )
- [ [ return>> stack. ] when* ]
+ [ [ retain>> stack. ] when* ]
t "Retain stack" <labelled-pane> ;
TUPLE: traceback-gadget < track ;
From 6474ed69a7aa46d87fffa15a4bc4fb2f2517d1e1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 16:24:53 -0500
Subject: [PATCH 39/46] new accessor
---
basis/ui/render/render.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index c7bfc99024..a4bb353d1b 100644
--- a/basis/ui/render/render.factor
+++ b/basis/ui/render/render.factor
@@ -138,7 +138,7 @@ M: polygon draw-interior
: <polygon-gadget> ( color points -- gadget )
dup max-dim
- >r <polygon> <gadget> r> over set-rect-dim
+ >r <polygon> <gadget> r> >>dim
[ (>>interior) ] keep ;
! Font rendering
From aa68ea0ce1f9cd6591a33447d38dc4400fa5f3e8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 17:27:28 -0500
Subject: [PATCH 40/46] fix messup
---
basis/calendar/calendar-docs.factor | 7 -------
basis/calendar/calendar.factor | 8 --------
2 files changed, 15 deletions(-)
diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor
index 5ff3ef6cc1..d687a8a9f4 100644
--- a/basis/calendar/calendar-docs.factor
+++ b/basis/calendar/calendar-docs.factor
@@ -136,27 +136,22 @@ HELP: instant
HELP: years
{ $values { "x" number } { "duration" duration } }
{ $description } ;
-{ year years } related-words
HELP: months
{ $values { "x" number } { "duration" duration } }
{ $description } ;
-{ month months } related-words
HELP: days
{ $values { "x" number } { "duration" duration } }
{ $description } ;
-{ day days } related-words
HELP: weeks
{ $values { "x" number } { "duration" duration } }
{ $description } ;
-{ week weeks } related-words
HELP: hours
{ $values { "x" number } { "duration" duration } }
{ $description } ;
-{ hour hours } related-words
HELP: minutes
{ $values { "x" number } { "duration" duration } }
@@ -166,12 +161,10 @@ HELP: minutes
HELP: seconds
{ $values { "x" number } { "duration" duration } }
{ $description } ;
-{ second seconds } related-words
HELP: milliseconds
{ $values { "x" number } { "duration" duration } }
{ $description } ;
-{ millisecond milliseconds } related-words
HELP: leap-year?
{ $values { "obj" object } { "?" "a boolean" } }
diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index fd99464bd3..b7e93e56f9 100755
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -125,14 +125,6 @@ MEMO: instant ( -- duration ) 0 0 0 0 0 0 <duration> ;
: minutes ( x -- duration ) instant clone swap >>minute ;
: seconds ( x -- duration ) instant clone swap >>second ;
: milliseconds ( x -- duration ) 1000 / seconds ;
-ALIAS: year years
-ALIAS: month months
-ALIAS: day days
-ALIAS: week weeks
-ALIAS: hour hours
-ALIAS: minute minutes
-ALIAS: second seconds
-ALIAS: millisecond milliseconds
GENERIC: leap-year? ( obj -- ? )
From 357f5c36fdf3b19526b24cb2c5a8d554bef97349 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 17:28:27 -0500
Subject: [PATCH 41/46] oops
---
basis/calendar/calendar-docs.factor | 1 -
1 file changed, 1 deletion(-)
diff --git a/basis/calendar/calendar-docs.factor b/basis/calendar/calendar-docs.factor
index d687a8a9f4..2c23ae95c1 100644
--- a/basis/calendar/calendar-docs.factor
+++ b/basis/calendar/calendar-docs.factor
@@ -156,7 +156,6 @@ HELP: hours
HELP: minutes
{ $values { "x" number } { "duration" duration } }
{ $description } ;
-{ minute minutes } related-words
HELP: seconds
{ $values { "x" number } { "duration" duration } }
From 89264e77267a8474962566113b21f6dd497a7d4b Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Sun, 31 Aug 2008 17:29:55 -0500
Subject: [PATCH 42/46] fix using
---
basis/calendar/calendar.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index b7e93e56f9..d9284573c4 100755
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -3,7 +3,7 @@
USING: arrays kernel math math.functions namespaces sequences
strings system vocabs.loader calendar.backend threads
accessors combinators locals classes.tuple math.order
-memoize summary combinators.short-circuit alias ;
+memoize summary combinators.short-circuit ;
IN: calendar
TUPLE: duration
From 29e5ed2adbc1e5260da76f704bdd36b69a9bb5e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 19:17:04 -0500
Subject: [PATCH 43/46] Fixing deploy tool
---
.../tree/propagation/info/info.factor | 6 +--
.../tree/propagation/inlining/inlining.factor | 16 ++++++--
.../known-words/known-words.factor | 40 +++++++++----------
.../tree/propagation/nodes/nodes.factor | 3 --
.../tree/propagation/simple/simple.factor | 39 ++++++++----------
basis/macros/expander/expander.factor | 4 +-
.../known-words/known-words.factor | 10 ++---
.../transforms/transforms.factor | 11 ++---
basis/tools/deploy/shaker/shaker.factor | 38 +++++++++++++-----
basis/tools/deploy/test/1/deploy.factor | 16 ++++----
basis/tools/deploy/test/2/deploy.factor | 14 +++----
basis/tools/deploy/test/3/deploy.factor | 18 ++++-----
basis/tools/deploy/test/4/deploy.factor | 14 +++----
basis/tools/deploy/test/5/deploy.factor | 14 +++----
14 files changed, 127 insertions(+), 116 deletions(-)
diff --git a/basis/compiler/tree/propagation/info/info.factor b/basis/compiler/tree/propagation/info/info.factor
index f3ecd7ae65..2281c140a4 100644
--- a/basis/compiler/tree/propagation/info/info.factor
+++ b/basis/compiler/tree/propagation/info/info.factor
@@ -12,8 +12,6 @@ IN: compiler.tree.propagation.info
: null-class? ( class -- ? ) null class<= ;
-SYMBOL: +interval+
-
GENERIC: eql? ( obj1 obj2 -- ? )
M: object eql? eq? ;
M: fixnum eql? eq? ;
@@ -40,7 +38,7 @@ slots ;
: class-interval ( class -- interval )
dup real class<=
- [ +interval+ word-prop [-inf,inf] or ] [ drop f ] if ;
+ [ "interval" word-prop [-inf,inf] or ] [ drop f ] if ;
: interval>literal ( class interval -- literal literal? )
#! If interval has zero length and the class is sufficiently
@@ -84,7 +82,7 @@ slots ;
init-value-info ; foldable
: <class-info> ( class -- info )
- dup word? [ dup +interval+ word-prop ] [ f ] if [-inf,inf] or
+ dup word? [ dup "interval" word-prop ] [ f ] if [-inf,inf] or
<class/interval-info> ; foldable
: <interval-info> ( interval -- info )
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 09f50b21ea..4f93769b7f 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays sequences math math.order
-math.partial-dispatch generic generic.standard classes.algebra
-classes.union sets quotations assocs combinators words
-namespaces
+math.partial-dispatch generic generic.standard generic.math
+classes.algebra classes.union sets quotations assocs combinators
+words namespaces
compiler.tree
compiler.tree.builder
compiler.tree.normalization
@@ -145,3 +145,13 @@ SYMBOL: history
: always-inline-word? ( word -- ? )
{ curry compose } memq? ;
+
+: do-inlining ( #call word -- ? )
+ {
+ { [ dup always-inline-word? ] [ inline-word ] }
+ { [ dup standard-generic? ] [ inline-standard-method ] }
+ { [ dup math-generic? ] [ inline-math-method ] }
+ { [ dup math-partial? ] [ inline-math-partial ] }
+ { [ dup method-body? ] [ inline-method-body ] }
+ [ 2drop f ]
+ } cond ;
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 23323e107d..c07c5a5cb5 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -17,11 +17,11 @@ IN: compiler.tree.propagation.known-words
\ fixnum
most-negative-fixnum most-positive-fixnum [a,b]
-+interval+ set-word-prop
+"interval" set-word-prop
\ array-capacity
0 max-array-capacity [a,b]
-+interval+ set-word-prop
+"interval" set-word-prop
{ + - * / }
[ { number number } "input-classes" set-word-prop ] each
@@ -66,17 +66,17 @@ most-negative-fixnum most-positive-fixnum [a,b]
over interval>> [ [ clone ] dip change-interval ] [ 2drop ] if ; inline
{ bitnot fixnum-bitnot bignum-bitnot } [
- [ [ interval-bitnot ] ?change-interval ] +outputs+ set-word-prop
+ [ [ interval-bitnot ] ?change-interval ] "outputs" set-word-prop
] each
-\ abs [ [ interval-abs ] ?change-interval ] +outputs+ set-word-prop
+\ abs [ [ interval-abs ] ?change-interval ] "outputs" set-word-prop
: math-closure ( class -- newclass )
{ fixnum bignum integer rational float real number object }
[ class<= ] with find nip ;
: fits? ( interval class -- ? )
- +interval+ word-prop interval-subset? ;
+ "interval" word-prop interval-subset? ;
: binary-op-class ( info1 info2 -- newclass )
[ class>> ] bi@
@@ -120,7 +120,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
[ binary-op-class ] [ , binary-op-interval ] 2bi
@
<class/interval-info>
- ] +outputs+ set-word-prop ;
+ ] "outputs" set-word-prop ;
\ + [ [ interval+ ] [ may-overflow number-valued ] binary-op ] each-derived-op
\ + [ [ interval+ ] [ number-valued ] binary-op ] each-fast-derived-op
@@ -158,7 +158,7 @@ most-negative-fixnum most-positive-fixnum [a,b]
in1 in2 op negate-comparison (comparison-constraints) out f--> /\ ;
: define-comparison-constraints ( word op -- )
- '[ , comparison-constraints ] +constraints+ set-word-prop ;
+ '[ , comparison-constraints ] "constraints" set-word-prop ;
comparison-ops
[ dup '[ , define-comparison-constraints ] each-derived-op ] each
@@ -178,13 +178,13 @@ generic-comparison-ops [
comparison-ops [
dup '[
- [ , fold-comparison ] +outputs+ set-word-prop
+ [ , fold-comparison ] "outputs" set-word-prop
] each-derived-op
] each
generic-comparison-ops [
dup specific-comparison
- '[ , fold-comparison ] +outputs+ set-word-prop
+ '[ , fold-comparison ] "outputs" set-word-prop
] each
: maybe-or-never ( ? -- info )
@@ -196,7 +196,7 @@ generic-comparison-ops [
{ number= bignum= float= } [
[
info-intervals-intersect? maybe-or-never
- ] +outputs+ set-word-prop
+ ] "outputs" set-word-prop
] each
: info-classes-intersect? ( info1 info2 -- ? )
@@ -206,13 +206,13 @@ generic-comparison-ops [
over value-info literal>> fixnum? [
[ value-info literal>> is-equal-to ] dip t-->
] [ 3drop f ] if
-] +constraints+ set-word-prop
+] "constraints" set-word-prop
\ eq? [
[ info-intervals-intersect? ]
[ info-classes-intersect? ]
2bi or maybe-or-never
-] +outputs+ set-word-prop
+] "outputs" set-word-prop
{
{ >fixnum fixnum }
@@ -226,7 +226,7 @@ generic-comparison-ops [
interval-intersect
] 2bi
<class/interval-info>
- ] +outputs+ set-word-prop
+ ] "outputs" set-word-prop
] assoc-each
{
@@ -250,36 +250,36 @@ generic-comparison-ops [
}
} cond
[ fixnum fits? fixnum integer ? ] keep <class/interval-info>
- [ 2nip ] curry +outputs+ set-word-prop
+ [ 2nip ] curry "outputs" set-word-prop
] each
{ <tuple> <tuple-boa> } [
[
literal>> dup tuple-layout? [ class>> ] [ drop tuple ] if <class-info>
[ clear ] dip
- ] +outputs+ set-word-prop
+ ] "outputs" set-word-prop
] each
\ new [
literal>> dup tuple-class? [ drop tuple ] unless <class-info>
-] +outputs+ set-word-prop
+] "outputs" set-word-prop
! the output of clone has the same type as the input
{ clone (clone) } [
[ clone f >>literal f >>literal? ]
- +outputs+ set-word-prop
+ "outputs" set-word-prop
] each
\ slot [
dup literal?>>
[ literal>> swap value-info-slot ] [ 2drop object-info ] if
-] +outputs+ set-word-prop
+] "outputs" set-word-prop
\ instance? [
[ value-info ] dip over literal>> class? [
[ literal>> ] dip predicate-constraints
] [ 3drop f ] if
-] +constraints+ set-word-prop
+] "constraints" set-word-prop
\ instance? [
! We need to force the caller word to recompile when the class
@@ -292,4 +292,4 @@ generic-comparison-ops [
[ predicate-output-infos ]
bi
] [ 2drop object-info ] if
-] +outputs+ set-word-prop
+] "outputs" set-word-prop
diff --git a/basis/compiler/tree/propagation/nodes/nodes.factor b/basis/compiler/tree/propagation/nodes/nodes.factor
index 358944d1b7..9e4d99e462 100644
--- a/basis/compiler/tree/propagation/nodes/nodes.factor
+++ b/basis/compiler/tree/propagation/nodes/nodes.factor
@@ -6,9 +6,6 @@ compiler.tree.propagation.copy
compiler.tree.propagation.info ;
IN: compiler.tree.propagation.nodes
-SYMBOL: +constraints+
-SYMBOL: +outputs+
-
GENERIC: propagate-before ( node -- )
GENERIC: propagate-after ( node -- )
diff --git a/basis/compiler/tree/propagation/simple/simple.factor b/basis/compiler/tree/propagation/simple/simple.factor
index d664ae5ccf..809a85a51f 100644
--- a/basis/compiler/tree/propagation/simple/simple.factor
+++ b/basis/compiler/tree/propagation/simple/simple.factor
@@ -3,8 +3,7 @@
USING: fry accessors kernel sequences sequences.private assocs words
namespaces classes.algebra combinators classes classes.tuple
classes.tuple.private continuations arrays
-math math.partial-dispatch math.private slots generic definitions
-generic.standard generic.math
+math math.private slots generic definitions
stack-checker.state
compiler.tree
compiler.tree.propagation.info
@@ -52,7 +51,7 @@ M: #declare propagate-before
with-datastack first assume ;
: compute-constraints ( #call word -- )
- dup +constraints+ word-prop [ nip custom-constraints ] [
+ dup "constraints" word-prop [ nip custom-constraints ] [
dup predicate? [
[ [ in-d>> first ] [ out-d>> first ] bi ]
[ "predicating" word-prop ] bi*
@@ -61,19 +60,22 @@ M: #declare propagate-before
] if* ;
: call-outputs-quot ( #call word -- infos )
- [ in-d>> [ value-info ] map ] [ +outputs+ word-prop ] bi*
+ [ in-d>> [ value-info ] map ] [ "outputs" word-prop ] bi*
with-datastack ;
: foldable-call? ( #call word -- ? )
"foldable" word-prop
[ in-d>> [ value-info literal?>> ] all? ] [ drop f ] if ;
-: fold-call ( #call word -- infos )
+: (fold-call) ( #call word -- info )
[ [ out-d>> ] [ in-d>> [ value-info literal>> ] map ] bi ] [ '[ , execute ] ] bi*
'[ , , with-datastack [ <literal-info> ] map nip ]
[ drop [ object-info ] replicate ]
recover ;
+: fold-call ( #call word -- )
+ [ (fold-call) ] [ drop out-d>> ] 2bi set-value-infos ;
+
: predicate-output-infos ( info class -- info )
[ class>> ] dip {
{ [ 2dup class<= ] [ t <literal-info> ] }
@@ -95,30 +97,23 @@ M: #declare propagate-before
: output-value-infos ( #call word -- infos )
{
- { [ 2dup foldable-call? ] [ fold-call ] }
{ [ dup tuple-constructor? ] [ propagate-tuple-constructor ] }
{ [ dup sequence-constructor? ] [ propagate-sequence-constructor ] }
{ [ dup predicate? ] [ propagate-predicate ] }
- { [ dup +outputs+ word-prop ] [ call-outputs-quot ] }
+ { [ dup "outputs" word-prop ] [ call-outputs-quot ] }
[ default-output-value-infos ]
} cond ;
-: do-inlining ( #call word -- ? )
- {
- { [ dup always-inline-word? ] [ inline-word ] }
- { [ dup standard-generic? ] [ inline-standard-method ] }
- { [ dup math-generic? ] [ inline-math-method ] }
- { [ dup math-partial? ] [ inline-math-partial ] }
- { [ dup method-body? ] [ inline-method-body ] }
- [ 2drop f ]
- } cond ;
-
M: #call propagate-before
- dup word>> 2dup do-inlining [ 2drop ] [
- [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
- [ compute-constraints ]
- 2bi
- ] if ;
+ dup word>> {
+ { [ 2dup foldable-call? ] [ fold-call ] }
+ { [ 2dup do-inlining ] [ 2drop ] }
+ [
+ [ [ output-value-infos ] [ drop out-d>> ] 2bi set-value-infos ]
+ [ compute-constraints ]
+ 2bi
+ ]
+ } cond ;
M: #call annotate-node
dup [ in-d>> ] [ out-d>> ] bi append (annotate-node) ;
diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor
index f538412937..0a1703de58 100644
--- a/basis/macros/expander/expander.factor
+++ b/basis/macros/expander/expander.factor
@@ -32,8 +32,8 @@ M: wrapper expand-macros* wrapped>> literal ;
stack get pop >quotation end (expand-macros) ;
: expand-macro? ( word -- quot ? )
- dup [ "macro" word-prop ] [ +transform-quot+ word-prop ] bi or dup [
- swap [ stack-effect in>> length ] [ +transform-n+ word-prop ] bi or
+ dup [ "macro" word-prop ] [ "transform-quot" word-prop ] bi or dup [
+ swap [ stack-effect in>> length ] [ "transform-n" word-prop ] bi or
stack get length <=
] [ 2drop f f ] if ;
diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index c01236fba9..5cbd5f40af 100755
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -173,15 +173,13 @@ do-primitive alien-invoke alien-indirect alien-callback
{ call execute dispatch load-locals get-local drop-locals }
[ t "no-compile" set-word-prop ] each
-SYMBOL: +primitive+
-
: non-inline-word ( word -- )
dup called-dependency depends-on
{
{ [ dup "shuffle" word-prop ] [ infer-shuffle-word ] }
{ [ dup "special" word-prop ] [ infer-special ] }
- { [ dup +primitive+ word-prop ] [ infer-primitive ] }
- { [ dup +transform-quot+ word-prop ] [ apply-transform ] }
+ { [ dup "primitive" word-prop ] [ infer-primitive ] }
+ { [ dup "transform-quot" word-prop ] [ apply-transform ] }
{ [ dup "macro" word-prop ] [ apply-macro ] }
{ [ dup "cannot-infer" word-prop ] [ cannot-infer-effect ] }
{ [ dup "inferred-effect" word-prop ] [ cached-infer ] }
@@ -190,7 +188,7 @@ SYMBOL: +primitive+
} cond ;
: define-primitive ( word inputs outputs -- )
- [ 2drop t +primitive+ set-word-prop ]
+ [ 2drop t "primitive" set-word-prop ]
[ drop "input-classes" set-word-prop ]
[ nip "default-output-classes" set-word-prop ]
3tri ;
@@ -600,8 +598,6 @@ SYMBOL: +primitive+
\ (set-os-envs) { array } { } define-primitive
-\ do-primitive [ \ do-primitive cannot-infer-effect ] "infer" set-word-prop
-
\ dll-valid? { object } { object } define-primitive
\ modify-code-heap { array object } { } define-primitive
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index 200b5d9c43..1bdfdb6f42 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -8,9 +8,6 @@ stack-checker.backend stack-checker.state stack-checker.visitor
stack-checker.errors ;
IN: stack-checker.transforms
-SYMBOL: +transform-quot+
-SYMBOL: +transform-n+
-
: give-up-transform ( word -- )
dup recursive-label
[ call-recursive-word ]
@@ -48,8 +45,8 @@ SYMBOL: +transform-n+
: apply-transform ( word -- )
[ inlined-dependency depends-on ] [
[ ]
- [ +transform-quot+ word-prop ]
- [ +transform-n+ word-prop ]
+ [ "transform-quot" word-prop ]
+ [ "transform-n" word-prop ]
tri
(apply-transform)
] bi ;
@@ -64,8 +61,8 @@ SYMBOL: +transform-n+
] bi ;
: define-transform ( word quot n -- )
- [ drop +transform-quot+ set-word-prop ]
- [ nip +transform-n+ set-word-prop ]
+ [ drop "transform-quot" set-word-prop ]
+ [ nip "transform-n" set-word-prop ]
3bi ;
! Combinators
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index eaa0342c25..5e888cd871 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -85,8 +85,11 @@ IN: tools.deploy.shaker
[
strip-dictionary? [
{
+ "cannot-infer"
"coercer"
+ "combination"
"compiled-effect"
+ "compiled-generic-uses"
"compiled-uses"
"constraints"
"declared-effect"
@@ -94,38 +97,52 @@ IN: tools.deploy.shaker
"default-method"
"default-output-classes"
"derived-from"
- "identities"
+ "engines"
"if-intrinsics"
"infer"
"inferred-effect"
+ "inline"
+ "inlined-block"
"input-classes"
"interval"
"intrinsics"
+ "lambda"
"loc"
+ "local-reader"
+ "local-reader?"
+ "local-writer"
+ "local-writer?"
+ "local?"
+ "macro"
"members"
- "methods"
+ "memo-quot"
"method-class"
"method-generic"
- "combination"
- "cannot-infer"
+ "methods"
"no-compile"
"optimizer-hooks"
- "output-classes"
+ "outputs"
"participants"
"predicate"
"predicate-definition"
"predicating"
- "tuple-dispatch-generic"
- "slots"
+ "reader"
+ "reading"
+ "recursive"
+ "shuffle"
"slot-names"
+ "slots"
+ "special"
"specializer"
"step-into"
"step-into?"
"superclass"
- "reading"
- "writing"
+ "transform-n"
+ "transform-quot"
+ "tuple-dispatch-generic"
"type"
- "engines"
+ "writer"
+ "writing"
} %
] when
@@ -211,6 +228,7 @@ IN: tools.deploy.shaker
classes:update-map
command-line:main-vocab-hook
compiled-crossref
+ compiled-generic-crossref
compiler.units:recompile-hook
compiler.units:update-tuples-hook
definitions:crossref
diff --git a/basis/tools/deploy/test/1/deploy.factor b/basis/tools/deploy/test/1/deploy.factor
index 490c21a067..098e99719e 100755
--- a/basis/tools/deploy/test/1/deploy.factor
+++ b/basis/tools/deploy/test/1/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-word-defs? f }
- { deploy-random? f }
- { deploy-name "tools.deploy.test.1" }
- { deploy-threads? t }
- { deploy-compiler? t }
- { deploy-math? t }
{ deploy-c-types? f }
+ { deploy-name "tools.deploy.test.1" }
{ deploy-io 2 }
- { deploy-reflection 1 }
- { deploy-ui? f }
+ { deploy-random? f }
+ { deploy-math? t }
+ { deploy-compiler? t }
+ { deploy-reflection 2 }
{ "stop-after-last-window?" t }
+ { deploy-threads? t }
+ { deploy-ui? f }
{ deploy-word-props? f }
+ { deploy-word-defs? f }
}
diff --git a/basis/tools/deploy/test/2/deploy.factor b/basis/tools/deploy/test/2/deploy.factor
index aeec8e94f7..c6f46eede6 100755
--- a/basis/tools/deploy/test/2/deploy.factor
+++ b/basis/tools/deploy/test/2/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-compiler? t }
- { deploy-reflection 2 }
+ { deploy-io 2 }
{ deploy-ui? f }
- { deploy-word-props? f }
{ deploy-threads? t }
{ deploy-c-types? f }
- { deploy-random? f }
- { "stop-after-last-window?" t }
{ deploy-name "tools.deploy.test.2" }
- { deploy-io 2 }
+ { deploy-compiler? t }
+ { deploy-word-props? f }
+ { deploy-reflection 2 }
{ deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-random? f }
+ { deploy-math? t }
}
diff --git a/basis/tools/deploy/test/3/deploy.factor b/basis/tools/deploy/test/3/deploy.factor
index dde8291658..5f45b87e0d 100755
--- a/basis/tools/deploy/test/3/deploy.factor
+++ b/basis/tools/deploy/test/3/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-word-defs? f }
- { deploy-random? f }
- { deploy-name "tools.deploy.test.3" }
- { deploy-threads? t }
- { deploy-compiler? t }
- { deploy-math? t }
- { deploy-c-types? f }
{ deploy-io 3 }
- { deploy-reflection 1 }
{ deploy-ui? f }
- { "stop-after-last-window?" t }
+ { deploy-threads? t }
+ { deploy-c-types? f }
+ { deploy-name "tools.deploy.test.3" }
+ { deploy-compiler? t }
{ deploy-word-props? f }
+ { deploy-reflection 2 }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-random? f }
+ { deploy-math? t }
}
diff --git a/basis/tools/deploy/test/4/deploy.factor b/basis/tools/deploy/test/4/deploy.factor
index 65ead56e2b..ea899e64c0 100644
--- a/basis/tools/deploy/test/4/deploy.factor
+++ b/basis/tools/deploy/test/4/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-reflection 1 }
{ deploy-io 2 }
- { deploy-c-types? f }
- { deploy-random? f }
{ deploy-ui? f }
- { deploy-name "tools.deploy.test.4" }
- { deploy-word-defs? f }
- { "stop-after-last-window?" t }
{ deploy-threads? t }
+ { deploy-c-types? f }
+ { deploy-name "tools.deploy.test.4" }
{ deploy-compiler? t }
{ deploy-word-props? f }
+ { deploy-reflection 2 }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-random? f }
+ { deploy-math? t }
}
diff --git a/basis/tools/deploy/test/5/deploy.factor b/basis/tools/deploy/test/5/deploy.factor
index bb4580b7ae..797116e09b 100644
--- a/basis/tools/deploy/test/5/deploy.factor
+++ b/basis/tools/deploy/test/5/deploy.factor
@@ -1,15 +1,15 @@
USING: tools.deploy.config ;
H{
- { deploy-math? t }
- { deploy-reflection 1 }
{ deploy-io 3 }
- { deploy-c-types? f }
- { deploy-random? f }
{ deploy-ui? f }
- { deploy-name "tools.deploy.test.5" }
- { deploy-word-defs? f }
- { "stop-after-last-window?" t }
{ deploy-threads? t }
+ { deploy-c-types? f }
+ { deploy-name "tools.deploy.test.5" }
{ deploy-compiler? t }
{ deploy-word-props? f }
+ { deploy-reflection 2 }
+ { deploy-word-defs? f }
+ { "stop-after-last-window?" t }
+ { deploy-random? f }
+ { deploy-math? t }
}
From facc5edeec38a201bebcedf1a053e9e7904ab762 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 19:23:04 -0500
Subject: [PATCH 44/46] Fix handler
---
basis/ui/gadgets/handler/handler.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/basis/ui/gadgets/handler/handler.factor b/basis/ui/gadgets/handler/handler.factor
index 1ad5063013..1c12142593 100644
--- a/basis/ui/gadgets/handler/handler.factor
+++ b/basis/ui/gadgets/handler/handler.factor
@@ -8,4 +8,4 @@ TUPLE: handler < wrapper table ;
: <handler> ( child -- handler ) handler new-wrapper ;
M: handler handle-gesture ( gesture gadget -- ? )
- over table>> at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
+ tuck table>> at dup [ call f ] [ 2drop t ] if ;
\ No newline at end of file
From da295345a2f5d3d135307fd71ac768e530e60536 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 19:28:26 -0500
Subject: [PATCH 45/46] Fix tests
---
basis/help/topics/topics-tests.factor | 6 +++---
1 file changed, 3 insertions(+), 3 deletions(-)
diff --git a/basis/help/topics/topics-tests.factor b/basis/help/topics/topics-tests.factor
index c52d5e347f..699b2d398a 100644
--- a/basis/help/topics/topics-tests.factor
+++ b/basis/help/topics/topics-tests.factor
@@ -1,6 +1,6 @@
-USING: definitions help help.topics help.crossref help.markup
-help.syntax kernel sequences tools.test words parser namespaces
-assocs source-files eval ;
+USING: accessors definitions help help.topics help.crossref
+help.markup help.syntax kernel sequences tools.test words parser
+namespaces assocs source-files eval ;
IN: help.topics.tests
\ article-name must-infer
From 88aa1def3564819a46ed36378041e658776ad15e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 31 Aug 2008 20:13:06 -0500
Subject: [PATCH 46/46] More a UI dependency to basis
---
{extra => basis}/math/points/points.factor | 0
1 file changed, 0 insertions(+), 0 deletions(-)
rename {extra => basis}/math/points/points.factor (100%)
diff --git a/extra/math/points/points.factor b/basis/math/points/points.factor
similarity index 100%
rename from extra/math/points/points.factor
rename to basis/math/points/points.factor