Merge branch 'master' of git://factorcode.org/git/factor

basis/functors/functors-tests.factor

@@ -34,7 +34,7 @@ WW DEFINES ${W}${W}
 
 WHERE
 
-: WW W twice ; inline
+: WW ( a -- b ) \ W twice ; inline
 
 ;FUNCTOR
 
@@ -45,3 +45,21 @@ WHERE
 \ sqsq must-infer
 
 [ 16 ] [ 2 sqsq ] unit-test
+
+<<
+
+FUNCTOR: wrapper-test-2 ( W -- )
+
+W DEFINES ${W}
+
+WHERE
+
+: W ( a b -- c ) \ + execute ;
+
+;FUNCTOR
+
+"blah" wrapper-test-2
+
+>>
+
+[ 4 ] [ 1 3 blah ] unit-test

basis/functors/functors.factor

@@ -1,17 +1,43 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel quotations classes.tuple make combinators generic
 words interpolate namespaces sequences io.streams.string fry
 classes.mixin effects lexer parser classes.tuple.parser
 effects.parser locals.types locals.parser
-locals.rewrite.closures vocabs.parser ;
+locals.rewrite.closures vocabs.parser arrays accessors ;
 IN: functors
 
-: scan-param ( -- obj )
-    scan-object dup special? [ literalize ] unless ;
+! This is a hack
+
+<PRIVATE
+
+: scan-param ( -- obj ) scan-object literalize ;
 
 : define* ( word def effect -- ) pick set-word define-declared ;
 
+TUPLE: fake-quotation seq ;
+
+GENERIC: >fake-quotations ( quot -- fake )
+
+M: callable >fake-quotations
+    >array >fake-quotations fake-quotation boa ;
+
+M: array >fake-quotations [ >fake-quotations ] { } map-as ;
+
+M: object >fake-quotations ;
+
+GENERIC: fake-quotations> ( fake -- quot )
+
+M: fake-quotation fake-quotations>
+    seq>> [ fake-quotations> ] map >quotation ;
+
+M: array fake-quotations> [ fake-quotations> ] map ;
+
+M: object fake-quotations> ;
+
+: parse-definition* ( -- )
+    parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
+
 : DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
 
 : `TUPLE:
@@ -32,7 +58,7 @@ IN: functors
     scan-param parsed
     scan-param parsed
     \ create-method parsed
-    parse-definition parsed
+    parse-definition*
     DEFINE* ; parsing
 
 : `C:
@@ -45,7 +71,7 @@ IN: functors
 : `:
     effect off
     scan-param parsed
-    parse-definition parsed
+    parse-definition*
     DEFINE* ; parsing
 
 : `INSTANCE:
@@ -64,12 +90,16 @@ IN: functors
     [ scan interpolate-locals ] dip
     '[ _ with-string-writer @ ] parsed ;
 
+PRIVATE>
+
 : IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
 
 : DEFINES [ create-in ] (INTERPOLATE) ; parsing
 
 DEFER: ;FUNCTOR delimiter
 
