Merge branch 'master' of git://factorcode.org/git/factor into clean-linux-x86-32

basis/help/html/html.factor

@@ -4,24 +4,26 @@ USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
 io.files io.files.temp io.directories html.streams help kernel
 assocs sequences make words accessors arrays help.topics vocabs
 tools.vocabs help.vocabs namespaces prettyprint io
-vocabs.loader serialize fry memoize unicode.case math.order
+vocabs.loader serialize fry memoize ascii unicode.case math.order
-sorting debugger html xml.syntax xml.writer ;
+sorting debugger html xml.syntax xml.writer math.parser ;
 IN: help.html
 
 : escape-char ( ch -- )
-    dup H{
+    dup ascii? [
-        { CHAR: " "__quo__" }
+        dup H{
-        { CHAR: * "__star__" }
+            { CHAR: " "__quo__" }
-        { CHAR: : "__colon__" }
+            { CHAR: * "__star__" }
-        { CHAR: < "__lt__" }
+            { CHAR: : "__colon__" }
-        { CHAR: > "__gt__" }
+            { CHAR: < "__lt__" }
-        { CHAR: ? "__que__" }
+            { CHAR: > "__gt__" }
-        { CHAR: \\ "__back__" }
+            { CHAR: ? "__que__" }
-        { CHAR: | "__pipe__" }
+            { CHAR: \\ "__back__" }
-        { CHAR: / "__slash__" }
+            { CHAR: | "__pipe__" }
-        { CHAR: , "__comma__" }
+            { CHAR: / "__slash__" }
-        { CHAR: @ "__at__" }
+            { CHAR: , "__comma__" }
-    } at [ % ] [ , ] ?if ;
+            { CHAR: @ "__at__" }
+        } at [ % ] [ , ] ?if
+    ] [ number>string "__" "__" surround % ] if ;
 
 : escape-filename ( string -- filename )
     [ [ escape-char ] each ] "" make ;

basis/lcs/lcs.factor

@@ -8,7 +8,7 @@ IN: lcs
     0 1 ? + [ [ 1+ ] bi@ ] dip min min ;
 
 : lcs-step ( insert delete change same? -- next )
-    1 -1./0. ? + max max ; ! -1./0. is -inf (float)
+    1 -1/0. ? + max max ; ! -1/0. is -inf (float)
 
 :: loop-step ( i j matrix old new step -- )
     i j 1+ matrix nth nth ! insertion

basis/windows/gdi32/tags.txt

@@ -1 +1,2 @@
 unportable
+bindings

basis/windows/usp10/tags.txt

@@ -0,0 +1,2 @@
+unportable
+bindings

build-support/factor.sh

@@ -139,7 +139,6 @@ check_library_exists() {
 }
 
 check_X11_libraries() {
-    check_library_exists GLU
     check_library_exists GL
     check_library_exists X11
     check_library_exists pango-1.0
@@ -491,7 +490,7 @@ make_boot_image() {
 }
 
 install_build_system_apt() {
-    sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev glutg3-dev wget git-core git-doc rlwrap gcc make
+    sudo apt-get --yes install libc6-dev libpango1.0-dev libx11-dev xorg-dev wget git-core git-doc rlwrap gcc make
     check_ret sudo
 }
 

core/math/parser/parser-docs.factor

@@ -25,7 +25,7 @@ $nl
 ABOUT: "number-strings"
 
 HELP: digits>integer
-{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n" integer } }
+{ $values { "seq" "a sequence of integers" } { "radix" "an integer between 2 and 36" } { "n/f" { $maybe integer } } }
 { $description "Converts a sequence of digits (with most significant digit first) into an integer." }
 { $notes "This is one of the factors of " { $link string>number } "." } ;
 

core/sequences/sequences-tests.factor

@@ -227,7 +227,7 @@ unit-test
 [ -3 10 nth ] must-fail
 [ 11 10 nth ] must-fail
 
-[ -1./0. 0 delete-nth ] must-fail
+[ -1/0. 0 delete-nth ] must-fail
 [ "" ] [ "" [ CHAR: \s = ] trim ] unit-test
 [ "" ] [ "" [ CHAR: \s = ] trim-head ] unit-test
 [ "" ] [ "" [ CHAR: \s = ] trim-tail ] unit-test

core/syntax/syntax-docs.factor

@@ -66,6 +66,12 @@ ARTICLE: "syntax-floats" "Float syntax"
     "7.e13"
     "1.0e-5"
 }
+"There are three special float values:"
+{ $table
+{ "Positive infinity" { $snippet "1/0." } }
+{ "Negative infinity" { $snippet "-1/0." } }
+{ "Not-a-number" { $snippet "0/0." } }
+}
 "More information on floats can be found in " { $link "floats" } "." ;
 
 ARTICLE: "syntax-complex-numbers" "Complex number syntax"

extra/irc/client/internals/internals.factor

@@ -45,11 +45,11 @@ M: sequence chat-put [ chat-put ] with each ;
 
 ! Server message handling
 
-GENERIC: forward-message ( irc-message -- )
+GENERIC: message-forwards ( irc-message -- seq )
-M: irc-message   forward-message +server-chat+ chat-put ;
+M: irc-message   message-forwards drop +server-chat+ ;
-M: to-one-chat   forward-message dup chat> chat-put ;
+M: to-one-chat   message-forwards chat> ;
-M: to-all-chats  forward-message chats> chat-put ;
+M: to-all-chats  message-forwards drop chats> ;
-M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
+M: to-many-chats message-forwards sender>> participant-chats ;
 
 GENERIC: process-message ( irc-message -- )
 M: object process-message drop ; 
@@ -91,7 +91,7 @@ M: irc-message handle-outgoing-irc irc-message>string irc-print t ;
 : handle-reader-message ( irc-message -- ) irc> in-messages>> mailbox-put ;
 
 : (handle-disconnect) ( -- )
-    irc> in-messages>> irc-disconnected swap mailbox-put
+    irc-disconnected irc> in-messages>> mailbox-put
     irc> reconnect-time>> sleep
     (connect-irc)
     (do-login) ;
@@ -113,8 +113,12 @@ M: f      handle-input handle-disconnect ;
 ! Processing loops
 
 : in-multiplexer-loop ( -- ? )
-    irc> in-messages>> mailbox-get
+    irc> in-messages>> mailbox-get {
-    [ process-message ] [ forward-message ] [ irc-end? not ] tri ;
+        [ message-forwards ]
+        [ process-message ]
+        [ swap chat-put ]
+        [ irc-end? not ]
+    } cleave ;
 
 : strings>privmsg ( name string -- privmsg )
     " :" prepend append "PRIVMSG " prepend string>irc-message ;

extra/irc/logbot/authors.txt

@@ -0,0 +1 @@
+Bruno Deferrari

extra/irc/logbot/log-line/authors.txt

@@ -0,0 +1 @@
+Bruno Deferrari

extra/irc/logbot/log-line/log-line.factor

@@ -0,0 +1,37 @@
+! Copyright (C) 2009 Bruno Deferrari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors irc.messages irc.messages.base kernel make ;
+EXCLUDE: sequences => join ;
+IN: irc.logbot.log-line
+
+: dot-or-parens ( string -- string )
+    [ "." ] [ " (" prepend ")." append ] if-empty ;
+
+GENERIC: >log-line ( object -- line )
+
+M: irc-message >log-line line>> ;
+
+M: privmsg >log-line
+    [ "<" % dup sender>> % "> " % text>> % ] "" make ;
+
+M: join >log-line
+    [ "* " % sender>> % " has joined the channel." % ] "" make ;
+
+M: part >log-line
+    [ "* " % dup sender>> % " has left the channel" %
+      comment>> dot-or-parens % ] "" make ;
+
+M: quit >log-line
+    [ "* " % dup sender>> % " has quit" %
+      comment>> dot-or-parens % ] "" make ;
+
+M: kick >log-line
+    [ "* " % dup sender>> % " has kicked " % dup user>> %
+      " from the channel" % comment>> dot-or-parens % ] "" make ;
+
+M: participant-mode >log-line
+    [ "* " % dup sender>> % " has set mode " % dup mode>> %
+      " to " % parameter>> % ] "" make ;
+
+M: nick >log-line
+    [ "* " % dup sender>> % " is now known as " % nickname>> % ] "" make ;

extra/irc/logbot/log-line/summary.txt

@@ -0,0 +1 @@
+IRC message formatting for logs

extra/irc/logbot/logbot.factor

@@ -0,0 +1,56 @@
+! Copyright (C) 2009 Bruno Deferrari.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors calendar calendar.format destructors fry io io.encodings.8-bit
+io.files io.pathnames irc.client irc.client.chats irc.messages
+irc.messages.base kernel make namespaces sequences threads
+irc.logbot.log-line ;
+IN: irc.logbot
+
+CONSTANT: bot-channel "#concatenative"
+CONSTANT: log-directory "/tmp/logs"
+
+SYMBOL: current-day
+SYMBOL: current-stream
+
+: bot-profile ( -- obj )
+    "irc.freenode.org" 6667 "flogger" f <irc-profile> ;
+
+: add-timestamp ( string timestamp -- string )
+    timestamp>hms "[" prepend "] " append prepend ;
+
+: timestamp-path ( timestamp -- path )
+    timestamp>ymd ".log" append log-directory prepend-path ;
+
+: timestamp>stream ( timestamp  -- stream )
+    dup day-of-year current-day get = [
+        drop
+    ] [
+        current-stream get [ dispose ] when*
+        [ day-of-year current-day set ]
+        [ timestamp-path latin1 <file-writer> ] bi
+        current-stream set
+    ] if current-stream get ;
+
+: log-message ( string timestamp -- )
+    [ add-timestamp ] [ timestamp>stream ] bi
+    [ stream-print ] [ stream-flush ] bi ;
+
+GENERIC: handle-message ( msg -- )
+
+M: object      handle-message drop ;
+M: irc-message handle-message [ >log-line ] [ timestamp>> ] bi log-message ;
+
+: bot-loop ( chat -- ) dup hear handle-message bot-loop ;
+
+: start-bot ( -- )
+    bot-profile <irc-client>
+    [ connect-irc ]
+    [
+        [ bot-channel <irc-channel-chat> ] dip
+        '[ _ [ _ attach-chat ] [ bot-loop ] bi ]
+        "LogBot" spawn drop
+    ] bi ;
+
+: logbot ( -- ) start-bot ;
+
+MAIN: logbot

extra/irc/logbot/summary.txt

@@ -0,0 +1 @@
+An IRC logging bot

extra/irc/messages/messages-tests.factor

@@ -58,7 +58,8 @@ IN: irc.messages.tests
      { command "NICK" }
      { parameters  { } }
      { trailing "someuser2" }
-     { sender "someuser" } } }
+     { sender "someuser" }
+     { nickname "someuser2" } } }
 [ ":someuser!n=user@some.where NICK :someuser2"
   string>irc-message f >>timestamp ] unit-test
 

