Optimizations and load fixes

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
 
 <PRIVATE
@@ -36,6 +36,8 @@ PRIVATE>
 : natural-search ( obj seq -- i elt )
     [ <=> ] with search ;
 
+HINTS: natural-search array ;
+
 : sorted-index ( obj seq -- i )
     natural-search drop ;
 

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 <vector>
     <mailbox>

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
+    [ block-unless-pred ]
-    nip >r data>> r> delete-node-if ; inline
+    [ nip >r data>> r> delete-node-if ]
+    3bi ; inline
 
 : mailbox-get? ( mailbox pred -- obj )
     f swap mailbox-get-timeout? ; inline

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> lambda
 
-TUPLE: let bindings body ;
+TUPLE: binding-form bindings body ;
+
+TUPLE: let < binding-form ;
 
 C: <let> let
 
-TUPLE: let* bindings body ;
+TUPLE: let* < binding-form ;
 
 C: <let*> let*
 
-TUPLE: wlet bindings body ;
+TUPLE: wlet < binding-form ;
 
 C: <wlet> 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 ;
 
 : <local> ( 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 ;
 

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

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' )
+
+<PRIVATE
+
+SYMBOL: stack
+
+: begin ( -- ) V{ } clone stack set ;
+
+: end ( -- )
+    stack get
+    [ [ literalize , ] each ]
+    [ delete-all ]
+    bi ;
+
+: literal ( obj -- ) stack get push ;
+
+GENERIC: expand-macros* ( obj -- )
+
+: (expand-macros) ( quot -- )
+    [ expand-macros* ] each ;
+
+M: wrapper expand-macros* wrapped>> 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>

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"

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' ) <repetition> concat >quotation ;
 
 : saver ( n -- quot ) \ >r <repetition> >quotation ;

basis/persistent/deques/deques.factor

@@ -12,10 +12,10 @@ IN: persistent.deques
 TUPLE: cons { car read-only } { cdr read-only } ;
 C: <cons> 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

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? [
+    swap XSelectionEvent-property zero? [
-        r> drop f
+        drop f
     ] [
-        r> selection-property 1 window-property utf8 decode
+        selection-property 1 window-property utf8 decode
     ] if ;
 
 : own-selection ( prop win -- )

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) <slice> ;
+: head-slice ( seq n -- slice ) (head) <slice> ; inline
 
-: tail-slice ( seq n -- slice ) (tail) <slice> ;
+: tail-slice ( seq n -- slice ) (tail) <slice> ; 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
 

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 -- )
+: leach ( list quot: ( elt -- ) -- )
-    over nil? [ 2drop ] [ (leach) leach ] if ; inline
+    over nil? [ 2drop ] [ (leach) leach ] if ; inline recursive
 
-: lmap ( list quot -- result )
+: lmap ( list quot: ( elt -- ) -- result )
-    over nil? [ drop ] [ (leach) lmap cons ] if ; inline
+    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 )
     [ <reversed> ] 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

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