+<PRIVATE
+
 : functor-words ( -- assoc )
     H{
         { "TUPLE:" POSTPONE: `TUPLE: }
@@ -104,4 +134,6 @@ DEFER: ;FUNCTOR delimiter
     parse-functor-body swap pop-locals <lambda>
     rewrite-closures first ;
 
+PRIVATE>
+
 : FUNCTOR: (FUNCTOR:) define ; parsing

basis/io/mmap/functor/functor.factor

@@ -20,9 +20,9 @@ with-mapped-A-file DEFINES with-mapped-${T}-file
 WHERE
 
 : <mapped-A> ( mapped-file -- direct-array )
-    T mapped-file>direct <A> execute ; inline
+    T mapped-file>direct <A> ; inline
 
 : with-mapped-A-file ( path length quot -- )
-    '[ <mapped-A> execute @ ] with-mapped-file ; inline
+    '[ <mapped-A> @ ] with-mapped-file ; inline
 
 ;FUNCTOR

basis/locals/locals-docs.factor

@@ -113,7 +113,7 @@ HELP: MEMO::
 
 { POSTPONE: MEMO: POSTPONE: MEMO:: } related-words
 
-ARTICLE: "locals-literals" "Locals in array and hashtable literals"
+ARTICLE: "locals-literals" "Locals in literals"
 "Certain data type literals are permitted to contain free variables. Any such literals are written into code which constructs an instance of the type with the free variable values spliced in. Conceptually, this is similar to the transformation applied to quotations containing free variables."
 $nl
 "The data types which receive this special handling are the following:"
@@ -122,7 +122,9 @@ $nl
     { $link "hashtables" }
     { $link "vectors" }
     { $link "tuples" }
+    { $link "wrappers" }
 }
+{ $heading "Object identity" }
 "This feature changes the semantics of literal object identity. An ordinary word containing a literal pushes the same literal on the stack every time it is invoked:"
 { $example
     "IN: scratchpad"
@@ -143,7 +145,7 @@ $nl
     "f"
 }
 "One exception to the above rule is that array instances containing no free variables do retain identity. This allows macros such as " { $link cond } " to recognize that the array is constant and expand at compile-time."
-$nl
+{ $heading "Example" }
 "For example, here is an implementation of the " { $link 3array } " word which uses this feature:"
 { $code ":: 3array ( x y z -- array ) { x y z } ;" } ;
 

basis/locals/locals-tests.factor

@@ -494,4 +494,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 
 ! Discovered by littledan
 [ "bar" ] [ [let | a [ [let | foo [ "bar" ] | foo ] ] | a ] ] unit-test
-[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
+[ 10 ] [ [let | a [ 10 ] | [let | b [ a ] | b ] ] ] unit-test
+
+[ { \ + } ] [ [let | x [ \ + ] | { \ x } ] ] unit-test
+
+[ { \ + 3 } ] [ [let | a [ 3 ] | { \ + a } ] ] unit-test
+
+[ 3 ] [ [let | a [ \ + ] | 1 2 [ \ a execute ] ] call ] unit-test

basis/locals/rewrite/sugar/sugar.factor

@@ -37,7 +37,7 @@ M: array rewrite-literal? [ rewrite-literal? ] contains? ;
 
 M: quotation rewrite-literal? [ rewrite-literal? ] contains? ;
 
-M: wrapper rewrite-literal? drop t ;
+M: wrapper rewrite-literal? wrapped>> rewrite-literal? ;
 
 M: hashtable rewrite-literal? drop t ;
 
@@ -53,7 +53,7 @@ GENERIC: rewrite-element ( obj -- )
     [ rewrite-element ] each ;
 
 : rewrite-sequence ( seq -- )
-    [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ;
+    [ rewrite-elements ] [ length ] [ 0 head ] tri '[ _ _ nsequence ] % ;
 
 M: array rewrite-element
     dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
@@ -63,7 +63,7 @@ M: vector rewrite-element rewrite-sequence ;
 M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
 
 M: tuple rewrite-element
-    [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ;
+    [ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % ;
 
 M: quotation rewrite-element rewrite-sugar* ;
 
@@ -81,10 +81,14 @@ M: local-writer rewrite-element
 M: local-word rewrite-element
     local-word-in-literal-error ;
 
-M: word rewrite-element literalize , ;
+M: word rewrite-element <wrapper> , ;
+
+: rewrite-wrapper ( wrapper -- )
+    dup rewrite-literal?
+    [ wrapped>> rewrite-element ] [ , ] if ;
 
 M: wrapper rewrite-element
-    dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ;
+    rewrite-wrapper \ <wrapper> , ;
 
 M: object rewrite-element , ;
 
@@ -98,7 +102,8 @@ M: def rewrite-sugar* , ;
 
 M: hashtable rewrite-sugar* rewrite-element ;
 
-M: wrapper rewrite-sugar* rewrite-element ;
+M: wrapper rewrite-sugar*
+    rewrite-wrapper ;
 
 M: word rewrite-sugar*
     dup { load-locals get-local drop-locals } memq?

basis/locals/types/types.factor

@@ -1,6 +1,7 @@
-! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
+! Copyright (C) 2007, 2009 Slava Pestov, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators kernel sequences words ;
+USING: accessors combinators kernel sequences words
+quotations ;
 IN: locals.types
 
 TUPLE: lambda vars body ;
@@ -38,6 +39,8 @@ PREDICATE: local < word "local?" word-prop ;
     f <word>
     dup t "local?" set-word-prop ;
 
+M: local literalize ;
+
 PREDICATE: local-word < word "local-word?" word-prop ;
 
 : <local-word> ( name -- word )
@@ -49,6 +52,8 @@ PREDICATE: local-reader < word "local-reader?" word-prop ;
     f <word>
     dup t "local-reader?" set-word-prop ;
 
+M: local-reader literalize ;
+
 PREDICATE: local-writer < word "local-writer?" word-prop ;
 
 : <local-writer> ( reader -- word )

basis/math/blas/cblas/tags.txt

@@ -1,3 +1,2 @@
 math
 bindings
-unportable

basis/math/blas/matrices/matrices.factor

@@ -268,28 +268,28 @@ TUPLE: MATRIX < blas-matrix-base ;
 M: MATRIX element-type
     drop TYPE ;
 M: MATRIX (blas-matrix-like)
-    drop <MATRIX> execute ;
+    drop <MATRIX> ;
 M: VECTOR (blas-matrix-like)
-    drop <MATRIX> execute ;
+    drop <MATRIX> ;
 M: MATRIX (blas-vector-like)
-    drop <VECTOR> execute ;
+    drop <VECTOR> ;
 
 : >MATRIX ( arrays -- matrix )
-    [ >ARRAY execute underlying>> ] (>matrix)
-    <MATRIX> execute ;
+    [ >ARRAY underlying>> ] (>matrix)
+    <MATRIX> ;
 
 M: VECTOR n*M.V+n*V!
-    [ TYPE>ARG execute ] (prepare-gemv)
-    [ XGEMV execute ] dip ;
+    [ TYPE>ARG ] (prepare-gemv)
+    [ XGEMV ] dip ;
 M: MATRIX n*M.M+n*M!
-    [ TYPE>ARG execute ] (prepare-gemm)
-    [ XGEMM execute ] dip ;
+    [ TYPE>ARG ] (prepare-gemm)
+    [ XGEMM ] dip ;
 M: MATRIX n*V(*)V+M!
-    [ TYPE>ARG execute ] (prepare-ger)
-    [ XGERU execute ] dip ;
+    [ TYPE>ARG ] (prepare-ger)
+    [ XGERU ] dip ;
 M: MATRIX n*V(*)Vconj+M!
-    [ TYPE>ARG execute ] (prepare-ger)
-    [ XGERC execute ] dip ;
+    [ TYPE>ARG ] (prepare-ger)
+    [ XGERC ] dip ;
 
 ;FUNCTOR
 

basis/math/blas/matrices/tags.txt

@@ -1,3 +1,2 @@
 math
 bindings
-unportable

basis/math/blas/syntax/syntax.factor

@@ -1,5 +1,5 @@
 USING: kernel math.blas.vectors math.blas.matrices parser
-arrays prettyprint.backend sequences ;
+arrays prettyprint.backend prettyprint.custom sequences ;
 IN: math.blas.syntax
 
 : svector{

basis/math/blas/syntax/tags.txt

@@ -1,2 +1 @@
 math
-unportable

basis/math/blas/vectors/tags.txt

@@ -1,2 +1 @@
 math
-unportable

basis/math/blas/vectors/vectors.factor

@@ -144,26 +144,26 @@ TUPLE: VECTOR < blas-vector-base ;
 : <VECTOR> ( underlying length inc -- vector ) VECTOR boa ; inline
 
 : >VECTOR ( seq -- v )
-    [ >ARRAY execute underlying>> ] [ length ] bi 1 <VECTOR> execute ;
+    [ >ARRAY underlying>> ] [ length ] bi 1 <VECTOR> ;
 
 M: VECTOR clone
     TYPE heap-size (prepare-copy)
-    [ XCOPY execute ] 3dip <VECTOR> execute ;
+    [ XCOPY ] 3dip <VECTOR> ;
 
 M: VECTOR element-type
     drop TYPE ;
 M: VECTOR Vswap
-    (prepare-swap) [ XSWAP execute ] 2dip ;
+    (prepare-swap) [ XSWAP ] 2dip ;
 M: VECTOR Viamax
-    (prepare-nrm2) IXAMAX execute ;
+    (prepare-nrm2) IXAMAX ;
 
 M: VECTOR (blas-vector-like)
-    drop <VECTOR> execute ;
+    drop <VECTOR> ;
 
 M: VECTOR (blas-direct-array)
     [ underlying>> ]
     [ [ length>> ] [ inc>> ] bi * ] bi
-    <DIRECT-ARRAY> execute ;
+    <DIRECT-ARRAY> ;
 
 ;FUNCTOR
 
@@ -180,17 +180,17 @@ XSCAL          IS cblas_${T}scal
 WHERE
 
 M: VECTOR V.
-    (prepare-dot) XDOT execute ;
+    (prepare-dot) XDOT ;
 M: VECTOR V.conj
-    (prepare-dot) XDOT execute ;
+    (prepare-dot) XDOT ;
 M: VECTOR Vnorm
-    (prepare-nrm2) XNRM2 execute ;
+    (prepare-nrm2) XNRM2 ;
 M: VECTOR Vasum
-    (prepare-nrm2) XASUM execute ;
+    (prepare-nrm2) XASUM ;
 M: VECTOR n*V+V!
-    (prepare-axpy) [ XAXPY execute ] dip ;
+    (prepare-axpy) [ XAXPY ] dip ;
 M: VECTOR n*V!
-    (prepare-scal) [ XSCAL execute ] dip ;
+    (prepare-scal) [ XSCAL ] dip ;
 
 ;FUNCTOR
 
@@ -207,13 +207,13 @@ COMPLEX>ARG            DEFINES ${TYPE}-complex>arg
 WHERE
 
 : <DIRECT-COMPLEX-ARRAY> ( alien len -- sequence )
-    1 shift <DIRECT-ARRAY> execute <complex-sequence> ;
+    1 shift <DIRECT-ARRAY> <complex-sequence> ;
 : >COMPLEX-ARRAY ( sequence -- sequence )
-    <complex-components> >ARRAY execute ;
+    <complex-components> >ARRAY ;
 : COMPLEX>ARG ( complex -- alien )
-    >rect 2array >ARRAY execute underlying>> ;
+    >rect 2array >ARRAY underlying>> ;
 : ARG>COMPLEX ( alien -- complex )
-    2 <DIRECT-ARRAY> execute first2 rect> ;
+    2 <DIRECT-ARRAY> first2 rect> ;
 
 ;FUNCTOR
 
@@ -234,22 +234,22 @@ WHERE
 
 M: VECTOR V.
     (prepare-dot) TYPE <c-object>
-    [ XDOTU_SUB execute ] keep
-    ARG>TYPE execute ;
+    [ XDOTU_SUB ] keep
+    ARG>TYPE ;
 M: VECTOR V.conj
     (prepare-dot) TYPE <c-object>
-    [ XDOTC_SUB execute ] keep
-    ARG>TYPE execute ;
+    [ XDOTC_SUB ] keep
+    ARG>TYPE ;
 M: VECTOR Vnorm
-    (prepare-nrm2) XXNRM2 execute ;
+    (prepare-nrm2) XXNRM2 ;
 M: VECTOR Vasum
-    (prepare-nrm2) XXASUM execute ;
+    (prepare-nrm2) XXASUM ;
 M: VECTOR n*V+V!
-    [ TYPE>ARG execute ] 2dip
-    (prepare-axpy) [ XAXPY execute ] dip ;
+    [ TYPE>ARG ] 2dip
+    (prepare-axpy) [ XAXPY ] dip ;
 M: VECTOR n*V!
-    [ TYPE>ARG execute ] dip
-    (prepare-scal) [ XSCAL execute ] dip ;
+    [ TYPE>ARG ] dip
+    (prepare-scal) [ XSCAL ] dip ;
 
 ;FUNCTOR
 

basis/specialized-arrays/direct/functor/functor.factor

@@ -27,8 +27,8 @@ TUPLE: A
 M: A length length>> ;
 M: A nth-unsafe underlying>> NTH call ;
 M: A set-nth-unsafe underlying>> SET-NTH call ;
-M: A like drop dup A instance? [ >A' execute ] unless ;
-M: A new-sequence drop <A'> execute ;
+M: A like drop dup A instance? [ >A' ] unless ;
+M: A new-sequence drop <A'> ;
 
 INSTANCE: A sequence
 

basis/specialized-arrays/functor/functor.factor

@@ -49,9 +49,9 @@ M: A set-nth-unsafe underlying>> SET-NTH call ;
 
 : >A ( seq -- specialized-array ) A new clone-like ; inline
 
-M: A like drop dup A instance? [ >A execute ] unless ;
+M: A like drop dup A instance? [ >A ] unless ;
 
-M: A new-sequence drop (A) execute ;
+M: A new-sequence drop (A) ;
 
 M: A equal? over A instance? [ sequence= ] [ 2drop f ] if ;
 
@@ -64,13 +64,13 @@ M: A resize
 
 M: A byte-length underlying>> length ;
 
-M: A pprint-delims drop A{ \ } ;
+M: A pprint-delims drop \ A{ \ } ;
 
 M: A >pprint-sequence ;
 
 M: A pprint* pprint-object ;
 
-: A{ \ } [ >A execute ] parse-literal ; parsing
+: A{ \ } [ >A ] parse-literal ; parsing
 
 INSTANCE: A sequence
 

basis/specialized-vectors/functor/functor.factor

@@ -18,16 +18,16 @@ WHERE
 
 TUPLE: V { underlying A } { length array-capacity } ;
 
-: <V> ( capacity -- vector ) <A> execute 0 V boa ; inline
+: <V> ( capacity -- vector ) <A> 0 V boa ; inline
 
 M: V like
     drop dup V instance? [
-        dup A instance? [ dup length V boa ] [ >V execute ] if
+        dup A instance? [ dup length V boa ] [ >V ] if
     ] unless ;
 
-M: V new-sequence drop [ <A> execute ] [ >fixnum ] bi V boa ;
+M: V new-sequence drop [ <A> ] [ >fixnum ] bi V boa ;
 
-M: A new-resizable drop <V> execute ;
+M: A new-resizable drop <V> ;
 
 M: V equal? over V instance? [ sequence= ] [ 2drop f ] if ;
 
@@ -39,7 +39,7 @@ M: V >pprint-sequence ;
 
 M: V pprint* pprint-object ;
 
-: V{ \ } [ >V execute ] parse-literal ; parsing
+: V{ \ } [ >V ] parse-literal ; parsing
 
 INSTANCE: V growable
 

core/quotations/quotations-docs.factor

@@ -14,6 +14,10 @@ $nl
 "Quotations implement the " { $link "sequence-protocol" } ", and existing sequences can be converted into quotations:"
 { $subsection >quotation }
 { $subsection 1quotation }
+"Wrappers:"
+{ $subsection "wrappers" } ;
+
+ARTICLE: "wrappers" "Wrappers"
 "Wrappers are used to push words on the data stack; they evaluate to the object being wrapped:"
 { $subsection wrapper }
 { $subsection literalize }

core/syntax/syntax.factor

@@ -103,7 +103,7 @@ IN: bootstrap.syntax
     "W{" [ \ } [ first <wrapper> ] parse-literal ] define-syntax
 
     "POSTPONE:" [ scan-word parsed ] define-syntax
-    "\\" [ scan-word literalize parsed ] define-syntax
+    "\\" [ scan-word <wrapper> parsed ] define-syntax
     "inline" [ word make-inline ] define-syntax
     "recursive" [ word make-recursive ] define-syntax
     "foldable" [ word make-foldable ] define-syntax