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

db4
Bruno Deferrari 2008-09-06 17:56:59 -03:00
commit 3de7739403
238 changed files with 1238 additions and 818 deletions

View File

@ -9,13 +9,19 @@ HELP: add-alarm
{ $description "Creates and registers an alarm. If " { $snippet "frequency" } " is " { $link f } ", this will be a one-time alarm, otherwise it will fire with the given frequency. The quotation will be called from the alarm thread." } ;
HELP: later
{ $values { "quot" quotation } { "dt" duration } { "alarm" alarm } }
{ $values { "quot" quotation } { "duration" duration } { "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation once at " { $snippet "time" } " from now." } ;
HELP: cancel-alarm
{ $values { "alarm" alarm } }
{ $description "Cancels an alarm. Does nothing if the alarm is not active." } ;
HELP: every
{ $values
{ "quot" quotation } { "duration" duration }
{ "alarm" alarm } }
{ $description "Creates and registers an alarm which calls the quotation repeatedly, using " { $snippet "dt" } " as the frequency." } ;
ARTICLE: "alarms" "Alarms"
"Alarms provide a lightweight way to schedule one-time and recurring tasks without spawning a new thread."
{ $subsection alarm }

View File

@ -82,10 +82,10 @@ PRIVATE>
: add-alarm ( quot time frequency -- alarm )
<alarm> [ register-alarm ] keep ;
: later ( quot dt -- alarm )
: later ( quot duration -- alarm )
hence f add-alarm ;
: every ( quot dt -- alarm )
: every ( quot duration -- alarm )
[ hence ] keep add-alarm ;
: cancel-alarm ( alarm -- )

View File

@ -91,5 +91,5 @@ M: bit-array byte-length length 7 + -3 shift ;
INSTANCE: bit-array sequence
M: bit-array pprint-delims drop \ ?{ \ } ;
M: bit-array >pprint-sequence ;
M: bit-array pprint* pprint-object ;

View File

@ -34,5 +34,5 @@ INSTANCE: bit-vector growable
: ?V{ \ } [ >bit-vector ] parse-literal ; parsing
M: bit-vector >pprint-sequence ;
M: bit-vector pprint-delims drop \ ?V{ \ } ;
M: bit-vector pprint* pprint-object ;

View File

@ -21,8 +21,8 @@ HELP: <date>
{ $description "Returns a timestamp object representing the start of the specified day in your current timezone." }
{ $examples
{ $example "USING: calendar prettyprint ;"
"12 25 2010 <date> ."
"T{ timestamp f 12 25 2010 0 0 0 T{ duration f 0 0 0 -5 0 0 } }"
"2010 12 25 <date> ."
"T{ timestamp\n { year 2010 }\n { month 12 }\n { day 25 }\n { gmt-offset T{ duration { hour -5 } } }\n}"
}
} ;

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
!
! Channels - based on ideas from newsqueak
USING: kernel sequences sequences.lib threads continuations
random math accessors ;
USING: kernel sequences threads continuations
random math accessors random ;
IN: channels
TUPLE: channel receivers senders ;

View File

@ -0,0 +1,21 @@
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitwise strings io.binary namespaces
grouping ;
IN: checksums.common
SYMBOL: bytes-read
: calculate-pad-length ( length -- pad-length )
dup 56 < 55 119 ? swap - ;
: pad-last-block ( str big-endian? length -- str )
[
rot %
HEX: 80 ,
dup HEX: 3f bitand calculate-pad-length 0 <string> %
3 shift 8 rot [ >be ] [ >le ] if %
] "" make 64 group ;
: update-old-new ( old new -- )
[ get >r get r> ] 2keep >r >r w+ dup r> set r> set ; inline

View File

@ -0,0 +1 @@
Some code shared by MD5, SHA1 and SHA2 implementations

View File

@ -1,11 +1,14 @@
! See http://www.faqs.org/rfcs/rfc1321.html
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
sequences crypto.common byte-arrays locals sequences.private
io.encodings.binary symbols math.bitfields.lib checksums ;
sequences byte-arrays locals sequences.private
io.encodings.binary symbols math.bitwise checksums
checksums.common ;
IN: checksums.md5
! See http://www.faqs.org/rfcs/rfc1321.html
<PRIVATE
SYMBOLS: a b c d old-a old-b old-c old-d ;

View File

@ -1,7 +1,9 @@
USING: arrays combinators crypto.common kernel io
io.encodings.binary io.files io.streams.byte-array math.vectors
strings sequences namespaces math parser sequences vectors
io.binary hashtables symbols math.bitfields.lib checksums ;
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
math parser sequences assocs grouping vectors io.binary hashtables
symbols math.bitwise checksums checksums.common ;
IN: checksums.sha1
! Implemented according to RFC 3174.
@ -45,6 +47,9 @@ SYMBOLS: h0 h1 h2 h3 h4 A B C D E w K ;
{ 3 [ bitxor bitxor ] }
} case ;
: nth-int-be ( string n -- int )
4 * dup 4 + rot <slice> be> ; inline
: make-w ( str -- )
#! compute w, steps a-b of RFC 3174, section 6.1
16 [ nth-int-be w get push ] with each
@ -113,8 +118,16 @@ INSTANCE: sha1 checksum
M: sha1 checksum-stream ( stream -- sha1 )
drop [ initialize-sha1 stream>sha1 get-sha1 ] with-input-stream ;
: seq>2seq ( seq -- seq1 seq2 )
#! { abcdefgh } -> { aceg } { bdfh }
2 group flip dup empty? [ drop { } { } ] [ first2 ] if ;
: 2seq>seq ( seq1 seq2 -- seq )
#! { aceg } { bdfh } -> { abcdefgh }
[ zip concat ] keep like ;
: sha1-interleave ( string -- seq )
[ zero? ] left-trim
[ zero? ] trim-left
dup length odd? [ rest ] when
seq>2seq [ sha1 checksum-bytes ] bi@
2seq>seq ;

View File

@ -1,6 +1,8 @@
USING: crypto.common kernel splitting grouping
math sequences namespaces io.binary symbols
math.bitfields.lib checksums ;
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting grouping math sequences namespaces
io.binary symbols math.bitwise checksums checksums.common
sbufs strings ;
IN: checksums.sha2
<PRIVATE
@ -81,6 +83,8 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
[ -11 bitroll-32 ] keep
-25 bitroll-32 bitxor bitxor ; inline
: slice3 ( n seq -- a b c ) >r dup 3 + r> <slice> first3 ; inline
: T1 ( W n -- T1 )
[ swap nth ] keep
K get nth +
@ -112,6 +116,15 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
: seq>byte-array ( n seq -- string )
[ swap [ >be % ] curry each ] B{ } make ;
: preprocess-plaintext ( string big-endian? -- padded-string )
#! pad 0x80 then 00 til 8 bytes left, then 64bit length in bits
>r >sbuf r> over [
HEX: 80 ,
dup length HEX: 3f bitand
calculate-pad-length 0 <string> %
length 3 shift 8 rot [ >be ] [ >le ] if %
] "" make over push-all ;
: byte-array>sha2 ( byte-array -- string )
t preprocess-plaintext
block-size get group [ process-chunk ] each

