diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor index 2863944c8b..f29e05c023 100644 --- a/basis/binary-search/binary-search.factor +++ b/basis/binary-search/binary-search.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel sequences sequences.private accessors math -math.order combinators ; +math.order combinators hints arrays ; IN: binary-search : natural-search ( obj seq -- i elt ) [ <=> ] with search ; +HINTS: natural-search array ; + : sorted-index ( obj seq -- i ) natural-search drop ; diff --git a/basis/concurrency/mailboxes/mailboxes-tests.factor b/basis/concurrency/mailboxes/mailboxes-tests.factor index 61c57bb9e9..64971eeb77 100755 --- a/basis/concurrency/mailboxes/mailboxes-tests.factor +++ b/basis/concurrency/mailboxes/mailboxes-tests.factor @@ -3,6 +3,8 @@ USING: concurrency.mailboxes concurrency.count-downs vectors sequences threads tools.test math kernel strings namespaces continuations calendar destructors ; +{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as + [ V{ 1 2 3 } ] [ 0 diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor index e4269000c9..cf8c064b82 100755 --- a/basis/concurrency/mailboxes/mailboxes.factor +++ b/basis/concurrency/mailboxes/mailboxes.factor @@ -60,8 +60,9 @@ M: mailbox dispose* threads>> notify-all ; [ [ mailbox-empty? ] curry ] dip [ ] while ; inline : mailbox-get-timeout? ( mailbox timeout pred -- obj ) - 3dup block-unless-pred - nip >r data>> r> delete-node-if ; inline + [ block-unless-pred ] + [ nip >r data>> r> delete-node-if ] + 3bi ; inline : mailbox-get? ( mailbox pred -- obj ) f swap mailbox-get-timeout? ; inline diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index 5b4da8927a..77ee06793e 100755 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -5,7 +5,7 @@ parser words quotations debugger macros arrays macros splitting combinators prettyprint.backend definitions prettyprint hashtables prettyprint.sections sets sequences.private effects effects.parser generic generic.parser compiler.units accessors -locals.backend memoize lexer ; +locals.backend memoize macros.expander lexer ; IN: locals ! Inspired by @@ -17,18 +17,27 @@ TUPLE: lambda vars body ; C: lambda -TUPLE: let bindings body ; +TUPLE: binding-form bindings body ; + +TUPLE: let < binding-form ; C: let -TUPLE: let* bindings body ; +TUPLE: let* < binding-form ; C: let* -TUPLE: wlet bindings body ; +TUPLE: wlet < binding-form ; C: wlet +M: lambda expand-macros clone [ expand-macros ] change-body ; + +M: binding-form expand-macros + clone + [ [ expand-macros ] assoc-map ] change-bindings + [ expand-macros ] change-body ; + PREDICATE: local < word "local?" word-prop ; : ( name -- word ) @@ -146,7 +155,8 @@ GENERIC: lambda-rewrite* ( obj -- ) GENERIC: local-rewrite* ( obj -- ) -: lambda-rewrite ( quot -- quot' ) +: lambda-rewrite ( form -- form' ) + expand-macros [ local-rewrite* ] [ ] make [ [ lambda-rewrite* ] each ] [ ] make ; diff --git a/basis/macros/expander/expander-tests.factor b/basis/macros/expander/expander-tests.factor new file mode 100644 index 0000000000..fe0154b725 --- /dev/null +++ b/basis/macros/expander/expander-tests.factor @@ -0,0 +1,9 @@ +IN: macros.expander.tests +USING: macros.expander tools.test math combinators.short-circuit +kernel ; + +[ t ] [ 20 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test + +[ f ] [ 15 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test + +[ f ] [ 5.0 [ { [ integer? ] [ even? ] [ 10 > ] } 1&& ] expand-macros call ] unit-test diff --git a/basis/macros/expander/expander.factor b/basis/macros/expander/expander.factor new file mode 100644 index 0000000000..f538412937 --- /dev/null +++ b/basis/macros/expander/expander.factor @@ -0,0 +1,51 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel sequences namespaces quotations accessors words +continuations vectors effects math stack-checker.transforms ; +IN: macros.expander + +GENERIC: expand-macros ( quot -- quot' ) + +> literal ; + +: expand-macro ( quot -- ) + stack [ swap with-datastack >vector ] change + 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 + stack get length <= + ] [ 2drop f f ] if ; + +M: word expand-macros* + dup expand-macro? [ nip expand-macro ] [ drop end , ] if ; + +M: object expand-macros* literal ; + +M: callable expand-macros* + expand-macros literal ; + +M: callable expand-macros ( quot -- quot' ) + [ begin (expand-macros) end ] [ ] make ; + +PRIVATE> diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor index e6baa19d0c..704cae459a 100644 --- a/basis/macros/macros-docs.factor +++ b/basis/macros/macros-docs.factor @@ -17,20 +17,11 @@ $nl HELP: macro { $class-description "Class of words defined with " { $link POSTPONE: MACRO: } "." } ; -HELP: macro-expand -{ $values { "..." "inputs to a macro" } { "word" macro } { "quot" quotation } } -{ $description "Expands a macro. Useful for debugging." } -{ $examples - { $code "USING: math macros combinators.short-circuit ;" "{ [ integer? ] [ 0 > ] [ 13 mod zero? ] } \ 1&& macro-expand ." } -} ; - ARTICLE: "macros" "Macros" "The " { $vocab-link "macros" } " vocabulary implements macros in the Lisp sense; compile-time code transformers and generators. Macros can be used to calculate lookup tables and generate code at compile time, which can improve performance, the level of abstraction and simplify code." $nl "Defining new macros:" { $subsection POSTPONE: MACRO: } -"Expanding macros for debugging purposes:" -{ $subsection macro-expand } "Macros are really just a very thin layer of syntax sugar over " { $link "compiler-transforms" } "." ; ABOUT: "macros" diff --git a/basis/macros/macros.factor b/basis/macros/macros.factor index 7e85b0b194..e8cd9d1d19 100755 --- a/basis/macros/macros.factor +++ b/basis/macros/macros.factor @@ -26,8 +26,6 @@ M: macro definition "macro" word-prop ; M: macro reset-word [ call-next-method ] [ f "macro" set-word-prop ] bi ; -: macro-expand ( ... word -- quot ) "macro" word-prop call ; - : n*quot ( n seq -- seq' ) concat >quotation ; : saver ( n -- quot ) \ >r >quotation ; diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor index b30153aada..2f201ef4a5 100644 --- a/basis/persistent/deques/deques.factor +++ b/basis/persistent/deques/deques.factor @@ -12,10 +12,10 @@ IN: persistent.deques TUPLE: cons { car read-only } { cdr read-only } ; C: cons -: each ( list quot -- ) +: each ( list quot: ( elt -- ) -- ) over [ [ >r car>> r> call ] [ >r cdr>> r> ] 2bi each ] - [ 2drop ] if ; inline + [ 2drop ] if ; inline recursive : reduce ( list start quot -- end ) swapd each ; inline diff --git a/basis/x11/clipboard/clipboard.factor b/basis/x11/clipboard/clipboard.factor index cbe3c633fc..1007b47a5b 100755 --- a/basis/x11/clipboard/clipboard.factor +++ b/basis/x11/clipboard/clipboard.factor @@ -33,10 +33,10 @@ TUPLE: x-clipboard atom contents ; [ XGetWindowProperty drop ] keep snarf-property ; : selection-from-event ( event window -- string ) - >r XSelectionEvent-property zero? [ - r> drop f + swap XSelectionEvent-property zero? [ + drop f ] [ - r> selection-property 1 window-property utf8 decode + selection-property 1 window-property utf8 decode ] if ; : own-selection ( prop win -- ) diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index e7e2e17c88..f7a078fe4d 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -202,17 +202,17 @@ M: slice length [ to>> ] [ from>> ] bi - ; : short ( seq n -- seq n' ) over length min ; inline -: head-slice ( seq n -- slice ) (head) ; +: head-slice ( seq n -- slice ) (head) ; inline -: tail-slice ( seq n -- slice ) (tail) ; +: tail-slice ( seq n -- slice ) (tail) ; inline -: rest-slice ( seq -- slice ) 1 tail-slice ; +: rest-slice ( seq -- slice ) 1 tail-slice ; inline -: head-slice* ( seq n -- slice ) from-end head-slice ; +: head-slice* ( seq n -- slice ) from-end head-slice ; inline -: tail-slice* ( seq n -- slice ) from-end tail-slice ; +: tail-slice* ( seq n -- slice ) from-end tail-slice ; inline -: but-last-slice ( seq -- slice ) 1 head-slice* ; +: but-last-slice ( seq -- slice ) 1 head-slice* ; inline INSTANCE: slice virtual-sequence diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor index 613d75c4ae..5cf954fb8b 100644 --- a/extra/lists/lists.factor +++ b/extra/lists/lists.factor @@ -55,19 +55,20 @@ M: object nil? drop f ; : (leach) ( list quot -- cdr quot ) [ [ car ] dip call ] [ [ cdr ] dip ] 2bi ; inline -: leach ( list quot -- ) - over nil? [ 2drop ] [ (leach) leach ] if ; inline +: leach ( list quot: ( elt -- ) -- ) + over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive -: lmap ( list quot -- result ) - over nil? [ drop ] [ (leach) lmap cons ] if ; inline +: lmap ( list quot: ( elt -- ) -- result ) + over nil? [ drop ] [ (leach) lmap cons ] if ; inline recursive -: foldl ( list identity quot -- result ) swapd leach ; inline +: foldl ( list identity quot: ( obj1 obj2 -- obj ) -- result ) + swapd leach ; inline -: foldr ( list identity quot -- result ) +: foldr ( list identity quot: ( obj1 obj2 -- obj ) -- result ) pick nil? [ [ drop ] [ ] [ drop ] tri* ] [ [ [ cdr ] 2dip foldr ] [ nip [ car ] dip ] 3bi call - ] if ; inline + ] if ; inline recursive : llength ( list -- n ) 0 [ drop 1+ ] foldl ; @@ -87,9 +88,10 @@ M: object nil? drop f ; : seq>cons ( seq -- cons ) [ ] keep nil [ tuck same? [ seq>cons ] when f cons swap >>cdr ] with reduce ; -: (lmap>array) ( acc cons quot -- newcons ) +: (lmap>array) ( acc cons quot: ( elt -- elt' ) -- newcons ) over nil? [ 2drop ] - [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; inline + [ [ uncons ] dip [ call ] keep swapd [ suffix ] 2dip (lmap>array) ] if ; + inline recursive : lmap>array ( cons quot -- newcons ) { } -rot (lmap>array) ; inline @@ -103,8 +105,8 @@ M: object nil? drop f ; : list>seq ( list -- array ) [ ] lmap>array ; -: traverse ( list pred quot -- result ) +: traverse ( list pred quot: ( list/elt -- result ) -- result ) [ 2over call [ tuck [ call ] 2dip ] when - pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; + pick list? [ traverse ] [ 2drop ] if ] 2curry lmap ; inline recursive INSTANCE: cons list \ No newline at end of file diff --git a/extra/math/primes/list/list.factor b/extra/math/primes/list/list.factor index 7d1e2f20db..7560538028 100644 --- a/extra/math/primes/list/list.factor +++ b/extra/math/primes/list/list.factor @@ -6418,4 +6418,4 @@ IN: math.primes.list 999431 999433 999437 999451 999491 999499 999521 999529 999541 999553 999563 999599 999611 999613 999623 999631 999653 999667 999671 999683 999721 999727 999749 999763 999769 999773 999809 999853 999863 999883 999907 999917 999931 999953 999959 999961 -999979 999983 } ; +999979 999983 } ; inline