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

basis/alien/c-types/c-types-tests.factor

@@ -2,6 +2,12 @@ IN: alien.c-types.tests
 USING: alien alien.syntax alien.c-types kernel tools.test
 sequences system libc alien.strings io.encodings.utf8 ;
 
+\ expand-constants must-infer
+
+: xyz 123 ;
+
+[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
+
 : foo ( -- n ) "fdafd" f dlsym [ 123 ] unless* ;
 
 [ 123 ] [ foo ] unit-test

basis/alien/c-types/c-types.factor

@@ -4,7 +4,7 @@ USING: byte-arrays arrays assocs kernel kernel.private libc math
 namespaces parser sequences strings words assocs splitting
 math.parser cpu.architecture alien alien.accessors quotations
 layouts system compiler.units io.files io.encodings.binary
-accessors combinators effects ;
+accessors combinators effects continuations ;
 IN: alien.c-types
 
 DEFER: <int>
@@ -239,15 +239,20 @@ M: long-long-type box-return ( type -- )
     } 2cleave ;
 
 : expand-constants ( c-type -- c-type' )
-    #! We use def>> call instead of execute to get around
-    #! staging violations
     dup array? [
-        unclip >r [ dup word? [ def>> call ] when ] map r> prefix
+        unclip >r [
+            dup word? [
+                def>> { } swap with-datastack first
+            ] when
+        ] map r> prefix
     ] when ;
 
 : malloc-file-contents ( path -- alien len )
     binary file-contents dup malloc-byte-array swap length ;
 
+: if-void ( type true false -- )
+    pick "void" = [ drop nip call ] [ nip call ] if ; inline
+
 [
     <c-type>
         [ alien-cell ] >>getter

basis/disjoint-sets/disjoint-sets.factor

@@ -66,6 +66,10 @@ M: disjoint-set add-atom
 
 : add-atoms ( seq disjoint-set -- ) '[ , add-atom ] each ;
 
+GENERIC: disjoint-set-member? ( a disjoint-set -- ? )
+
+M: disjoint-set disjoint-set-member? parents>> key? ;
+
 GENERIC: equiv-set-size ( a disjoint-set -- n )
 
 M: disjoint-set equiv-set-size [ representative ] keep count ;
@@ -84,6 +88,14 @@ M:: disjoint-set equate ( a b disjoint-set -- )
         disjoint-set link-sets
     ] if ;
 
+: equate-all-with ( seq a disjoint-set -- )
+    '[ , , equate ] each ;
+
+: equate-all ( seq disjoint-set -- )
+    over dup empty? [ 2drop ] [
+        [ unclip-slice ] dip equate-all-with
+    ] if ;
+
 M: disjoint-set clone
     [ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
     disjoint-set boa ;

basis/help/lint/lint.factor

@@ -3,9 +3,9 @@
 USING: accessors sequences parser kernel help help.markup
 help.topics words strings classes tools.vocabs namespaces io
 io.streams.string prettyprint definitions arrays vectors
-combinators splitting debugger hashtables sorting effects vocabs
+combinators combinators.short-circuit splitting debugger
-vocabs.loader assocs editors continuations classes.predicate
+hashtables sorting effects vocabs vocabs.loader assocs editors
-macros math sets eval ;
+continuations classes.predicate macros math sets eval ;
 IN: help.lint
 
 : check-example ( element -- )
@@ -43,15 +43,15 @@ IN: help.lint
 
 : check-values ( word element -- )
     {
-        { [ over "declared-effect" word-prop ] [ 2drop ] }
+        [ drop "declared-effect" word-prop not ]
-        { [ dup contains-funky-elements? not ] [ 2drop ] }
+        [ nip contains-funky-elements? ]
-        { [ over macro? not ] [ 2drop ] }
+        [ drop macro? ]
         [
             [ effect-values >array ]
             [ extract-values >array ]
-            bi* assert=
+            bi* =
         ]
-    } cond ;
+    } 2|| [ "$values don't match stack effect" throw ] unless ;
 
 : check-see-also ( word element -- )
     nip \ $see-also swap elements [

basis/io/ports/ports.factor

@@ -4,7 +4,7 @@ USING: math kernel io sequences io.buffers io.timeouts generic
 byte-vectors system io.encodings math.order io.backend
 continuations debugger classes byte-arrays namespaces splitting
 grouping dlists assocs io.encodings.binary summary accessors
-destructors ;
+destructors combinators ;
 IN: io.ports
 
 SYMBOL: default-buffer-size
@@ -133,10 +133,12 @@ M: output-port stream-flush ( port -- )
 
 M: output-port dispose*
     [
+        {
             [ handle>> &dispose drop ]
+            [ buffer>> &dispose drop ]
             [ port-flush ]
             [ handle>> shutdown ]
-        tri
+        } cleave
     ] with-destructors ;
 
 M: buffered-port dispose*

basis/math/constants/constants.factor

@@ -1,5 +1,6 @@
-! Copyright (C) 2004, 2005 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
+USE: math
 IN: math.constants
 
 : e ( -- e ) 2.7182818284590452354 ; inline
@@ -7,3 +8,5 @@ IN: math.constants
 : phi ( -- phi ) 1.61803398874989484820 ; inline
 : pi ( -- pi ) 3.14159265358979323846 ; inline
 : epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
+: smallest-float ( -- x ) HEX: 1 bits>double ; foldable
+: largest-float ( -- x ) HEX: 7fefffffffffffff bits>double ; foldable

basis/math/ranges/ranges-docs.factor

@@ -1,21 +1,27 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup arrays sequences ;
 
 IN: math.ranges
 
 ARTICLE: "ranges" "Ranges"
-
+"A " { $emphasis "range" } " is a virtual sequence with real number elements "
-  "A " { $emphasis "range" } " is a virtual sequence with real elements "
 "ranging from " { $emphasis "a" } " to " { $emphasis "b" } " by " { $emphasis "step" } "."
-
 $nl
-
+"The class of ranges:"
-  "Creating ranges:"
+{ $subsection range }
-
+"Creating ranges with integer end-points. The standard mathematical convention is used, where " { $snippet "(" } " or " { $snippet ")" } " denotes that the end-point itself " { $emphasis "is not" } " part of the range; " { $snippet "[" } " or " { $snippet "]" } " denotes that the end-point " { $emphasis "is" } " part of the range:"
-  { $subsection <range> }
 { $subsection [a,b] }
 { $subsection (a,b] }
 { $subsection [a,b) }
 { $subsection (a,b) }
 { $subsection [0,b] }
 { $subsection [1,b] }
-  { $subsection [0,b)   } ;
+{ $subsection [0,b) }
+"Creating general ranges:"
+{ $subsection <range> }
+"Ranges are most frequently used with sequence combinators as a means of iterating over integers. For example,"
+{ $code
+    "3 10 [a,b] [ sqrt ] map"
+}
+"A range can be converted into a concrete sequence using a word such as " { $link >array } ". In most cases this is unnecessary since ranges implement the sequence protocol already. It is necessary if a mutable sequence is needed, for use with words such as " { $link set-nth } " or " { $link change-each } "." ;
+  
+ABOUT: "ranges"

basis/prettyprint/sections/sections.factor

@@ -171,10 +171,11 @@ M: block section-fits? ( section -- ? )
     line-limit? [ drop t ] [ call-next-method ] if ;
 
 : pprint-sections ( block advancer -- )
-    swap sections>> [ line-break? not ] filter
+    [
-    unclip pprint-section [
+        sections>> [ line-break? not ] filter
-        dup rot call pprint-section
+        unclip-slice pprint-section
-    ] with each ; inline
+    ] dip
+    [ [ pprint-section ] bi ] curry each ; inline
 
 M: block short-section ( block -- )
     [ advance ] pprint-sections ;

basis/smtp/smtp-tests.factor

@@ -3,12 +3,6 @@ smtp.server kernel sequences namespaces logging accessors
 assocs sorting ;
 IN: smtp.tests
 
-[ t ] [
-    <email>
-    dup clone "a" "b" set-header drop
-    headers>> assoc-empty?
-] unit-test
-
 { 0 0 } [ [ ] with-smtp-connection ] must-infer-as
 
 [ "hello\nworld" validate-address ] must-fail
@@ -60,12 +54,13 @@ IN: smtp.tests
             "Ed <dharmatech@factorcode.org>"
         } >>to
         "Doug <erg@factorcode.org>" >>from
-    prepare
+    [
-    dup headers>> >alist sort-keys [
+        email>headers sort-keys [
             drop { "Date" "Message-Id" } member? not
         ] assoc-filter
-    over to>>
+    ]
-    rot from>>
+    [ to>> [ extract-email ] map ]
+    [ from>> extract-email ] tri
 ] unit-test
 
 [ ] [ [ 4321 mock-smtp-server ] "SMTP server" spawn drop ] unit-test

basis/smtp/smtp.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
 ! Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces io io.timeouts kernel logging io.sockets
+USING: arrays namespaces io io.timeouts kernel logging io.sockets
 sequences combinators sequences.lib splitting assocs strings
-math.parser random system calendar io.encodings.ascii
+math.parser random system calendar io.encodings.ascii summary
-calendar.format accessors sets ;
+calendar.format accessors sets hashtables ;
 IN: smtp
 
 SYMBOL: smtp-domain
@@ -23,6 +23,16 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
         call
     ] with-client ; inline
 
