diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index 39923afee7..a5f3042b38 100644 --- a/basis/functors/functors-tests.factor +++ b/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 \ No newline at end of file diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 28bedc8360..f4d35b6932 100644 --- a/basis/functors/functors.factor +++ b/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 + +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 + rewrite-closures first ; +PRIVATE> + : FUNCTOR: (FUNCTOR:) define ; parsing diff --git a/basis/io/mmap/functor/functor.factor b/basis/io/mmap/functor/functor.factor index 4587a75fd9..954d8b43c7 100644 --- a/basis/io/mmap/functor/functor.factor +++ b/basis/io/mmap/functor/functor.factor @@ -20,9 +20,9 @@ with-mapped-A-file DEFINES with-mapped-${T}-file WHERE : ( mapped-file -- direct-array ) - T mapped-file>direct execute ; inline + T mapped-file>direct ; inline : with-mapped-A-file ( path length quot -- ) - '[ execute @ ] with-mapped-file ; inline + '[ @ ] with-mapped-file ; inline ;FUNCTOR diff --git a/basis/locals/locals-docs.factor b/basis/locals/locals-docs.factor index efaad748cf..a4a9ca448b 100644 --- a/basis/locals/locals-docs.factor +++ b/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 } ;" } ; diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index 982674694a..bd9e7cf103 100644 --- a/basis/locals/locals-tests.factor +++ b/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 \ No newline at end of file +[ 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 \ No newline at end of file diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor index 835fa6e421..515473c467 100644 --- a/basis/locals/rewrite/sugar/sugar.factor +++ b/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 , ; + +: rewrite-wrapper ( wrapper -- ) + dup rewrite-literal? + [ wrapped>> rewrite-element ] [ , ] if ; M: wrapper rewrite-element - dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; + rewrite-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? diff --git a/basis/locals/types/types.factor b/basis/locals/types/types.factor index 7a8dac1947..3ed753e094 100644 --- a/basis/locals/types/types.factor +++ b/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 dup t "local?" set-word-prop ; +M: local literalize ; + PREDICATE: local-word < word "local-word?" word-prop ; : ( name -- word ) @@ -49,6 +52,8 @@ PREDICATE: local-reader < word "local-reader?" word-prop ; f dup t "local-reader?" set-word-prop ; +M: local-reader literalize ; + PREDICATE: local-writer < word "local-writer?" word-prop ; : ( reader -- word ) diff --git a/basis/math/blas/cblas/tags.txt b/basis/math/blas/cblas/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/cblas/tags.txt +++ b/basis/math/blas/cblas/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index 75ab07709a..f6b98e3ae2 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/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 execute ; + drop ; M: VECTOR (blas-matrix-like) - drop execute ; + drop ; M: MATRIX (blas-vector-like) - drop execute ; + drop ; : >MATRIX ( arrays -- matrix ) - [ >ARRAY execute underlying>> ] (>matrix) - execute ; + [ >ARRAY underlying>> ] (>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 diff --git a/basis/math/blas/matrices/tags.txt b/basis/math/blas/matrices/tags.txt index 5118958180..241ec1ecda 100644 --- a/basis/math/blas/matrices/tags.txt +++ b/basis/math/blas/matrices/tags.txt @@ -1,3 +1,2 @@ math bindings -unportable diff --git a/basis/math/blas/syntax/syntax.factor b/basis/math/blas/syntax/syntax.factor index 95f9f7bd08..2d171a801b 100644 --- a/basis/math/blas/syntax/syntax.factor +++ b/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{ diff --git a/basis/math/blas/syntax/tags.txt b/basis/math/blas/syntax/tags.txt index 6a932d96d2..ede10ab61b 100644 --- a/basis/math/blas/syntax/tags.txt +++ b/basis/math/blas/syntax/tags.txt @@ -1,2 +1 @@ math -unportable diff --git a/basis/math/blas/vectors/tags.txt b/basis/math/blas/vectors/tags.txt index 6a932d96d2..ede10ab61b 100644 --- a/basis/math/blas/vectors/tags.txt +++ b/basis/math/blas/vectors/tags.txt @@ -1,2 +1 @@ math -unportable diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index db027b0ffd..c86fa30115 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -144,26 +144,26 @@ TUPLE: VECTOR < blas-vector-base ; : ( underlying length inc -- vector ) VECTOR boa ; inline : >VECTOR ( seq -- v ) - [ >ARRAY execute underlying>> ] [ length ] bi 1 execute ; + [ >ARRAY underlying>> ] [ length ] bi 1 ; M: VECTOR clone TYPE heap-size (prepare-copy) - [ XCOPY execute ] 3dip execute ; + [ XCOPY ] 3dip ; 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 execute ; + drop ; M: VECTOR (blas-direct-array) [ underlying>> ] [ [ length>> ] [ inc>> ] bi * ] bi - execute ; + ; ;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 : ( alien len -- sequence ) - 1 shift execute ; + 1 shift ; : >COMPLEX-ARRAY ( sequence -- sequence ) - >ARRAY execute ; + >ARRAY ; : COMPLEX>ARG ( complex -- alien ) - >rect 2array >ARRAY execute underlying>> ; + >rect 2array >ARRAY underlying>> ; : ARG>COMPLEX ( alien -- complex ) - 2 execute first2 rect> ; + 2 first2 rect> ; ;FUNCTOR @@ -234,22 +234,22 @@ WHERE M: VECTOR V. (prepare-dot) TYPE - [ XDOTU_SUB execute ] keep - ARG>TYPE execute ; + [ XDOTU_SUB ] keep + ARG>TYPE ; M: VECTOR V.conj (prepare-dot) TYPE - [ 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 diff --git a/basis/specialized-arrays/direct/functor/functor.factor b/basis/specialized-arrays/direct/functor/functor.factor index 14fb739947..ce23186fc6 100755 --- a/basis/specialized-arrays/direct/functor/functor.factor +++ b/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 execute ; +M: A like drop dup A instance? [ >A' ] unless ; +M: A new-sequence drop ; INSTANCE: A sequence diff --git a/basis/specialized-arrays/functor/functor.factor b/basis/specialized-arrays/functor/functor.factor index 579da5b84a..9a56346be4 100644 --- a/basis/specialized-arrays/functor/functor.factor +++ b/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 diff --git a/basis/specialized-vectors/functor/functor.factor b/basis/specialized-vectors/functor/functor.factor index 6069a4cb4a..e6f1986874 100644 --- a/basis/specialized-vectors/functor/functor.factor +++ b/basis/specialized-vectors/functor/functor.factor @@ -18,16 +18,16 @@ WHERE TUPLE: V { underlying A } { length array-capacity } ; -: ( capacity -- vector ) execute 0 V boa ; inline +: ( capacity -- vector ) 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 [ execute ] [ >fixnum ] bi V boa ; +M: V new-sequence drop [ ] [ >fixnum ] bi V boa ; -M: A new-resizable drop execute ; +M: A new-resizable drop ; 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 diff --git a/core/quotations/quotations-docs.factor b/core/quotations/quotations-docs.factor index 1a16d0f92a..f2629a36c4 100644 --- a/core/quotations/quotations-docs.factor +++ b/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 } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index c81fc9201e..af5fa38aeb 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -103,7 +103,7 @@ IN: bootstrap.syntax "W{" [ \ } [ first ] parse-literal ] define-syntax "POSTPONE:" [ scan-word parsed ] define-syntax - "\\" [ scan-word literalize parsed ] define-syntax + "\\" [ scan-word parsed ] define-syntax "inline" [ word make-inline ] define-syntax "recursive" [ word make-recursive ] define-syntax "foldable" [ word make-foldable ] define-syntax