View File

@ -1,7 +1,7 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math cocoa cocoa.messages cocoa.classes
sequences math.bitfields ;
sequences math.bitwise ;
IN: cocoa.windows
: NSBorderlessWindowMask 0 ; inline

View File

@ -3,7 +3,7 @@
USING: arrays byte-arrays generic assocs hashtables io.binary
kernel kernel.private math namespaces sequences words
quotations strings alien.accessors alien.strings layouts system
combinators math.bitfields words.private cpu.architecture
combinators math.bitwise words.private cpu.architecture
math.order accessors growable ;
IN: compiler.generator.fixup

View File

@ -647,7 +647,7 @@ UNION: immediate fixnum POSTPONE: f ;
: phantom-shuffle ( shuffle -- )
[ in>> length phantom-datastack get phantom-input ] keep
shuffle* phantom-datastack get phantom-append ;
shuffle phantom-datastack get phantom-append ;
: phantom->r ( n -- )
phantom-datastack get phantom-input

View File

@ -151,7 +151,7 @@ M: #branch normalize*
: eliminate-phi-introductions ( introductions seq terminated -- seq' )
[
[ nip ] [
dup [ +bottom+ eq? ] left-trim
dup [ +bottom+ eq? ] trim-left
[ [ length ] bi@ - tail* ] keep append
] if
] 3map ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: compiler.generator.fixup kernel namespaces sequences
words math math.bitfields io.binary parser lexer ;
words math math.bitwise io.binary parser lexer ;
IN: cpu.ppc.assembler.backend
: insn ( operand opcode -- ) { 26 0 } bitfield , ;

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations destructors kernel math
namespaces sequences sequences.lib classes.tuple words strings
tools.walker accessors combinators.lib combinators ;
namespaces sequences classes.tuple words strings
tools.walker accessors combinators ;
IN: db
TUPLE: db

View File

@ -4,8 +4,8 @@ USING: arrays assocs alien alien.syntax continuations io
kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
namespaces.lib accessors random db.queries destructors ;
combinators classes locals words tools.walker
nmake accessors random db.queries destructors ;
USE: tools.walker
IN: db.postgresql

View File

@ -1,9 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel math namespaces sequences random
strings math.parser math.intervals combinators
math.bitfields.lib namespaces.lib db db.tuples db.types
sequences.lib db.sql classes words shuffle arrays ;
USING: accessors kernel math namespaces sequences random strings
math.parser math.intervals combinators math.bitwise nmake db
db.tuples db.types db.sql classes words shuffle arrays ;
IN: db.queries
GENERIC: where ( specs obj -- )
@ -142,8 +141,8 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
: make-query ( tuple query -- tuple' )
dupd
{
[ group>> [ do-group ] [ drop ] if-seq ]
[ order>> [ do-order ] [ drop ] if-seq ]
[ group>> [ drop ] [ do-group ] if-empty ]
[ order>> [ drop ] [ do-order ] if-empty ]
[ limit>> [ do-limit ] [ drop ] if* ]
[ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ;

View File

@ -1,6 +1,6 @@
USING: kernel parser quotations classes.tuple words math.order
namespaces.lib namespaces sequences arrays combinators
prettyprint strings math.parser sequences.lib math symbols ;
nmake namespaces sequences arrays combinators
prettyprint strings math.parser math symbols ;
IN: db.sql
SYMBOLS: insert update delete select distinct columns from as

View File

@ -1,13 +1,11 @@
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators math.intervals
io namespaces.lib accessors vectors math.ranges random
math.bitfields.lib db.queries destructors ;
USE: tools.walker
USING: alien arrays assocs classes compiler db hashtables
io.files kernel math math.parser namespaces prettyprint
sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
math.bitwise db.queries destructors ;
IN: db.sqlite
TUPLE: sqlite-db < db path ;

View File

@ -3,8 +3,8 @@
USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitfields.lib
math.ranges strings sequences.lib urls fry ;
db.postgresql accessors random math.bitwise
math.ranges strings urls fry ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real

View File

@ -3,7 +3,7 @@
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
destructors mirrors sequences.lib combinators.lib ;
destructors mirrors ;
IN: db.tuples
: define-persistent ( class table columns -- )
@ -71,13 +71,14 @@ SINGLETON: retryable
] 2map >>bind-params ;
M: retryable execute-statement* ( statement type -- )
drop [
drop [ retries>> ] [
[
nip
[ query-results dispose t ]
[ ]
[ regenerate-params bind-statement* f ] cleanup
] curry
] [ retries>> ] bi retry drop ;
] bi attempt-all drop ;
: resulting-tuple ( class row out-params -- tuple )
rot class new [
@ -159,7 +160,8 @@ M: retryable execute-statement* ( statement type -- )
dup dup class <select-by-slots-statement> do-select ;
: select-tuple ( tuple -- tuple/f )
dup dup class \ query new 1 >>limit <query> do-select ?first ;
dup dup class \ query new 1 >>limit <query> do-select
[ f ] [ first ] if-empty ;
: do-count ( exemplar-tuple statement -- tuples )
[

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
sequences continuations sequences.deep
words namespaces slots slots.private classes mirrors
classes.tuple combinators calendar.format symbols
classes.singleton accessors quotations random ;

View File

@ -61,8 +61,8 @@ INSTANCE: float-array sequence
: F{ \ } [ >float-array ] parse-literal ; parsing
M: float-array pprint-delims drop \ F{ \ } ;
M: float-array >pprint-sequence ;
M: float-array pprint* pprint-object ;
USING: hints math.vectors arrays ;

View File

@ -34,5 +34,5 @@ INSTANCE: float-vector growable
: FV{ \ } [ >float-vector ] parse-literal ; parsing
M: float-vector >pprint-sequence ;
M: float-vector pprint-delims drop \ FV{ \ } ;
M: float-vector pprint* pprint-object ;

View File

@ -14,6 +14,7 @@ ARTICLE: "span-elements" "Span elements"
{ $subsection $link }
{ $subsection $vocab-link }
{ $subsection $snippet }
{ $subsection $slot }
{ $subsection $url } ;
ARTICLE: "block-elements" "Block elements"
@ -212,6 +213,18 @@ HELP: $code
{ $markup-example { $code "2 2 + ." } }
} ;
HELP: $nl
{ $values { "children" "unused parameter" } }
{ $description "Prints a paragraph break. The parameter is unused." } ;
HELP: $snippet
{ $values { "children" "markup elements" } }
{ $description "Prints a key word or otherwise notable snippet of text, such as a type or a word input parameter. To document slot names, use " { $link $slot } "." } ;
HELP: $slot
{ $values { "children" "markup elements" } }
{ $description "Prints a tuple slot name in the same way as a snippet. The help tool can check that there exists an accessor with this name." } ;
HELP: $vocabulary
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
{ $description "Prints a word's vocabulary. This markup element is automatically output by the help system, so help descriptions of parsing words should not call it." } ;

View File

@ -3,7 +3,7 @@
USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots
vocabs help.stylesheet help.topics vocabs.loader ;
vocabs help.stylesheet help.topics vocabs.loader alias ;
IN: help.markup
! Simple markup language.
@ -61,6 +61,9 @@ M: f print-element drop ;
: $snippet ( children -- )
[ snippet-style get print-element* ] ($span) ;
! for help-lint
ALIAS: $slot $snippet
: $emphasis ( children -- )
[ emphasis-style get print-element* ] ($span) ;

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors strings namespaces assocs hashtables
mirrors math fry sequences sequences.lib words continuations ;
mirrors math fry sequences words continuations ;
IN: html.forms
TUPLE: form errors values validation-failed ;

View File

@ -3,7 +3,7 @@
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math urls present
unicode.case mirrors fry math urls present
multiline xml xml.data xml.writer xml.utilities
html.forms
html.elements

View File

@ -4,7 +4,7 @@ IN: html.templates.chloe.syntax
USING: accessors kernel sequences combinators kernel namespaces
classes.tuple assocs splitting words arrays memoize parser lexer
io io.files io.encodings.utf8 io.streams.string
unicode.case tuple-syntax mirrors fry math urls
unicode.case mirrors fry math urls
multiline xml xml.data xml.writer xml.utilities
html.elements
html.components

View File

@ -1,5 +1,5 @@
USING: http.client http.client.private http tools.test
tuple-syntax namespaces urls ;
namespaces urls ;
[ "localhost" f ] [ "localhost" parse-host ] unit-test
[ "localhost" 8888 ] [ "localhost:8888" parse-host ] unit-test
@ -9,12 +9,12 @@ tuple-syntax namespaces urls ;
[ "www.arc.com" ] [ "http://www.arc.com////" download-name ] unit-test
[
TUPLE{ request
url: TUPLE{ url protocol: "http" host: "www.apple.com" port: 80 path: "/index.html" }
method: "GET"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
T{ request
{ url T{ url { protocol "http" } { host "www.apple.com" } { port 80 } { path "/index.html" } } }
{ method "GET" }
{ version "1.1" }
{ cookies V{ } }
{ header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
}
] [
"http://www.apple.com/index.html"
@ -22,12 +22,12 @@ tuple-syntax namespaces urls ;
] unit-test
[
TUPLE{ request
url: TUPLE{ url protocol: "https" host: "www.amazon.com" port: 443 path: "/index.html" }
method: "GET"
version: "1.1"
cookies: V{ }
header: H{ { "connection" "close" } { "user-agent" "Factor http.client" } }
T{ request
{ url T{ url { protocol "https" } { host "www.amazon.com" } { port 443 } { path "/index.html" } } }
{ method "GET" }
{ version "1.1" }
{ cookies V{ } }
{ header H{ { "connection" "close" } { "user-agent" "Factor http.client" } } }
}
] [
"https://www.amazon.com/index.html"

View File

@ -113,7 +113,7 @@ SYMBOL: redirects
PRIVATE>
: read-chunk-size ( -- n )
read-crlf ";" split1 drop [ blank? ] right-trim
read-crlf ";" split1 drop [ blank? ] trim-right
hex> [ "Bad chunk size" throw ] unless* ;
: read-chunks ( -- )

View File

@ -1,8 +1,8 @@
USING: http http.server http.client tools.test multiline
tuple-syntax io.streams.string io.encodings.utf8
io.encodings.8-bit io.encodings.binary io.encodings.string
kernel arrays splitting sequences assocs io.sockets db db.sqlite
continuations urls hashtables accessors ;
io.streams.string io.encodings.utf8 io.encodings.8-bit
io.encodings.binary io.encodings.string kernel arrays splitting
sequences assocs io.sockets db db.sqlite continuations urls
hashtables accessors ;
IN: http.tests
[ "text/plain" latin1 ] [ "text/plain" parse-content-type ] unit-test
@ -24,13 +24,13 @@ blah
;
[
TUPLE{ request
url: TUPLE{ url path: "/bar" }
method: "POST"
version: "1.1"
header: H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } }
post-data: TUPLE{ post-data content: "blah" raw: "blah" content-type: "application/octet-stream" }
cookies: V{ }
T{ request
{ url T{ url { path "/bar" } } }
{ method "POST" }
{ version "1.1" }
{ header H{ { "some-header" "1; 2" } { "content-length" "4" } { "content-type" "application/octet-stream" } } }
{ post-data T{ post-data { content "blah" } { raw "blah" } { content-type "application/octet-stream" } } }
{ cookies V{ } }
}
] [
read-request-test-1 lf>crlf [
@ -62,12 +62,12 @@ Host: www.sex.com
;
[
TUPLE{ request
url: TUPLE{ url host: "www.sex.com" path: "/bar" }
method: "HEAD"
version: "1.1"
header: H{ { "host" "www.sex.com" } }
cookies: V{ }
T{ request
{ url T{ url { host "www.sex.com" } { path "/bar" } } }
{ method "HEAD" }
{ version "1.1" }
{ header H{ { "host" "www.sex.com" } } }
{ cookies V{ } }
}
] [
read-request-test-2 lf>crlf [
@ -103,14 +103,14 @@ blah
;
[
TUPLE{ response
version: "1.1"
code: 404
message: "not found"
header: H{ { "content-type" "text/html; charset=UTF-8" } }
cookies: { }
content-type: "text/html"
content-charset: utf8
T{ response
{ version "1.1" }
{ code 404 }
{ message "not found" }
{ header H{ { "content-type" "text/html; charset=UTF-8" } } }
{ cookies { } }
{ content-type "text/html" }
{ content-charset utf8 }
}
] [
read-response-test-1 lf>crlf

View File

@ -1,7 +1,7 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel combinators math namespaces
assocs assocs.lib sequences splitting sorting sets debugger
assocs sequences splitting sorting sets debugger
strings vectors hashtables quotations arrays byte-arrays
math.parser calendar calendar.format present
@ -27,9 +27,12 @@ IN: http
: (read-header) ( -- alist )
[ read-crlf dup f like ] [ parse-header-line ] [ drop ] produce ;
: collect-headers ( assoc -- assoc' )
H{ } clone [ '[ , push-at ] assoc-each ] keep ;
: process-header ( alist -- assoc )
f swap [ [ swap or dup ] dip swap ] assoc-map nip
[ ?push ] histogram [ "; " join ] assoc-map
collect-headers [ "; " join ] assoc-map
>hashtable ;
: read-header ( -- assoc )

View File

@ -45,9 +45,9 @@ TUPLE: file-responder root hook special allow-listings ;
[ file-responder get hook>> call ] [ 2drop <304> ] if ;
: serving-path ( filename -- filename )
file-responder get root>> right-trim-separators
file-responder get root>> trim-right-separators
"/"
rot "" or left-trim-separators 3append ;
rot "" or trim-left-separators 3append ;
: serve-file ( filename -- response )
dup mime-type

View File

@ -54,7 +54,7 @@ os { winnt linux macosx } member? [
"m" get next-change drop
dup print flush
dup parent-directory
[ right-trim-separators "xyz" tail? ] either? not
[ trim-right-separators "xyz" tail? ] either? not
] loop
"c1" get count-down
@ -63,7 +63,7 @@ os { winnt linux macosx } member? [
"m" get next-change drop
dup print flush
dup parent-directory
[ right-trim-separators "yxy" tail? ] either? not
[ trim-right-separators "yxy" tail? ] either? not
] loop
"c2" get count-down

View File

@ -77,17 +77,9 @@ M: inet4 make-sockaddr ( inet -- sockaddr )
"0.0.0.0" or
rot inet-pton *uint over set-sockaddr-in-addr ;
<PRIVATE
SYMBOL: port-override
: (port) ( port -- port' ) port-override get swap or ;
PRIVATE>
M: inet4 parse-sockaddr
>r dup sockaddr-in-addr <uint> r> inet-ntop
swap sockaddr-in-port ntohs (port) <inet4> ;
swap sockaddr-in-port ntohs <inet4> ;
TUPLE: inet6 host port ;
@ -140,7 +132,7 @@ M: inet6 make-sockaddr ( inet -- sockaddr )
M: inet6 parse-sockaddr
>r dup sockaddr-in6-addr r> inet-ntop
swap sockaddr-in6-port ntohs (port) <inet6> ;
swap sockaddr-in6-port ntohs <inet6> ;
: addrspec-of-family ( af -- addrspec )
{
@ -259,17 +251,6 @@ HOOK: (send) io-backend ( packet addrspec datagram -- )
[ addrinfo>addrspec ] map
sift ;
: prepare-resolve-host ( addrspec -- host' serv' flags )
#! If the port is a number, we resolve for 'http' then
#! change it later. This is a workaround for a FreeBSD
#! getaddrinfo() limitation -- on Windows, Linux and Mac,
#! we can convert a number to a string and pass that as the
#! service name, but on FreeBSD this gives us an unknown
#! service error.
[ host>> ]
[ port>> dup integer? [ port-override set "http" ] when ] bi
over 0 AI_PASSIVE ? ;
HOOK: addrinfo-error io-backend ( n -- )
GENERIC: resolve-host ( addrspec -- seq )
@ -278,17 +259,24 @@ TUPLE: inet host port ;
C: <inet> inet
M: inet resolve-host
[
prepare-resolve-host
: resolve-passive-host ( -- addrspecs )
{ T{ inet6 f "::" f } T{ inet4 f "0.0.0.0" f } } [ clone ] map ;
: prepare-addrinfo ( -- addrinfo )
"addrinfo" <c-object>
[ set-addrinfo-flags ] keep
PF_UNSPEC over set-addrinfo-family
IPPROTO_TCP over set-addrinfo-protocol
f <void*> [ getaddrinfo addrinfo-error ] keep *void*
[ parse-addrinfo-list ] keep
freeaddrinfo
] with-scope ;
IPPROTO_TCP over set-addrinfo-protocol ;
: fill-in-ports ( addrspecs port -- addrspecs )
[ >>port ] curry map ;
M: inet resolve-host
[ port>> ] [ host>> ] bi [
f prepare-addrinfo f <void*>
[ getaddrinfo addrinfo-error ] keep *void*
[ parse-addrinfo-list ] keep freeaddrinfo
] [ resolve-passive-host ] if*
swap fill-in-ports ;
M: f resolve-host drop { } ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.backend io.ports io.unix.backend io.files io
unix unix.stat unix.time kernel math continuations
math.bitfields byte-arrays alien combinators calendar
math.bitwise byte-arrays alien combinators calendar
io.encodings.binary accessors sequences strings system
io.files.private destructors ;

View File

@ -1,4 +1,4 @@
USING: kernel io.ports io.unix.backend math.bitfields
USING: kernel io.ports io.unix.backend math.bitwise
unix io.files.unique.backend system ;
IN: io.unix.files.unique

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types kernel math math.bitfields namespaces
USING: alien.c-types kernel math math.bitwise namespaces
locals accessors combinators threads vectors hashtables
sequences assocs continuations sets
unix unix.time unix.kqueue unix.process

View File

@ -4,7 +4,7 @@ USING: kernel io.backend io.monitors io.monitors.recursive
io.files io.buffers io.monitors io.ports io.timeouts
io.unix.backend io.unix.select io.encodings.utf8
unix.linux.inotify assocs namespaces threads continuations init
math math.bitfields sets alien alien.strings alien.c-types
math math.bitwise sets alien alien.strings alien.c-types
vocabs.loader accessors system hashtables destructors unix ;
IN: io.unix.linux.monitors

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien io io.files kernel math math.bitfields system unix
USING: alien io io.files kernel math math.bitwise system unix
io.unix.backend io.ports io.mmap destructors locals accessors ;
IN: io.unix.mmap

View File

@ -4,8 +4,7 @@ USING: alien.c-types io.binary io.backend io.files io.buffers
io.windows kernel math splitting
windows windows.kernel32 windows.time calendar combinators
math.functions sequences namespaces words symbols system
io.ports destructors accessors
math.bitfields math.bitfields.lib ;
io.ports destructors accessors math.bitwise ;
IN: io.windows.files
: open-file ( path access-mode create-mode flags -- handle )

View File

@ -1,6 +1,6 @@
USING: alien alien.c-types arrays destructors generic io.mmap
io.ports io.windows io.windows.files io.windows.privileges
kernel libc math math.bitfields namespaces quotations sequences
kernel libc math math.bitwise namespaces quotations sequences
windows windows.advapi32 windows.kernel32 io.backend system
accessors locals ;
IN: io.windows.mmap

View File

@ -21,8 +21,8 @@ IN: io.windows.nt.files.tests
[ t ] [ "\\\\" root-directory? ] unit-test
[ t ] [ "/" root-directory? ] unit-test
[ t ] [ "//" root-directory? ] unit-test
[ t ] [ "c:\\" right-trim-separators root-directory? ] unit-test
[ t ] [ "Z:\\" right-trim-separators root-directory? ] unit-test
[ t ] [ "c:\\" trim-right-separators root-directory? ] unit-test
[ t ] [ "Z:\\" trim-right-separators root-directory? ] unit-test
[ f ] [ "c:\\foo" root-directory? ] unit-test
[ f ] [ "." root-directory? ] unit-test
[ f ] [ ".." root-directory? ] unit-test

View File

@ -22,7 +22,7 @@ M: winnt root-directory? ( path -- ? )
{
{ [ dup empty? ] [ f ] }
{ [ dup [ path-separator? ] all? ] [ t ] }
{ [ dup right-trim-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
{ [ dup trim-right-separators { [ length 2 = ] [ second CHAR: : = ] } 1&& ] [ t ] }
[ f ]
} cond nip ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types libc destructors locals
kernel math assocs namespaces continuations sequences hashtables
sorting arrays combinators math.bitfields strings system
sorting arrays combinators math.bitwise strings system
accessors threads splitting
io.backend io.windows io.windows.nt.backend io.windows.nt.files
io.monitors io.ports io.buffers io.files io.timeouts io

View File

@ -1,7 +1,7 @@
! Copyright (C) 2007, 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays destructors io io.windows libc
windows.types math.bitfields windows.kernel32 windows namespaces
windows.types math.bitwise windows.kernel32 windows namespaces
kernel sequences windows.errors assocs math.parser system random
combinators accessors io.pipes io.ports ;
IN: io.windows.nt.pipes

View File

@ -1,6 +1,6 @@
USING: alien alien.c-types alien.syntax arrays continuations
destructors generic io.mmap io.ports io.windows io.windows.files
kernel libc math math.bitfields namespaces quotations sequences windows
kernel libc math math.bitwise namespaces quotations sequences windows
windows.advapi32 windows.kernel32 io.backend system accessors
io.windows.privileges ;
IN: io.windows.nt.privileges

View File

@ -5,7 +5,7 @@ io.buffers io.files io.ports io.sockets io.binary
io.sockets io.timeouts windows.errors strings
kernel math namespaces sequences windows windows.kernel32
windows.shell32 windows.types windows.winsock splitting
continuations math.bitfields system accessors ;
continuations math.bitwise system accessors ;
IN: io.windows
: set-inherit ( handle ? -- )

View File

@ -1,6 +1,5 @@
USING: sequences kernel math locals math.order math.ranges
accessors combinators.lib arrays namespaces combinators
combinators.short-circuit ;
accessors arrays namespaces combinators combinators.short-circuit ;
IN: lcs
<PRIVATE

View File

@ -46,7 +46,7 @@ SYMBOL: log-service
dup array? [ dup length 1 = [ first ] when ] when
dup string? [
[
string-limit off
string-limit? off
1 line-limit set
3 nesting-limit set
0 margin set

View File

@ -2,8 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors peg peg.parsers memoize kernel sequences
logging arrays words strings vectors io io.files io.encodings.utf8
namespaces combinators combinators.lib logging.server
calendar calendar.format ;
namespaces combinators logging.server calendar calendar.format ;
IN: logging.parser
TUPLE: log-entry date level word-name message ;

View File

@ -1,27 +0,0 @@
USING: accessors math math.bitfields tools.test kernel words ;
IN: math.bitfields.tests
[ 0 ] [ { } bitfield ] unit-test
[ 256 ] [ 1 { 8 } bitfield ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test
: a 1 ; inline
: b 2 ; inline
: foo ( -- flags ) { a b } flags ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer
[ 0 ] [ { } bitfield-quot call ] unit-test
[ 256 ] [ 1 { 8 } bitfield-quot call ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield-quot call ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield-quot call ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield-quot call ] unit-test

View File

@ -1,37 +0,0 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math sequences words
namespaces stack-checker.transforms ;
IN: math.bitfields
GENERIC: (bitfield) ( value accum shift -- newaccum )
M: integer (bitfield) ( value accum shift -- newaccum )
swapd shift bitor ;
M: pair (bitfield) ( value accum pair -- newaccum )
first2 >r dup word? [ swapd execute ] when r> shift bitor ;
: bitfield ( values... bitspec -- n )
0 [ (bitfield) ] reduce ;
: flags ( values -- n )
0 [ dup word? [ execute ] when bitor ] reduce ;
GENERIC: (bitfield-quot) ( spec -- quot )
M: integer (bitfield-quot) ( spec -- quot )
[ swapd shift bitor ] curry ;
M: pair (bitfield-quot) ( spec -- quot )
first2 over word? [ >r swapd execute r> ] [ ] ?
[ shift bitor ] append 2curry ;
: bitfield-quot ( spec -- quot )
[ (bitfield-quot) ] map [ 0 ] prefix concat ;
\ bitfield [ bitfield-quot ] 1 define-transform
\ flags [
[ 0 , [ , \ bitor , ] each ] [ ] make
] 1 define-transform

View File

@ -1 +0,0 @@
Domain-specific language for constructing integers

View File

@ -1 +1,2 @@
Slava Pestov
Doug Coleman

View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax math ;
IN: math.bitfields
IN: math.bitwise
ARTICLE: "math-bitfields" "Constructing bit fields"
"Some applications, such as binary communication protocols and assemblers, need to construct integers from elaborate bit field specifications. Hand-coding this using " { $link shift } " and " { $link bitor } " results in repetitive code. A higher-level facility exists to factor out this repetition:"
@ -35,3 +35,16 @@ HELP: bitfield
" } ;"
}
} ;
HELP: bits
{ $values { "m" integer } { "n" integer } { "m'" integer } }
{ $description "Keep only n bits from the integer m." }
{ $example "USING: math.bitwise prettyprint ;" "HEX: 123abcdef 16 bits .h" "cdef" } ;
HELP: bitroll
{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" integer } }
{ $description "Roll n by s bits to the left, wrapping around after w bits." }
{ $examples
{ $example "USING: math.bitwise prettyprint ;" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
{ $example "USING: math.bitwise prettyprint ;" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
} ;

View File

@ -0,0 +1,29 @@
USING: accessors math math.bitwise tools.test kernel words ;
IN: math.bitwise.tests
[ 0 ] [ 1 0 0 bitroll ] unit-test
[ 1 ] [ 1 0 1 bitroll ] unit-test
[ 1 ] [ 1 1 1 bitroll ] unit-test
[ 1 ] [ 1 0 2 bitroll ] unit-test
[ 1 ] [ 1 0 1 bitroll ] unit-test
[ 1 ] [ 1 20 2 bitroll ] unit-test
[ 1 ] [ 1 8 8 bitroll ] unit-test
[ 1 ] [ 1 -8 8 bitroll ] unit-test
[ 1 ] [ 1 -32 8 bitroll ] unit-test
[ 128 ] [ 1 -1 8 bitroll ] unit-test
[ 8 ] [ 1 3 32 bitroll ] unit-test
[ 0 ] [ { } bitfield ] unit-test
[ 256 ] [ 1 { 8 } bitfield ] unit-test
[ 268 ] [ 3 1 { 8 2 } bitfield ] unit-test
[ 268 ] [ 1 { 8 { 3 2 } } bitfield ] unit-test
[ 512 ] [ 1 { { 1+ 8 } } bitfield ] unit-test
: a 1 ; inline
: b 2 ; inline
: foo ( -- flags ) { a b } flags ;
[ 3 ] [ foo ] unit-test
[ 3 ] [ { a b } flags ] unit-test
\ foo must-infer

View File

@ -0,0 +1,94 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions sequences
sequences.private words namespaces macros hints
combinators fry ;
IN: math.bitwise
! utilities
: clear-bit ( x n -- y ) 2^ bitnot bitand ; inline
: set-bit ( x n -- y ) 2^ bitor ; inline
: bit-clear? ( x n -- ? ) 2^ bitand zero? ; inline
: unmask ( x n -- ? ) bitnot bitand ; inline
: unmask? ( x n -- ? ) unmask 0 > ; inline
: mask ( x n -- ? ) bitand ; inline
: mask? ( x n -- ? ) mask 0 > ; inline
: wrap ( m n -- m' ) 1- bitand ; inline
: bits ( m n -- m' ) 2^ wrap ; inline
: mask-bit ( m n -- m' ) 1- 2^ mask ; inline
: shift-mod ( n s w -- n )
>r shift r> 2^ wrap ; inline
: bitroll ( x s w -- y )
[ wrap ] keep
[ shift-mod ]
[ [ - ] keep shift-mod ] 3bi bitor ; inline
: bitroll-32 ( n s -- n' ) 32 bitroll ;
HINTS: bitroll-32 bignum fixnum ;
: bitroll-64 ( n s -- n' ) 64 bitroll ;
HINTS: bitroll-64 bignum fixnum ;
! 32-bit arithmetic
: w+ ( int int -- int ) + 32 bits ; inline
: w- ( int int -- int ) - 32 bits ; inline
: w* ( int int -- int ) * 32 bits ; inline
! flags
MACRO: flags ( values -- )
[ 0 ] [ [ execute bitor ] curry compose ] reduce ;
! bitfield
<PRIVATE
GENERIC: (bitfield-quot) ( spec -- quot )
M: integer (bitfield-quot) ( spec -- quot )
[ swapd shift bitor ] curry ;
M: pair (bitfield-quot) ( spec -- quot )
first2 over word? [ >r swapd execute r> ] [ ] ?
[ shift bitor ] append 2curry ;
PRIVATE>
MACRO: bitfield ( bitspec -- )
[ 0 ] [ (bitfield-quot) compose ] reduce ;
! bit-count
<PRIVATE
DEFER: byte-bit-count
<<
\ byte-bit-count
256 [
0 swap [ [ 1+ ] when ] each-bit
] B{ } map-as '[ HEX: ff bitand , nth-unsafe ] define-inline
>>
GENERIC: (bit-count) ( x -- n )
M: fixnum (bit-count)
{
[ byte-bit-count ]
[ -8 shift byte-bit-count ]
[ -16 shift byte-bit-count ]
[ -24 shift byte-bit-count ]
} cleave + + + ;
M: bignum (bit-count)
dup 0 = [ drop 0 ] [
[ byte-bit-count ] [ -8 shift (bit-count) ] bi +
] if ;
PRIVATE>
: bit-count ( x -- n )
dup 0 >= [ (bit-count) ] [ bitnot (bit-count) ] if ; inline

View File

@ -0,0 +1 @@
Bitwise arithmetic utilities

View File

@ -49,5 +49,5 @@ IN: syntax
: C{ \ } [ first2 rect> ] parse-literal ; parsing
M: complex pprint-delims drop \ C{ \ } ;
M: complex >pprint-sequence >rect 2array ;
M: complex pprint* pprint-object ;

View File

@ -9,14 +9,30 @@ HELP: <"
{ $syntax "<\" text \">" }
{ $description "This forms a multiline string literal ending in \">. Unlike the " { $link POSTPONE: STRING: } " form, you can end it in the middle of a line. This construct is non-nesting. In the example above, the string would be parsed as \"text\"." } ;
{ POSTPONE: <" POSTPONE: STRING: } related-words
HELP: /*
{ $syntax "/* comment */" }
{ $description "Provides C-like comments that can span multiple lines. One caveat is that " { $snippet "/*" } " and " { $snippet "*/" } " are still tokens and must not abut the comment text itself." }
{ $example "USING: multiline ;"
"/* I think that I shall never see"
" A poem lovely as a tree. */"
""
} ;
HELP: parse-here
{ $values { "str" "a string" } }
{ $description "Parses a multiline string literal, as used by " { $link POSTPONE: STRING: } "." } ;
{ POSTPONE: <" POSTPONE: STRING: } related-words
HELP: parse-multiline-string
{ $values { "end-text" "a string delineating the end" } { "str" "the parsed string" } }
{ $description "Parses a multiline string literal, as used by " { $link POSTPONE: <" } ". The end-text is the delimiter for the end." } ;
{ $description "Parses the input stream until the " { $snippet "end-text" } " is reached and returns the parsed text as a string." }
{ $notes "Used to implement " { $link POSTPONE: /* } " and " { $link POSTPONE: <" } "." } ;
{ parse-here parse-multiline-string } related-words
ARTICLE: "multiline" "Multiline"
"Multiline strings:"
{ $subsection POSTPONE: STRING: }
{ $subsection POSTPONE: <" }
"Multiline comments:"
{ $subsection POSTPONE: /* }
"Writing new multiline parsing words:"
{ $subsection parse-multiline-string }
;
ABOUT: "multiline"

View File

@ -4,6 +4,7 @@ USING: namespaces parser lexer kernel sequences words quotations math
accessors ;
IN: multiline
<PRIVATE
: next-line-text ( -- str )
lexer get dup next-line line-text>> ;
@ -13,6 +14,7 @@ IN: multiline
[ drop lexer get next-line ]
[ % "\n" % (parse-here) ] if
] [ ";" unexpected-eof ] if* ;
PRIVATE>
: parse-here ( -- str )
[ (parse-here) ] "" make but-last
@ -22,6 +24,7 @@ IN: multiline
CREATE-WORD
parse-here 1quotation define-inline ; parsing
<PRIVATE
: (parse-multiline-string) ( start-index end-text -- end-index )
lexer get line-text>> [
2dup start
@ -30,6 +33,7 @@ IN: multiline
lexer get next-line swap (parse-multiline-string)
] if*
] [ nip unexpected-eof ] if* ;
PRIVATE>
: parse-multiline-string ( end-text -- str )
[

View File

@ -0,0 +1,8 @@
IN: nmake.tests
USING: nmake kernel tools.test ;
[ ] [ [ ] { } nmake ] unit-test
[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test
[ [ ] [ call ] curry { { } } nmake ] must-infer

44
basis/nmake/nmake.factor Normal file
View File

@ -0,0 +1,44 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences math.parser kernel macros
generalizations locals ;
IN: nmake
SYMBOL: building-seq
: get-building-seq ( n -- seq )
building-seq get nth ;
: n, ( obj n -- ) get-building-seq push ;
: n% ( seq n -- ) get-building-seq push-all ;
: n# ( num n -- ) >r number>string r> n% ;
: 0, ( obj -- ) 0 n, ;
: 0% ( seq -- ) 0 n% ;
: 0# ( num -- ) 0 n# ;
: 1, ( obj -- ) 1 n, ;
: 1% ( seq -- ) 1 n% ;
: 1# ( num -- ) 1 n# ;
: 2, ( obj -- ) 2 n, ;
: 2% ( seq -- ) 2 n% ;
: 2# ( num -- ) 2 n# ;
: 3, ( obj -- ) 3 n, ;
: 3% ( seq -- ) 3 n% ;
: 3# ( num -- ) 3 n# ;
: 4, ( obj -- ) 4 n, ;
: 4% ( seq -- ) 4 n% ;
: 4# ( num -- ) 4 n# ;
MACRO: finish-nmake ( exemplars -- )
length [ firstn ] curry ;
:: nmake ( quot exemplars -- )
[
exemplars
[ 0 swap new-resizable ] map
building-seq set
quot call
building-seq get
exemplars [ [ like ] 2map ] [ finish-nmake ] bi
] with-scope ; inline

View File

@ -2,7 +2,7 @@
! Portions copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators kernel system namespaces
assocs parser lexer sequences words quotations math.bitfields ;
assocs parser lexer sequences words quotations math.bitwise ;
IN: openssl.libssl

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel compiler.units words arrays strings math.parser sequences
quotations vectors namespaces math assocs continuations peg
peg.parsers unicode.categories multiline combinators.lib
peg.parsers unicode.categories multiline
splitting accessors effects sequences.deep peg.search
combinators.short-circuit lexer io.streams.string
stack-checker io prettyprint combinators parser ;

View File

@ -513,18 +513,11 @@ TUPLE: action-parser p1 quot ;
M: action-parser (compile) ( peg -- quot )
[ p1>> compile-parser 1quotation ] [ quot>> ] bi '[ @ , check-action ] ;
: left-trim-slice ( string -- string )
#! Return a new string without any leading whitespace
#! from the original string.
dup empty? [
dup first blank? [ rest-slice left-trim-slice ] when
] unless ;
TUPLE: sp-parser p1 ;
M: sp-parser (compile) ( peg -- quot )
p1>> compile-parser 1quotation '[
input-slice left-trim-slice input-from pos set @
input-slice [ blank? ] trim-left-slice input-from pos set @
] ;
TUPLE: delay-parser quot ;

View File

@ -51,5 +51,5 @@ M: persistent-hash clone ;
: PH{ \ } [ >persistent-hash ] parse-literal ; parsing
M: persistent-hash pprint-delims drop \ PH{ \ } ;
M: persistent-hash >pprint-sequence >alist ;
M: persistent-hash pprint* pprint-object ;

View File

@ -1,7 +1,7 @@
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: math math.bit-count arrays kernel accessors locals sequences
sequences.private sequences.lib
USING: math math.bitwise arrays kernel accessors locals sequences
sequences.private
persistent.sequences
persistent.hashtables.config
persistent.hashtables.nodes ;

View File

@ -1,6 +1,6 @@
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: kernel accessors math arrays fry sequences sequences.lib
USING: kernel accessors math arrays fry sequences
locals persistent.sequences
persistent.hashtables.config
persistent.hashtables.nodes

View File

@ -1,7 +1,7 @@
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: math accessors kernel arrays sequences sequences.private
locals sequences.lib
locals
persistent.sequences
persistent.hashtables.config
persistent.hashtables.nodes ;

View File

@ -1,6 +1,6 @@
! Based on Clojure's PersistentHashMap by Rich Hickey.
USING: math arrays kernel sequences sequences.lib
USING: math arrays kernel sequences
accessors locals persistent.hashtables.config ;
IN: persistent.hashtables.nodes

View File

@ -182,7 +182,7 @@ M: persistent-vector equal?
: PV{ \ } [ >persistent-vector ] parse-literal ; parsing
M: persistent-vector pprint-delims drop \ PV{ \ } ;
M: persistent-vector >pprint-sequence ;
M: persistent-vector pprint* pprint-object ;
INSTANCE: persistent-vector immutable-sequence

View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io kernel prettyprint
USING: help.markup help.syntax io kernel
prettyprint.config prettyprint.sections words strings ;
IN: prettyprint.backend
@ -24,7 +24,7 @@ HELP: unparse-ch
HELP: do-string-limit
{ $values { "str" string } { "trimmed" "a possibly trimmed string" } }
{ $description "If " { $link string-limit } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ;
{ $description "If " { $link string-limit? } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ;
HELP: pprint-string
{ $values { "obj" object } { "str" string } { "prefix" string } { "suffix" string } }

View File

@ -80,7 +80,7 @@ M: f pprint* drop \ f pprint-word ;
dup ch>ascii-escape [ "\\" % ] [ ] ?if , ;
: do-string-limit ( str -- trimmed )
string-limit get [
string-limit? get [
dup length margin get > [
margin get 3 - head "..." append
] when
@ -129,6 +129,30 @@ M: pathname pprint*
] if
] if ; inline
: tuple>assoc ( tuple -- assoc )
[ class all-slots ] [ tuple-slots ] bi zip
[ [ initial>> ] dip = not ] assoc-filter
[ [ name>> ] dip ] assoc-map ;
: pprint-slot-value ( name value -- )
<flow \ { pprint-word
[ text ] [ f <inset pprint* block> ] bi*
\ } pprint-word block> ;
M: tuple pprint*
boa-tuples? get [ call-next-method ] [
[
<flow
\ T{ pprint-word
dup class pprint-word
t <inset
tuple>assoc [ pprint-slot-value ] assoc-each
block>
\ } pprint-word
block>
] check-recursion
] if ;
: do-length-limit ( seq -- trimmed n/f )
length-limit get dup [
over length over [-]
@ -188,6 +212,8 @@ M: tuple pprint-narrow? drop t ;
] check-recursion ;
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
M: curry pprint*
dup quot>> callable? [ pprint-object ] [

View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io kernel prettyprint
USING: help.markup help.syntax io kernel
prettyprint.sections words ;
IN: prettyprint.config
@ -19,5 +19,9 @@ HELP: length-limit
HELP: line-limit
{ $var-description "The maximum number of lines output by the prettyprinter before output is truncated with \"...\". The default is " { $link f } ", denoting unlimited line count." } ;
HELP: string-limit
HELP: string-limit?
{ $var-description "Toggles whether printed strings are truncated to the margin." } ;
HELP: boa-tuples?
{ $var-description "Toggles whether tuples print in BOA-form or assoc-form." }
{ $notes "See " { $link POSTPONE: T{ } " for a description of both literal tuple forms." } ;

View File

@ -1,9 +1,9 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: prettyprint.config
USING: arrays generic assocs io kernel math
namespaces sequences strings io.styles vectors words
continuations ;
IN: prettyprint.config
! Configuration
SYMBOL: tab-size
@ -11,10 +11,8 @@ SYMBOL: margin
SYMBOL: nesting-limit
SYMBOL: length-limit
SYMBOL: line-limit
SYMBOL: string-limit
SYMBOL: string-limit?
SYMBOL: boa-tuples?
global [
4 tab-size set
64 margin set
string-limit off
] bind
4 tab-size set-global
64 margin set-global

View File

@ -26,7 +26,8 @@ ARTICLE: "prettyprint-variables" "Prettyprint control variables"
{ $subsection nesting-limit }
{ $subsection length-limit }
{ $subsection line-limit }
{ $subsection string-limit }
{ $subsection string-limit? }
{ $subsection boa-tuples? }
"Note that the " { $link short. } " and " { $link pprint-short } " variables override some of these variables."
{
$warning "Treat the global variables as essentially being constants. Only ever rebind them in a nested scope."
@ -86,7 +87,7 @@ $nl
{ $subsection "prettyprint-section-protocol" } ;
ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol"
"Unless a more specialized method exists for the input class, the " { $link pprint* } " word outputs an object in a standard format, ultimately calling two generic words:"
"Most custom data types have a literal syntax which resembles a sequence. An easy way to define such a syntax is to add a method to the " { $link pprint* } " generic word which calls " { $link pprint-object } ", and then to provide methods on two other generic words:"
{ $subsection pprint-delims }
{ $subsection >pprint-sequence }
"For example, consider the following data type, together with a parsing word for creating literals:"
@ -104,10 +105,11 @@ ARTICLE: "prettyprint-literal" "Literal prettyprinting protocol"
{ $code "RECT[ 100 * 200 ]" }
"Without further effort, the literal does not print in the same way:"
{ $unchecked-example "RECT[ 100 * 200 ] ." "T{ rect f 100 200 }" }
"However, we can define two methods easily enough:"
"However, we can define three methods easily enough:"
{ $code
"M: rect pprint-delims drop \\ RECT[ \\ ] ;"
"M: rect >pprint-sequence dup rect-w \\ * rot rect-h 3array ;"
"M: rect pprint* pprint-object ;"
}
"Now, it will be printed in a custom way:"
{ $unchecked-example "RECT[ 100 * 200 ] ." "RECT[ 100 * 200 ]" } ;

View File

@ -71,7 +71,8 @@ IN: prettyprint
{ line-limit 1 }
{ length-limit 15 }
{ nesting-limit 2 }
{ string-limit t }
{ string-limit? t }
{ boa-tuples? t }
} clone [ pprint ] bind ;
: unparse-short ( obj -- str )

View File

@ -3,7 +3,7 @@
! mersenne twister based on
! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c
USING: arrays kernel math namespaces sequences system init
accessors math.ranges random circular math.bitfields.lib
accessors math.ranges random circular math.bitwise
combinators ;
IN: random.mersenne-twister

View File

@ -1,4 +1,4 @@
USING: random sequences tools.test ;
USING: random sequences tools.test kernel ;
IN: random.tests
[ 4 ] [ 4 random-bytes length ] unit-test
@ -6,3 +6,6 @@ IN: random.tests
[ 4 ] [ [ 4 random-bytes length ] with-secure-random ] unit-test
[ 7 ] [ [ 7 random-bytes length ] with-secure-random ] unit-test
[ 2 ] [ V{ 10 20 30 } [ delete-random drop ] keep length ] unit-test
[ V{ } [ delete-random drop ] keep length ] must-fail

View File

@ -43,6 +43,9 @@ M: f random-32* ( obj -- * ) no-random-number-generator ;
] keep nth
] if ;
: delete-random ( seq -- elt )
[ length random ] keep [ nth ] 2keep delete-nth ;
: random-bits ( n -- r ) 2^ random ;
: with-random ( tuple quot -- )

View File

@ -1,8 +1,8 @@
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
! Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays namespaces io io.timeouts kernel logging io.sockets
sequences combinators sequences.lib splitting assocs strings
USING: arrays namespaces io io.timeouts kernel logging
io.sockets sequences combinators splitting assocs strings
math.parser random system calendar io.encodings.ascii summary
calendar.format accessors sets hashtables ;
IN: smtp
@ -112,7 +112,7 @@ ERROR: smtp-transaction-failed < smtp-error ;
} cond ;
: multiline? ( response -- boolean )
?fourth CHAR: - = ;
3 swap ?nth CHAR: - = ;
: process-multiline ( multiline -- response )
>r readln r> 2dup " " append head? [
@ -184,21 +184,3 @@ PRIVATE>
: send-email ( email -- )
[ 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
! it is in case anyone wants to fix it later.
!
! check-response used to have this clause:
! { [ dup "334" head? ] [ " " split 1 swap nth base64> challenge set ] }
!
! and the rest of the code was as follows:
! : (cram-md5-auth) ( -- response )
! swap challenge get
! string>md5-hmac hex-string
! " " prepend append
! >base64 ;
!
! : cram-md5-auth ( key login -- )
! "AUTH CRAM-MD5\r\n" get-ok
! (cram-md5-auth) "\r\n" append get-ok ;

View File

@ -47,7 +47,7 @@ IN: stack-checker.known-words
: infer-shuffle ( shuffle -- )
[ in>> length consume-d ] keep ! inputs shuffle
[ drop ] [ shuffle* dup copy-values dup output-d ] 2bi ! inputs outputs copies
[ drop ] [ shuffle dup copy-values dup output-d ] 2bi ! inputs outputs copies
[ nip ] [ swap zip ] 2bi ! inputs copies mapping
#shuffle, ;

Some files were not shown because too many files have changed in this diff Show More