+TUPLE: email
+    { from string }
+    { to array }
+    { cc array }
+    { bcc array }
+    { subject string }
+    { body string } ;
+
+: <email> ( -- email ) email new ;
+
 : crlf ( -- ) "\r\n" write ;
 
 : command ( string -- ) write crlf flush ;
@@ -30,10 +40,12 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
 : helo ( -- )
     esmtp get "EHLO " "HELO " ? host-name append command ;
 
+ERROR: bad-email-address email ;
+
 : validate-address ( string -- string' )
     #! Make sure we send funky stuff to the server by accident.
     dup "\r\n>" intersect empty?
-    [ "Bad e-mail address: " prepend throw ] unless ;
+    [ bad-email-address ] unless ;
 
 : mail-from ( fromaddr -- )
     "MAIL FROM:<" swap validate-address ">" 3append command ;
@@ -44,8 +56,15 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
 : data ( -- )
     "DATA" command ;
 
+ERROR: message-contains-dot message ;
+
+M: message-contains-dot summary ( obj -- string )
+    drop
+    "Message cannot contain . on a line by itself" ;
+
 : validate-message ( msg -- msg' )
-    "." over member? [ "Message cannot contain . on a line by itself" throw ] when ;
+    "." over member?
+    [ message-contains-dot ] when ;
 
 : send-body ( body -- )
     string-lines
@@ -58,19 +77,37 @@ LOG: log-smtp-connection NOTICE ( addrspec -- )
 
 LOG: smtp-response DEBUG
 
+ERROR: smtp-error message ;
+ERROR: smtp-server-busy < smtp-error ;
+ERROR: smtp-syntax-error < smtp-error ;
+ERROR: smtp-command-not-implemented < smtp-error ;
+ERROR: smtp-bad-authentication < smtp-error ;
+ERROR: smtp-mailbox-unavailable < smtp-error ;
+ERROR: smtp-user-not-local < smtp-error ;
+ERROR: smtp-exceeded-storage-allocation < smtp-error ;
+ERROR: smtp-bad-mailbox-name < smtp-error ;
+ERROR: smtp-transaction-failed < smtp-error ;
+
 : check-response ( response -- )
+    dup smtp-response
     {
-        { [ dup "220" head? ] [ smtp-response ] }
+        { [ dup "bye" head? ] [ drop ] }
-        { [ dup "235" swap subseq? ] [ smtp-response ] }
+        { [ dup "220" head? ] [ drop ] }
-        { [ dup "250" head? ] [ smtp-response ] }
+        { [ dup "235" swap subseq? ] [ drop ] }
-        { [ dup "221" head? ] [ smtp-response ] }
+        { [ dup "250" head? ] [ drop ] }
-        { [ dup "bye" head? ] [ smtp-response ] }
+        { [ dup "221" head? ] [ drop ] }
-        { [ dup "4" head? ] [ "server busy" throw ] }
+        { [ dup "354" head? ] [ drop ] }
-        { [ dup "354" head? ] [ smtp-response ] }
+        { [ dup "4" head? ] [ smtp-server-busy ] }
-        { [ dup "50" head? ] [ smtp-response "syntax error" throw ] }
+        { [ dup "500" head? ] [ smtp-syntax-error ] }
-        { [ dup "53" head? ] [ smtp-response "invalid authentication data" throw ] }
+        { [ dup "501" head? ] [ smtp-command-not-implemented ] }
-        { [ dup "55" head? ] [ smtp-response "fatal error" throw ] }
+        { [ dup "50" head? ] [ smtp-syntax-error ] }
-        [ "unknown error" throw ]
+        { [ dup "53" head? ] [ smtp-bad-authentication ] }
+        { [ dup "550" head? ] [ smtp-mailbox-unavailable ] }
+        { [ dup "551" head? ] [ smtp-user-not-local ] }
+        { [ dup "552" head? ] [ smtp-exceeded-storage-allocation ] }
+        { [ dup "553" head? ] [ smtp-bad-mailbox-name ] }
+        { [ dup "554" head? ] [ smtp-transaction-failed ] }
+        [ smtp-error ]
     } cond ;
 
 : multiline? ( response -- boolean )
@@ -89,41 +126,19 @@ LOG: smtp-response DEBUG
 
 : get-ok ( -- ) receive-response check-response ;
 
+ERROR: invalid-header-string string ;
+
 : validate-header ( string -- string' )
     dup "\r\n" intersect empty?
-    [ "Invalid header string: " prepend throw ] unless ;
+    [ invalid-header-string ] unless ;
 
 : write-header ( key value -- )
-    swap
+    [ validate-header write ]
-    validate-header write
+    [ ": " write validate-header write ] bi* crlf ;
-    ": " write
-    validate-header write
-    crlf ;
 
 : write-headers ( assoc -- )
     [ write-header ] assoc-each ;
 
-TUPLE: email from to subject headers body ;
-
-M: email clone
-    call-next-method [ clone ] change-headers ;
-
-: (send) ( email -- )
-    [
-        helo get-ok
-        dup from>> mail-from get-ok
-        dup to>> [ rcpt-to get-ok ] each
-        data get-ok
-        dup headers>> write-headers
-        crlf
-        body>> send-body get-ok
-        quit get-ok
-    ] with-smtp-connection ;
-
-: extract-email ( recepient -- email )
-    #! This could be much smarter.
-    " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
-
 : message-id ( -- string )
     [
         "<" %
@@ -135,25 +150,38 @@ M: email clone
         ">" %
     ] "" make ;
 
-: set-header ( email value key -- email )
+: extract-email ( recepient -- email )
-    pick headers>> set-at ;
+    #! This could be much smarter.
+    " " last-split1 swap or "<" ?head drop ">" ?tail drop ;
 
-: prepare ( email -- email )
+: email>headers ( email -- hashtable )
-    clone
+    [
-    dup from>> "From" set-header
+        {
-    [ extract-email ] change-from
+            [ from>> "From" set ]
-    dup to>> ", " join "To" set-header
+            [ to>> ", " join "To" set ]
-    [ [ extract-email ] map ] change-to
+            [ cc>> ", " join [ "Cc" set ] unless-empty ]
-    dup subject>> "Subject" set-header
+            [ subject>> "Subject" set ]
-    now timestamp>rfc822 "Date" set-header
+        } cleave
-    message-id "Message-Id" set-header ;
+        now timestamp>rfc822 "Date" set
+        message-id "Message-Id" set
+    ] { } make-assoc ;
 
-: <email> ( -- email )
+: (send-email) ( headers email -- )
-    email new
+    [
-    H{ } clone >>headers ;
+        helo get-ok
+        dup from>> extract-email mail-from get-ok
+        dup to>> [ extract-email rcpt-to get-ok ] each
+        dup cc>> [ extract-email rcpt-to get-ok ] each
+        dup bcc>> [ extract-email rcpt-to get-ok ] each
+        data get-ok
+        swap write-headers
+        crlf
+        body>> send-body get-ok
+        quit get-ok
+    ] with-smtp-connection ;
 
 : send-email ( email -- )
-    prepare (send) ;
+    [ email>headers ] keep (send-email) ;
 
 ! Dirk's old AUTH CRAM-MD5 code. I don't know anything about
 ! CRAM MD5, and the old code didn't work properly either, so here

basis/ui/gadgets/buttons/buttons.factor

@@ -199,14 +199,11 @@ M: radio-control model-changed
 : <radio-button> ( value model label -- gadget )
     <radio-knob> label-on-right radio-button-theme <radio-control> ;
 
-: radio-buttons-theme ( gadget -- )
-    { 5 5 } >>gap drop ;
-
 : <radio-buttons> ( model assoc -- gadget )
   <filled-pile>
     -rot
     [ <radio-button> ] <radio-controls>
-  dup radio-buttons-theme ;
+  { 5 5 } >>gap ;
 
 : <toggle-button> ( value model label -- gadget )
     <radio-control> bevel-button-theme ;