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

db4
Maxim Savchenko 2009-04-16 03:11:27 -04:00
commit 3059032d73
22 changed files with 205 additions and 84 deletions

View File

@ -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
sorting debugger html xml.syntax xml.writer ;
vocabs.loader serialize fry memoize ascii unicode.case math.order
sorting debugger html xml.syntax xml.writer math.parser ;
IN: help.html
: escape-char ( ch -- )
dup H{
{ CHAR: " "__quo__" }
{ CHAR: * "__star__" }
{ CHAR: : "__colon__" }
{ CHAR: < "__lt__" }
{ CHAR: > "__gt__" }
{ CHAR: ? "__que__" }
{ CHAR: \\ "__back__" }
{ CHAR: | "__pipe__" }
{ CHAR: / "__slash__" }
{ CHAR: , "__comma__" }
{ CHAR: @ "__at__" }
} at [ % ] [ , ] ?if ;
dup ascii? [
dup H{
{ CHAR: " "__quo__" }
{ CHAR: * "__star__" }
{ CHAR: : "__colon__" }
{ CHAR: < "__lt__" }
{ CHAR: > "__gt__" }
{ CHAR: ? "__que__" }
{ CHAR: \\ "__back__" }
{ CHAR: | "__pipe__" }
{ CHAR: / "__slash__" }
{ CHAR: , "__comma__" }
{ CHAR: @ "__at__" }
} at [ % ] [ , ] ?if
] [ number>string "__" "__" surround % ] if ;
: escape-filename ( string -- filename )
[ [ escape-char ] each ] "" make ;

View File

@ -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

View File

@ -1 +1,2 @@
unportable
bindings

View File

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

View File

@ -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
}

View File

@ -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 } "." } ;

View File

@ -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

View File

@ -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"

View File

@ -45,11 +45,11 @@ M: sequence chat-put [ chat-put ] with each ;
! Server message handling
GENERIC: forward-message ( irc-message -- )
M: irc-message forward-message +server-chat+ chat-put ;
M: to-one-chat forward-message dup chat> chat-put ;
M: to-all-chats forward-message chats> chat-put ;
M: to-many-chats forward-message dup sender>> participant-chats chat-put ;
GENERIC: message-forwards ( irc-message -- seq )
M: irc-message message-forwards drop +server-chat+ ;
M: to-one-chat message-forwards chat> ;
M: to-all-chats message-forwards drop chats> ;
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
[ process-message ] [ forward-message ] [ irc-end? not ] tri ;
irc> in-messages>> mailbox-get {
[ message-forwards ]
[ process-message ]
[ swap chat-put ]
[ irc-end? not ]
} cleave ;
: strings>privmsg ( name string -- privmsg )
" :" prepend append "PRIVMSG " prepend string>irc-message ;

View File

@ -0,0 +1 @@
Bruno Deferrari

View File

@ -0,0 +1 @@
Bruno Deferrari

View File

@ -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 ;

View File

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

View File

@ -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

View File

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

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;

View File

@ -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
8 read-c-string* tar-trim oct> >>mode
8 read-c-string* tar-trim oct> >>uid
8 read-c-string* tar-trim oct> >>gid
12 read-c-string* tar-trim oct> >>size
12 read-c-string* tar-trim oct> >>mtime
8 read-c-string* tar-trim oct> >>checksum
read1 >>typeflag
100 read-c-string* >>linkname
6 read >>magic
2 read >>version
32 read-c-string* >>uname
32 read-c-string* >>gname
8 read tar-trim oct> >>devmajor
8 read tar-trim oct> >>devminor
155 read-c-string* >>prefix ;
100 read-c-string >>name
8 read-c-string trim-string oct> >>mode
8 read-c-string trim-string oct> >>uid
8 read-c-string trim-string oct> >>gid
12 read-c-string trim-string oct> >>size
12 read-c-string trim-string oct> >>mtime
8 read-c-string trim-string oct> >>checksum
read1 >>typeflag
100 read-c-string >>linkname
6 read >>magic
2 read >>version
32 read-c-string >>uname
32 read-c-string >>gname
8 read trim-string oct> >>devmajor
8 read trim-string oct> >>devminor
155 read-c-string >>prefix ;
: header-checksum ( seq -- x )
148 cut-slice 8 tail-slice
[ sum ] bi@ + 256 + ;
: checksum-header ( seq -- n )
148 cut-slice 8 tail-slice [ 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 )
base-dir get prepend-path ;
M: unknown-typeflag summary ( obj -- str )
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 -- )
normalize-path dup parent-directory base-dir [
: untar ( path -- )
normalize-path [ ] [ parent-directory ] bi [
binary [ (parse-tar) ] with-file-reader
] with-variable ;
] with-directory ;

View File

@ -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
furnace.auth furnace.auth.features.deactivate-user
USING: accessors assocs db.sqlite furnace furnace.actions
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
webapps.site-watcher.watching webapps.site-watcher.spidering ;
io.servers.connection io.files.temp db db.tuples sequences
webapps.site-watcher.common webapps.site-watcher.watching
webapps.site-watcher.spidering ;
QUALIFIED: assocs
IN: webapps.site-watcher

View File

@ -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 ?\ )
(char-equal c ?\n)
(char-equal c ?E))
(cond ((memq c '(?\ ?\n ?E ?P))
(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)
(2 'factor-font-lock-type-name)
(3 'factor-font-lock-invalid-syntax nil t))
(,fuel-syntax--constructor-decl-regex
(1 'factor-font-lock-word)
(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))

View File

@ -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"))