extra/irc/messages/messages.factor

@@ -7,7 +7,7 @@ IN: irc.messages
 
 ! connection
 IRC: pass        "PASS"    password ;
-IRC: nick        "NICK"    nickname ;
+IRC: nick        "NICK"    : nickname ;
 IRC: user        "USER"    user mode _ : realname ;
 IRC: oper        "OPER"    name password ;
 IRC: mode        "MODE"    name mode parameter ;

extra/math/analysis/analysis.factor

@@ -42,7 +42,7 @@ PRIVATE>
     #! gamma(x) = integral 0..inf [ t^(x-1) exp(-t) ] dt
     #! gamma(n+1) = n! for n > 0
     dup { [ 0.0 <= ] [ 1.0 mod zero? ] } 1&& [
-        drop 1./0.
+        drop 1/0.
     ] [
         [ abs gamma-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
     ] if ;
@@ -51,7 +51,7 @@ PRIVATE>
     #! gammaln(x) is an alternative when gamma(x)'s range
     #! varies too widely
     dup 0 < [
-        drop 1./0.
+        drop 1/0.
     ] [
         [ abs gammaln-lanczos6 ] keep dup 0 > [ drop ] [ gamma-neg ] if
     ] if ;

extra/tar/tar.factor

@@ -1,8 +1,10 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
 USING: combinators io io.files io.files.links io.directories
 io.pathnames io.streams.string kernel math math.parser
 continuations namespaces pack prettyprint sequences strings
 system tools.hexdump io.encodings.binary summary accessors
-io.backend byte-arrays ;
+io.backend byte-arrays io.streams.byte-array splitting ;
 IN: tar
 
 CONSTANT: zero-checksum 256
@@ -10,37 +12,35 @@ CONSTANT: block-size 512
 
 TUPLE: tar-header name mode uid gid size mtime checksum typeflag
 linkname magic version uname gname devmajor devminor prefix ;
+
 ERROR: checksum-error ;
 
-SYMBOLS: base-dir filename ;
+: trim-string ( seq -- newseq ) [ "\0 " member? ] trim ;
 
-: tar-trim ( seq -- newseq ) [ "\0 " member? ] trim ;
+: read-c-string ( n -- str/f )
-
-: read-c-string* ( n -- str/f )
     read [ zero? ] trim-tail [ f ] when-empty ;
 
 : read-tar-header ( -- obj )
     \ tar-header new
-    100 read-c-string* >>name
+        100 read-c-string >>name
-    8 read-c-string* tar-trim oct> >>mode
+        8 read-c-string trim-string oct> >>mode
-    8 read-c-string* tar-trim oct> >>uid
+        8 read-c-string trim-string oct> >>uid
-    8 read-c-string* tar-trim oct> >>gid
+        8 read-c-string trim-string oct> >>gid
-    12 read-c-string* tar-trim oct> >>size
+        12 read-c-string trim-string oct> >>size
-    12 read-c-string* tar-trim oct> >>mtime
+        12 read-c-string trim-string oct> >>mtime
-    8 read-c-string* tar-trim oct> >>checksum
+        8 read-c-string trim-string oct> >>checksum
-    read1 >>typeflag
+        read1 >>typeflag
-    100 read-c-string* >>linkname
+        100 read-c-string >>linkname
-    6 read >>magic
+        6 read >>magic
-    2 read >>version
+        2 read >>version
-    32 read-c-string* >>uname
+        32 read-c-string >>uname
-    32 read-c-string* >>gname
+        32 read-c-string >>gname
-    8 read tar-trim oct> >>devmajor
+        8 read trim-string oct> >>devmajor
-    8 read tar-trim oct> >>devminor
+        8 read trim-string oct> >>devminor
-    155 read-c-string* >>prefix ;
+        155 read-c-string >>prefix ;
 
-: header-checksum ( seq -- x )
+: checksum-header ( seq -- n )
-    148 cut-slice 8 tail-slice
+    148 cut-slice 8 tail-slice [ sum ] bi@ + 256 + ;
-    [ sum ] bi@ + 256 + ;
 
 : read-data-blocks ( tar-header -- )
     dup size>> 0 > [
@@ -60,29 +60,34 @@ SYMBOLS: base-dir filename ;
     ] if ;
 
 : parse-tar-header ( seq -- obj )
-    [ header-checksum ] keep over zero-checksum = [
+    [ checksum-header ] keep over zero-checksum = [
         2drop
         \ tar-header new
             0 >>size
             0 >>checksum
     ] [
-        [ read-tar-header ] with-string-reader
+        binary [ read-tar-header ] with-byte-reader
         [ checksum>> = [ checksum-error ] unless ] keep
     ] if ;
 
 ERROR: unknown-typeflag ch ;
-M: unknown-typeflag summary ( obj -- str )
-    ch>> 1string "Unknown typeflag: " prepend ;
 
-: tar-prepend-path ( path -- newpath )
+M: unknown-typeflag summary ( obj -- str )
-    base-dir get prepend-path ;
+    ch>> [ "Unknown typeflag: " ] dip prefix ;
 
 : read/write-blocks ( tar-header path -- )
     binary [ read-data-blocks ] with-file-writer ;
 
+: prepend-current-directory ( path -- path' )
+    current-directory get prepend-path ;
+
 ! Normal file
 : typeflag-0 ( header -- )
-    dup name>> tar-prepend-path read/write-blocks ;
+    dup name>> dup "global_pax_header" = [
+        drop [ read-data-blocks ] with-string-writer drop
+    ] [
+        prepend-current-directory read/write-blocks
+    ] if ;
 
 ! Hard link
 : typeflag-1 ( header -- ) unknown-typeflag ;
@@ -99,7 +104,7 @@ M: unknown-typeflag summary ( obj -- str )
 
 ! Directory
 : typeflag-5 ( header -- )
-    name>> tar-prepend-path make-directories ;
+    name>> prepend-current-directory make-directories ;
 
 ! FIFO
 : typeflag-6 ( header -- ) unknown-typeflag ;
@@ -139,7 +144,7 @@ M: unknown-typeflag summary ( obj -- str )
     drop ;
     ! <string-writer> [ read-data-blocks ] keep
     ! >string [ zero? ] trim-tail filename set
-    ! filename get tar-prepend-path make-directories ;
+    ! filename get prepend-current-directory make-directories ;
 
 ! Multi volume continuation entry
 : typeflag-M ( header -- ) unknown-typeflag ;
@@ -157,7 +162,7 @@ M: unknown-typeflag summary ( obj -- str )
 : typeflag-X ( header -- ) unknown-typeflag ;
 
 : (parse-tar) ( -- )
-    block-size read dup length 512 = [
+    block-size read dup length block-size = [
         parse-tar-header
         dup typeflag>>
         {
@@ -189,7 +194,7 @@ M: unknown-typeflag summary ( obj -- str )
         drop
     ] if ;
 
-: parse-tar ( path -- )
+: untar ( path -- )
-    normalize-path dup parent-directory base-dir [
+    normalize-path [ ] [ parent-directory ] bi [
          binary [ (parse-tar) ] with-file-reader
-    ] with-variable ;
+    ] with-directory ;

extra/webapps/site-watcher/site-watcher.factor

@@ -1,15 +1,16 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs db.sqlite furnace furnace.actions furnace.alloy
+USING: accessors assocs db.sqlite furnace furnace.actions
-furnace.auth furnace.auth.features.deactivate-user
+furnace.alloy furnace.auth furnace.auth.features.deactivate-user
 furnace.auth.features.edit-profile
 furnace.auth.features.recover-password
 furnace.auth.features.registration furnace.auth.login
 furnace.boilerplate furnace.redirection html.forms http.server
 http.server.dispatchers kernel namespaces site-watcher site-watcher.db
 site-watcher.private urls validators io.sockets.secure.unix.debug
-io.servers.connection db db.tuples sequences webapps.site-watcher.common
+io.servers.connection io.files.temp db db.tuples sequences
-webapps.site-watcher.watching webapps.site-watcher.spidering ;
+webapps.site-watcher.common webapps.site-watcher.watching
+webapps.site-watcher.spidering ;
 QUALIFIED: assocs
 IN: webapps.site-watcher
 

misc/fuel/fuel-font-lock.el

@@ -60,6 +60,7 @@
   (declaration keyword "declaration words")
   (ebnf-form constant "EBNF: ... ;EBNF form")
   (parsing-word keyword  "parsing words")
+  (postpone-body comment "postponed form")
   (setter-word function-name "setter words (>>foo)")
   (getter-word function-name "getter words (foo>>)")
   (stack-effect comment "stack effect specifications")
@@ -76,20 +77,19 @@
 (defun fuel-font-lock--syntactic-face (state)
   (if (nth 3 state) 'factor-font-lock-string
     (let ((c (char-after (nth 8 state))))
-      (cond ((or (char-equal c ?\ )
+      (cond ((memq c '(?\  ?\n ?E ?P))
-                 (char-equal c ?\n)
-                 (char-equal c ?E))
              (save-excursion
                (goto-char (nth 8 state))
                (beginning-of-line)
-               (cond ((looking-at-p "USING: ")
+               (cond ((looking-at "E") 'factor-font-lock-ebnf-form)
+                     ((looking-at "P") 'factor-font-lock-postpone-body)
+                     ((looking-at-p "USING: ")
                       'factor-font-lock-vocabulary-name)
-                     ((looking-at-p "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
+                     ((looking-at-p
+                       "\\(TUPLE\\|SYMBOLS\\|VARS\\|SINGLETONS\\):")
                       'factor-font-lock-symbol)
                      ((looking-at-p "C-ENUM:\\( \\|\n\\)")
                       'factor-font-lock-constant)
-                     ((looking-at-p "E")
-                      'factor-font-lock-ebnf-form)
                      (t 'default))))
             ((or (char-equal c ?U) (char-equal c ?C))
              'factor-font-lock-parsing-word)
@@ -102,9 +102,10 @@
     (,fuel-syntax--alien-function-regex (1 'factor-font-lock-type-name)
                                         (2 'factor-font-lock-word))
     (,fuel-syntax--vocab-ref-regexp  2 'factor-font-lock-vocabulary-name)
-    (,fuel-syntax--constructor-decl-regex (1 'factor-font-lock-word)
+    (,fuel-syntax--constructor-decl-regex
-                                          (2 'factor-font-lock-type-name)
+     (1 'factor-font-lock-word)
-                                          (3 'factor-font-lock-invalid-syntax nil t))
+     (2 'factor-font-lock-type-name)
+     (3 'factor-font-lock-invalid-syntax nil t))
     (,fuel-syntax--typedef-regex (1 'factor-font-lock-type-name)
                                  (2 'factor-font-lock-type-name)
                                  (3 'factor-font-lock-invalid-syntax nil t))

misc/fuel/fuel-syntax.el

@@ -247,12 +247,14 @@
     ;; Strings and chars
     ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)"
      (1 "w") (2 "\"") (4 "\""))
-    ("\\(CHAR:\\|POSTPONE:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
+    ("\\(CHAR:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w"))
     ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)"
      (3 "\"") (5 "\""))
     ("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\""))
     ("\\_<<\\(\"\\)\\_>" (1 "<b"))
     ("\\_<\\(\"\\)>\\_>" (1 ">b"))
+    ;; postpone
+    ("\\_<POSTPONE:\\( \\).*\\(\n\\)" (1 "<b") (2 ">b"))
     ;; Multiline constructs
     ("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
     ("\\_<;EBN\\(F\\)\\_>" (1 ">b"))