Optimizations and load fixes

diff --git a/basis/binary-search/binary-search.factor b/basis/binary-search/binary-search.factor
index 2863944c8b04b730882fc5e161e0d42f8d11b5dc..f29e05c0234b115d1902f319f6e91684ea900545 100644 (file)
--- 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
 
 <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 ;
 

diff --git a/basis/concurrency/mailboxes/mailboxes-tests.factor b/basis/concurrency/mailboxes/mailboxes-tests.factor
index 61c57bb9e9c114ac14bb63340f3557a0da6c0678..64971eeb77c95f7b45322d4987efd1bd4038a9d2 100755 (executable)
--- 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\r
 continuations calendar destructors ;\r
 \r
+{ 1 1 } [ [ integer? ] mailbox-get? ] must-infer-as\r
+\r
 [ V{ 1 2 3 } ] [\r
     0 <vector>\r
     <mailbox>\r

diff --git a/basis/concurrency/mailboxes/mailboxes.factor b/basis/concurrency/mailboxes/mailboxes.factor
index e4269000c9628ab71612929cb78105fdc530aeb6..cf8c064b82f773b11ab1c2404b4e04870f5eaa6b 100755 (executable)
--- 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\r
 \r
 : mailbox-get-timeout? ( mailbox timeout pred -- obj )\r
-    3dup block-unless-pred\r
-    nip >r data>> r> delete-node-if ; inline\r
+    [ block-unless-pred ]\r
+    [ nip >r data>> r> delete-node-if ]\r
+    3bi ; inline\r
 \r
 : mailbox-get? ( mailbox pred -- obj )\r
     f swap mailbox-get-timeout? ; inline\r

diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor
index 5b4da8927a2c748471763d6e3a901ebb299e5acf..77ee06793efc6d4d5745bb8ef522f84a7a848ab3 100755 (executable)
--- 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> 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 ;
 

diff --git a/basis/macros/expander/expander-tests.factor b/basis/macros/expander/expander-tests.factor
new file mode 100644 (file)
index 0000000..fe0154b
--- /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 (file)
index 0000000..f538412
--- /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' )
+
+<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>

diff --git a/basis/macros/macros-docs.factor b/basis/macros/macros-docs.factor
index e6baa19d0c38094ffb738db1e1bf45d16ceb307b..704cae459a268683ab32063b00a1ea5c6010044b 100644 (file)
--- 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 7e85b0b194b4c7ef00a2483eec3f7d2eba985f50..e8cd9d1d196d72770dc3e0a6b8dc5050e868cc48 100755 (executable)
--- 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' ) <repetition> concat >quotation ;
 
 : saver ( n -- quot ) \ >r <repetition> >quotation ;

diff --git a/basis/persistent/deques/deques.factor b/basis/persistent/deques/deques.factor
index b30153aadafb62ae0ae9e6795ed4f71fec52fb04..2f201ef4a5ceb10ca098d1d2b1e971beb6de0db3 100644 (file)
--- 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> 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 cbe3c633fc54185135d768ebba3f73863007c7e3..1007b47a5b54491d5275ecba4a062b79b8ef146f 100755 (executable)
--- 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 e7e2e17c881d4c724797ba9131d565827277ac99..f7a078fe4d23bcd9a3192e384c2cd4253cd32895 100755 (executable)
--- 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) <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
 

diff --git a/extra/lists/lists.factor b/extra/lists/lists.factor
index 613d75c4aee98812300e591925cafe72ccdc6059..5cf954fb8be53a225669ca841c019eca431816fb 100644 (file)
--- 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 )
     [ <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
\ No newline at end of file

diff --git a/extra/math/primes/list/list.factor b/extra/math/primes/list/list.factor
index 7d1e2f20dbce5a81a49c34b41688547a00225f97..756053802859515f77ab0a1bb5c9577ae3b56fbb 100644 (file)
--- 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