[
boot
do-startup-hooks
- [
- (command-line) parse-command-line
- load-vocab-roots
- run-user-init
-
- "e" get script get or [
- "e" get [ eval( -- ) ] when*
- script get [ run-script ] when*
- ] [
- "run" get run
- ] if
-
- output-stream get [ stream-flush ] when*
- 0 exit
- ] [ print-error 1 exit ] recover
+ [ command-line-startup ] [ print-error 1 exit ] recover
] set-startup-quot
{ $class-description "Fowler-Noll-Vo checksum algorithm, v1a, 1024-bit." } ;
ARTICLE: "checksums.fnv1" "Fowler-Noll-Vo checksum"
- "The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash for more details."
+ "The Fowler-Noll-Vo checksum algorithm is another simple and fast checksum. It comes in 32, 64, 128, 256, 512 and 1024-bit versions, each in 1 and 1a variants. The 1a variants tend to produce a slightly better result. See " { $url "http://en.wikipedia.org/wiki/Fowler_Noll_Vo_hash" } " for more details."
{ $subsections
fnv1-32
fnv1a-32
Joe Groff
+Daniel Ehrenberg
+John Benediktsson
+Slava Pestov
! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data alien.prettyprint arrays
-assocs classes classes.struct combinators combinators.short-circuit
-continuations fry kernel libc make math math.parser mirrors
-prettyprint.backend prettyprint.custom prettyprint.sections
-see.private sequences slots strings summary words ;
+USING: accessors alien alien.c-types alien.data
+alien.prettyprint arrays assocs classes classes.struct
+combinators combinators.short-circuit continuations fry kernel
+libc make math math.parser mirrors prettyprint.backend
+prettyprint.custom prettyprint.sections see.private sequences
+slots strings summary words ;
IN: classes.struct.prettyprint
<PRIVATE
: struct-definer-word ( class -- word )
- struct-slots dup length 2 >=
- [ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
- [ drop \ STRUCT: ] if ;
+ struct-slots
+ {
+ { [ dup length 1 <= ] [ drop \ STRUCT: ] }
+ { [ dup [ offset>> 0 = ] all? ] [ drop \ UNION-STRUCT: ] }
+ { [ dup [ packed?>> ] all? ] [ drop \ PACKED-STRUCT: ] }
+ [ drop \ STRUCT: ]
+ } cond ;
: struct>assoc ( struct -- assoc )
[ class struct-slots ] [ struct-slot-values ] bi zip ;
{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
{ $description "Defines a new " { $link struct } " type where all of the slots share the same storage. See " { $link POSTPONE: STRUCT: } " for details on the syntax." } ;
+HELP: PACKED-STRUCT:
+{ $syntax "PACKED-STRUCT: class { slot type } { slot type } ... ;" }
+{ $values { "class" "a new " { $link struct } " class to define" } { "slots" "a list of slot specifiers" } }
+{ $description "Defines a new " { $link struct } " type with no alignment padding between slots or at the end. In all other respects, behaves like " { $link POSTPONE: STRUCT: } "." } ;
+
HELP: define-struct-class
{ $values
{ "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
}
{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
+HELP: define-packed-struct-class
+{ $values
+ { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
+}
+{ $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: PACKED-STRUCT: } " syntax." } ;
+
HELP: define-union-struct-class
{ $values
{ "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
ARTICLE: "classes.struct.define" "Defining struct classes"
"Struct classes are defined using a syntax similar to the " { $link POSTPONE: TUPLE: } " syntax for defining tuple classes:"
-{ $subsections POSTPONE: STRUCT: }
+{ $subsections POSTPONE: STRUCT: POSTPONE: PACKED-STRUCT: }
"Union structs are also supported, which behave like structs but share the same memory for all the slots."
{ $subsections POSTPONE: UNION-STRUCT: } ;
! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types alien.data alien.syntax ascii
-assocs byte-arrays classes.struct classes.tuple.parser
-classes.tuple.private classes.tuple combinators compiler.tree.debugger
-compiler.units delegate destructors io.encodings.utf8 io.pathnames
-io.streams.string kernel libc literals math mirrors namespaces
-prettyprint prettyprint.config see sequences specialized-arrays
-system tools.test parser lexer eval layouts generic.single classes
+USING: accessors alien alien.c-types alien.data alien.syntax
+ascii assocs byte-arrays classes.struct
+classes.struct.prettyprint classes.struct.prettyprint.private
+classes.tuple.parser classes.tuple.private classes.tuple
+combinators compiler.tree.debugger compiler.units delegate
+destructors io.encodings.utf8 io.pathnames io.streams.string
+kernel libc literals math mirrors namespaces prettyprint
+prettyprint.config see sequences specialized-arrays system
+tools.test parser lexer eval layouts generic.single classes
vocabs ;
FROM: math => float ;
FROM: specialized-arrays.private => specialized-array-vocab ;
[ make-mirror clear-assoc ] keep
] unit-test
+[ POSTPONE: STRUCT: ]
+[ struct-test-foo struct-definer-word ] unit-test
+
UNION-STRUCT: struct-test-float-and-bits
{ f c:float }
{ bits uint } ;
[ 123 ] [ [ struct-test-foo malloc-struct &free y>> ] with-destructors ] unit-test
+[ POSTPONE: UNION-STRUCT: ]
+[ struct-test-float-and-bits struct-definer-word ] unit-test
+
STRUCT: struct-test-string-ptr
{ x c-string } ;
STRUCT: silly-array-field-test { x int*[3] } ;
[ t ] [ silly-array-field-test <struct> x>> void*-array? ] unit-test
+
+! Packed structs
+PACKED-STRUCT: packed-struct-test
+ { d c:int }
+ { e c:short }
+ { f c:int }
+ { g c:char }
+ { h c:int } ;
+
+[ 15 ] [ packed-struct-test heap-size ] unit-test
+
+[ 0 ] [ "d" packed-struct-test offset-of ] unit-test
+[ 4 ] [ "e" packed-struct-test offset-of ] unit-test
+[ 6 ] [ "f" packed-struct-test offset-of ] unit-test
+[ 10 ] [ "g" packed-struct-test offset-of ] unit-test
+[ 11 ] [ "h" packed-struct-test offset-of ] unit-test
+
+[ POSTPONE: PACKED-STRUCT: ]
+[ packed-struct-test struct-definer-word ] unit-test
-! (c)Joe Groff, Daniel Ehrenberg bsd license
+! Copyright (C) 2010, 2011 Joe Groff, Daniel Ehrenberg,
+! John Benediktsson, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license
USING: accessors alien alien.c-types alien.data alien.parser
arrays byte-arrays classes classes.private classes.parser
classes.tuple classes.tuple.parser classes.tuple.private
TUPLE: struct
{ (underlying) c-ptr read-only } ;
+! We hijack the core slots vocab's slot-spec type for struct
+! fields. Note that 'offset' is in bits, not bytes, to support
+! bitfields.
TUPLE: struct-slot-spec < slot-spec
- type ;
+ type packed? ;
! For a struct-bit-slot-spec, offset is in bits, not bytes
TUPLE: struct-bit-slot-spec < struct-slot-spec
GENERIC: compute-slot-offset ( offset class -- offset' )
-: c-type-align-at ( class offset -- n )
- 0 = [ c-type-align-first ] [ c-type-align ] if ;
+: c-type-align-at ( slot-spec offset -- n )
+ over packed?>> [ 2drop 1 ] [
+ [ type>> ] dip
+ 0 = [ c-type-align-first ] [ c-type-align ] if
+ ] if ;
M: struct-slot-spec compute-slot-offset
- [ type>> over c-type-align-at 8 * align ] keep
+ [ over c-type-align-at 8 * align ] keep
[ [ 8 /i ] dip offset<< ] [ type>> heap-size 8 * + ] 2bi ;
M: struct-bit-slot-spec compute-slot-offset
: struct-alignment ( slots -- align )
[ struct-bit-slot-spec? not ] filter
- 1 [ [ type>> ] [ offset>> ] bi c-type-align-at max ] reduce ;
+ 1 [ dup offset>> c-type-align-at max ] reduce ;
PRIVATE>
: redefine-struct-tuple-class ( class -- )
[ struct f define-tuple-class ] [ make-final ] bi ;
-:: (define-struct-class) ( class slots offsets-quot -- )
- slots empty? [ struct-must-have-slots ] when
+:: (define-struct-class) ( class slot-specs offsets-quot alignment-quot -- )
+ slot-specs check-struct-slots
+ slot-specs empty? [ struct-must-have-slots ] when
class redefine-struct-tuple-class
- slots make-slots dup check-struct-slots :> slot-specs
slot-specs offsets-quot call :> unaligned-size
- slot-specs struct-alignment :> alignment
+ slot-specs alignment-quot call :> alignment
unaligned-size alignment align :> size
- class slot-specs size alignment c-type-for-class :> c-type
+ class slot-specs size alignment c-type-for-class :> c-type
c-type class typedef
class slot-specs define-accessors
class size "struct-size" set-word-prop
class dup make-struct-prototype "prototype" set-word-prop
class (struct-methods) ; inline
+
+: make-packed-slots ( slots -- slot-specs )
+ make-slots [ t >>packed? ] map! ;
+
PRIVATE>
: define-struct-class ( class slots -- )
- [ compute-struct-offsets ] (define-struct-class) ;
+ make-slots
+ [ compute-struct-offsets ] [ struct-alignment ]
+ (define-struct-class) ;
+
+: define-packed-struct-class ( class slots -- )
+ make-packed-slots
+ [ compute-struct-offsets ] [ drop 1 ]
+ (define-struct-class) ;
: define-union-struct-class ( class slots -- )
- [ compute-union-offsets ] (define-struct-class) ;
+ make-slots
+ [ compute-union-offsets ] [ struct-alignment ]
+ (define-struct-class) ;
ERROR: invalid-struct-slot token ;
SYNTAX: STRUCT:
parse-struct-definition define-struct-class ;
+
+SYNTAX: PACKED-STRUCT:
+ parse-struct-definition define-packed-struct-class ;
+
SYNTAX: UNION-STRUCT:
parse-struct-definition define-union-struct-class ;
{ "{" [ parse-struct-slot` t ] }
[ invalid-struct-slot ]
} case ;
+
PRIVATE>
FUNCTOR-SYNTAX: STRUCT:
"objc-calling"
"objc-subclassing"
}
-"A utility library is built to faciliate the development of Cocoa applications in Factor:"
+"A utility library is built to facilitate the development of Cocoa applications in Factor:"
{ $subsections
"cocoa-application-utils"
"cocoa-dialogs"
ARTICLE: "cli" "Command line arguments"
"Factor command line usage:"
{ $code "factor [VM args...] [script] [args...]" }
-"Zero or more VM arguments can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup, any arguments after the script file are stored in the following variable, with no further processing by Factor itself:"
+"Zero or more VM arguments can be passed in, followed by an optional script file name. If the script file is specified, it will be run on startup using " { $link run-script } ". Any arguments after the script file are stored in the following variable, with no further processing by Factor itself:"
{ $subsections command-line }
"Instead of running a script, it is also possible to run a vocabulary; this invokes the vocabulary's " { $link POSTPONE: MAIN: } " word:"
{ $code "factor [system switches...] -run=<vocab name>" }
"There is a way to override the default vocabulary to run on startup, if no script name or " { $snippet "-run" } " switch is specified:"
{ $subsections main-vocab-hook } ;
+HELP: run-script
+{ $values { "file" "a pathname string" } }
+{ $description "Parses the Factor source code stored in a file and runs it. The initial vocabulary search path is used. If the source file contains a " { $link POSTPONE: MAIN: } " declaration, the main entry point of the file will be also be executed. Loading messages will be suppressed." }
+{ $errors "Throws an error if loading the file fails, there input is malformed, or if a runtime error occurs while calling the parsed quotation or executing the main entry point." } ;
+
ABOUT: "cli"
! See http://factorcode.org/license.txt for BSD license.
USING: init continuations hashtables io io.encodings.utf8
io.files io.pathnames kernel kernel.private namespaces parser
-sequences strings system splitting vocabs.loader alien.strings ;
+sequences source-files strings system splitting vocabs.loader
+alien.strings accessors eval ;
IN: command-line
SYMBOL: script
"=" split1 [ var-param ] [ bool-param ] if* ;
: run-script ( file -- )
- t "quiet" set-global run-file ;
+ t "quiet" [
+ [ run-file ]
+ [ source-file main>> [ execute( -- ) ] when* ] bi
+ ] with-variable ;
: parse-command-line ( args -- )
[ command-line off script off ] [
] bind ;
[ default-cli-args ] "command-line" add-startup-hook
+
+: cli-usage ( -- )
+"""
+Usage: """ write vm file-name write """ [Factor arguments] [script] [script arguments]
+
+Common arguments:
+ -help print this message and exit
+ -i=<image> load Factor image file <image> (default """ write vm file-name write """.image)
+ -run=<vocab> run the MAIN: entry point of <vocab>
+ -e=<code> evaluate <code>
+ -quiet suppress "Loading vocab.factor" messages
+ -no-user-init suppress loading of .factor-rc
+
+Enter
+ "command-line" help
+from within Factor for more information.
+
+""" write ;
+
+: command-line-startup ( -- )
+ (command-line) parse-command-line
+ "help" get "-help" get or "h" get or [ cli-usage ] [
+ "e" get script get or "quiet" [
+ load-vocab-roots
+ run-user-init
+
+ "e" get script get or [
+ "e" get [ eval( -- ) ] when*
+ script get [ run-script ] when*
+ ] [
+ "run" get run
+ ] if
+ ] with-variable
+ ] if
+
+ output-stream get [ stream-flush ] when*
+ 0 exit ;
+
{ $description "Waits until the count-down value reaches zero." } ;\r
\r
ARTICLE: "concurrency.count-downs" "Count-down latches"\r
-"The " { $vocab-link "concurrency.count-downs" } " vocabulary implements the " { $emphasis "count-down latch" } " data type, whichis a wrapper for a non-negative integer value which tends towards zero. A thread can either decrement the value, or wait for it to become zero."\r
+"The " { $vocab-link "concurrency.count-downs" } " vocabulary implements the " { $emphasis "count-down latch" } " data type, which is a wrapper for a non-negative integer value which tends towards zero. A thread can either decrement the value, or wait for it to become zero."\r
{ $subsections\r
<count-down>\r
count-down\r
--- /dev/null
+not loaded
+compiler
--- /dev/null
+not loaded
+compiler
--- /dev/null
+not loaded
+compiler
--- /dev/null
+not loaded
+compiler
--- /dev/null
+not loaded
+compiler
{ $subsections "db.types" }
"Useful words:"
{ $subsections "db-tuples-words" }
-"For porting db.tuples to other databases:"
+"For porting " { $vocab-link "db.tuples" } " to other databases:"
{ $subsections "db-tuples-protocol" }
;
$nl
"A " { $emphasis "protocol" } " is a collection of related generic words. An object is said to " { $emphasis "consult" } " another object if it implements a protocol by forwarding all methods onto the other object."
$nl
-"Using this vocabulary, protocols can be defined and consulation can be set up without any repetitive boilerplate."
+"Using this vocabulary, protocols can be defined and consultation can be set up without any repetitive boilerplate."
$nl
"Unlike " { $link "tuple-subclassing" } ", which expresses " { $emphasis "is-a" } " relationships by statically including the methods and slots of the superclass in all subclasses, consultation forwards generic word calls to another distinct object."
$nl
! Method should be there
[ ] [ T{ a-tuple } do-me ] unit-test
-! Now try removing the consulation
+! Now try removing the consultation
[ [ ] ] [
"IN: delegate.tests" <string-reader> "delegate-test" parse-stream
] unit-test
{ $description "Converts a Farkup syntax tree node to XML." } ;
ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
-"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
+"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programmatically traversed and mutated before being passed on to " { $link write-farkup } "."
{ $subsections
heading1
heading2
XML] ;
: recaptcha-url ( secure? -- ? )
- "https://api.recaptcha.net/challenge" "http://api.recaptcha.net/challenge" ?
+ "http://www.google.com/recaptcha/api/challenge"
+ "https://www.google.com/recaptcha/api/challenge" ?
recaptcha-error cget [ "?error=" glue ] when* >url ;
: render-recaptcha ( -- xml )
{ $subsections
<options-request>
}
-"RFC2616 does not define any use for an entity body, yet allows for the inclusion of one as part of the OPTIONS method. This is not supported with this version of the http.client. The current implementation of http-options only supports a " { $link url } " request with no corresponding post-data, as per the stack effect." ;
+"RFC2616 does not define any use for an entity body, yet allows for the inclusion of one as part of the OPTIONS method. This is not supported with this version of the " { $vocab-link "http.client" } ". The current implementation of " { $link http-options } " only supports a " { $link url } " request with no corresponding post-data, as per the stack effect." ;
ARTICLE: "http.client.trace" "TRACE requests with the HTTP client"
"Basic usage involves passing a " { $link url } " and getting a " { $link response } " and data back:"
" [ reverse! drop ] each"
"] with-mapped-array"
}
-"Normalize a file containing packed quadrupes of floats:"
+"Normalize a file containing packed quadruples of floats:"
{ $code
"USING: kernel io.mmap math.vectors math.vectors.simd" "sequences specialized-arrays ;"
"SPECIALIZED-ARRAY: float-4"
USING: io io.pipes io.streams.string io.encodings.utf8
io.encodings.binary io.streams.duplex io.encodings io.timeouts
namespaces continuations tools.test kernel calendar destructors
-accessors debugger math sequences ;
+accessors debugger math sequences threads
+concurrency.count-downs fry ;
IN: io.pipes.tests
[ "Hello" ] [
] with-stream
] unit-test
+! Test run-pipeline
[ { } ] [ { } run-pipeline ] unit-test
[ { f } ] [ { [ f ] } run-pipeline ] unit-test
[ { "Hello" } ] [
} run-pipeline
] unit-test
+! Test timeout
[
utf8 <pipe> [
1 seconds over set-timeout
] with-disposal
] must-fail
+! Test writing to a half-open pipe
[ ] [
1000 [
utf8 <pipe> [
] times
] unit-test
+! Test non-blocking operation
+[ ] [
+ [
+ 2 <count-down> "count-down" set
+
+ utf8 <pipe> &dispose
+ utf8 <pipe> &dispose
+ [
+ [
+ '[
+ _ stream-read1 drop
+ "count-down" get count-down
+ ] in-thread
+ ] bi@
+
+ ! Give the threads enough time to start blocking on
+ ! read
+ 1 seconds sleep
+ ]
+ ! At this point, two threads are blocking on read
+ [ [ "Hi" over stream-write stream-flush ] bi@ ]
+ ! At this point, both threads should wake up
+ 2bi
+
+ "count-down" get await
+ ] with-destructors
+] unit-test
+
! 0 read should not block
[ f ] [
[
"This slot is required for secure server sockets." ;
ARTICLE: "ssl-ephemeral-rsa" "Ephemeral RSA key bits"
-"The " { $snippet "ephemeral-key-bits" } " slot of a " { $link secure-config } " contains the length of the empheral RSA key, in bits."
+"The " { $snippet "ephemeral-key-bits" } " slot of a " { $link secure-config } " contains the length of the ephemeral RSA key, in bits."
$nl
"The default value is 1024, and anything less than that is considered insecure. This slot is required for secure server sockets." ;
{ $errors "Throws " { $link upgrade-on-non-socket } " or " { $link upgrade-buffers-full } " if used improperly." } ;
ARTICLE: "ssl-upgrade" "Upgrading existing connections"
-"Some protocols, such as HTTPS, require that the connection be established as an SSL/TLS connection. Others, such as secure SMTP and POP3 require that the client and server initiate an SSL/TLS handshake upon the client sending a plain-text request. The latter use-case is accomodated by a pair of words."
+"Some protocols, such as HTTPS, require that the connection be established as an SSL/TLS connection. Others, such as secure SMTP and POP3 require that the client and server initiate an SSL/TLS handshake upon the client sending a plain-text request. The latter use-case is accommodated by a pair of words."
$nl
"Upgrading a connection to a secure socket by initiating an SSL/TLS handshake with the server:"
{ $subsections send-secure-handshake }
[ T{ inet f "google.com" 80 } ] [ "google.com" 80 with-port ] unit-test
+! Test bad hostnames
+[ "google.com" f <inet4> ] must-fail
+[ "a.b.c.d" f <inet4> ] must-fail
+[ "google.com" f <inet6> ] must-fail
+[ "a.b.c.d" f <inet6> ] must-fail
+
! Test present on addrspecs
[ "4.4.4.4:12" ] [ "4.4.4.4" 12 <inet4> present ] unit-test
[ "::1:12" ] [ "::1" 12 <inet6> present ] unit-test
TUPLE: ipv4 { host ?string read-only } ;
-C: <ipv4> ipv4
+<PRIVATE
-M: ipv4 inet-ntop ( data addrspec -- str )
- drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
+ERROR: invalid-ipv4 string reason ;
-<PRIVATE
+M: invalid-ipv4 summary drop "Invalid IPv4 address" ;
ERROR: malformed-ipv4 sequence ;
ERROR: bad-ipv4-component string ;
: parse-ipv4 ( string -- seq )
- "." split dup length 4 = [ malformed-ipv4 ] unless
- [ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as ;
-
-ERROR: invalid-ipv4 string reason ;
+ [ f ] [
+ "." split dup length 4 = [ malformed-ipv4 ] unless
+ [ dup string>number [ ] [ bad-ipv4-component ] ?if ] B{ } map-as
+ ] if-empty ;
-M: invalid-ipv4 summary drop "Invalid IPv4 address" ;
+: check-ipv4 ( string -- )
+ [ parse-ipv4 drop ] [ invalid-ipv4 ] recover ;
PRIVATE>
+: <ipv4> ( host -- ipv4 ) dup check-ipv4 ipv4 boa ;
+
+M: ipv4 inet-ntop ( data addrspec -- str )
+ drop 4 memory>byte-array [ number>string ] { } map-as "." join ;
+
M: ipv4 inet-pton ( str addrspec -- data )
drop [ parse-ipv4 ] [ invalid-ipv4 ] recover ;
TUPLE: inet4 < ipv4 { port integer read-only } ;
-C: <inet4> inet4
+: <inet4> ( host port -- inet4 )
+ over check-ipv4 inet4 boa ;
M: ipv4 with-port [ host>> ] dip <inet4> ;
{ host ?string read-only }
{ scope-id integer read-only } ;
-: <ipv6> ( host -- ipv6 ) 0 ipv6 boa ;
+<PRIVATE
-M: ipv6 inet-ntop ( data addrspec -- str )
- drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
+ERROR: invalid-ipv6 host reason ;
-ERROR: invalid-ipv6 string reason ;
-
-<PRIVATE
+M: invalid-ipv6 summary drop "Invalid IPv6 address" ;
ERROR: bad-ipv6-component obj ;
] if
] if-empty ;
+: check-ipv6 ( string -- )
+ [ "::" split1 [ parse-ipv6 ] bi@ 2drop ] [ invalid-ipv6 ] recover ;
+
+PRIVATE>
+
+: <ipv6> ( host -- ipv6 ) dup check-ipv6 0 ipv6 boa ;
+
+M: ipv6 inet-ntop ( data addrspec -- str )
+ drop 16 memory>byte-array 2 <groups> [ be> >hex ] map ":" join ;
+
+<PRIVATE
+
: pad-ipv6 ( string1 string2 -- seq )
2dup [ length ] bi@ + 8 swap -
dup 0 < [ more-than-8-components ] when
TUPLE: inet6 < ipv6 { port integer read-only } ;
-: <inet6> ( host port -- inet6 ) [ 0 ] dip inet6 boa ;
+: <inet6> ( host port -- inet6 )
+ [ dup check-ipv6 0 ] dip inet6 boa ;
M: ipv6 with-port
[ [ host>> ] [ scope-id>> ] bi ] dip
! over completely.
SYMBOL: io-thread-running?
-: io-thread ( -- )
- sleep-time io-multiplex yield ;
+TUPLE: io-thread < thread ;
+
+: <io-thread> ( -- thread )
+ [
+ [ io-thread-running? get-global ]
+ [ sleep-time io-multiplex yield ]
+ while
+ ]
+ "I/O wait"
+ io-thread new-thread ;
+
+M: io-thread error-in-thread [ die ] call( error thread -- ) ;
: start-io-thread ( -- )
t io-thread-running? set-global
- [ [ io-thread-running? get-global ] [ io-thread ] while ]
- "I/O wait" spawn drop ;
+ <io-thread> (spawn) ;
: stop-io-thread ( -- )
f io-thread-running? set-global ;
{ $description "Generates a sequence of " { $snippet "n" } " unique prime numbers with exactly " { $snippet "numbits" } " bits." } ;
ARTICLE: "math.primes" "Prime numbers"
-"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Serveral useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilstic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl
+"The " { $vocab-link "math.primes" } " vocabulary implements words related to prime numbers. Several useful vocabularies exist for testing primality. The Sieve of Eratosthenes in " { $vocab-link "math.primes.erato" } " is useful for testing primality below five million. For larger integers, " { $vocab-link "math.primes.miller-rabin" } " is a fast probabilistic primality test. The " { $vocab-link "math.primes.lucas-lehmer" } " vocabulary implements an algorithm for finding huge Mersenne prime numbers." $nl
"Testing if a number is prime:"
{ $subsections prime? }
"Generating prime numbers:"
$nl
"On PowerPC, or older x86 chips without SSE, software fallbacks are used for all high-level vector operations. SIMD code can run with no loss in functionality, just decreased performance."
$nl
-"The primities in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ;
+"The primitives in the " { $vocab-link "math.vectors.simd.intrinsics" } " vocabulary do not have software fallbacks, but they should not be called directly in any case." ;
ARTICLE: "math.vectors.simd.types" "SIMD vector types"
"Each SIMD vector type is named " { $snippet "scalar-count" } ", where " { $snippet "scalar" } " is a scalar C type and " { $snippet "count" } " is a vector dimension."
"matched rule that returns success or failure. The result of the parse is decided by "
"the result of the semantic action. The stack effect for the quotation is "
{ $snippet ( ast -- ? ) } ". "
-"A semantic action follows the rule it applies to and is delimeted by '?[' and ']?'."
+"A semantic action follows the rule it applies to and is delimited by '?[' and ']?'."
{ $examples
{ $example
"USING: prettyprint peg.ebnf math math.parser ;"
"working in one pass. There is no tokenization occurring over the whole string "
"followed by the parse of that result. It tokenizes as it needs to. You can even "
"switch tokenizers multiple times during a grammar. Rules use the tokenizer that "
-"was defined lexically before the rule. This is usefull in the JavaScript grammar:"
+"was defined lexically before the rule. This is useful in the JavaScript grammar:"
{ $examples
{ $code
"EBNF: javascript"
quotations sequences sequences.generalizations prettyprint
continuations effects definitions compiler.units namespaces
assocs tools.time generic inspector fry locals generalizations
-macros ;
+macros sequences.deep ;
IN: tools.annotations
<PRIVATE
[ dup def>> 2dup "unannotated-def" set-word-prop ] dip
call( old -- new ) define ;
+GENERIC# (deep-annotate) 1 ( word quot -- )
+
+M: generic (deep-annotate)
+ [ "methods" word-prop values ] dip '[ _ (deep-annotate) ] each ;
+
+M: word (deep-annotate)
+ [ check-annotate-twice ] dip
+ [ dup def>> 2dup "unannotated-def" set-word-prop ] dip
+ '[ dup callable? [ _ call( old -- new ) ] when ] deep-map define ;
+
PRIVATE>
: annotate ( word quot -- )
[ (annotate) ] with-compilation-unit ;
+: deep-annotate ( word quot -- )
+ [ (deep-annotate) ] with-compilation-unit ;
+
<PRIVATE
:: trace-quot ( word effect quot str -- quot' )
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs fry kernel quotations sequences strings
+tools.annotations vocabs words prettyprint io ;
+IN: tools.code-coverage
+
+TUPLE: coverage < identity-tuple executed? ;
+
+C: <coverage> coverage
+
+GENERIC: code-coverage-on ( object -- )
+
+GENERIC: code-coverage-off ( object -- )
+
+M: string code-coverage-on
+ words [ code-coverage-on ] each ;
+
+M: string code-coverage-off ( vocabulary -- )
+ words [ code-coverage-off ] each ;
+
+M: word code-coverage-on ( word -- )
+ H{ } clone [ "code-coverage" set-word-prop ] 2keep
+ '[
+ coverage new [ _ set-at ] 2keep
+ '[ _ t >>executed? drop ] [ ] surround
+ ] deep-annotate ;
+
+M: word code-coverage-off ( word -- )
+ [ reset ] [ f "code-coverage" set-word-prop ] bi ;
+
+GENERIC: untested ( object -- seq )
+
+M: string untested
+ words [ dup untested ] { } map>assoc ;
+
+M: word untested ( word -- seq )
+ "code-coverage" word-prop >alist
+ [ drop executed?>> not ] assoc-filter values ;
+
+GENERIC: show-untested ( object -- )
+
+M: string show-untested
+ words [ show-untested ] each ;
+
+M: word show-untested
+ dup untested [
+ drop
+ ] [
+ [ name>> ":" append print ]
+ [ [ bl bl bl bl . ] each ] bi*
+ ] if-empty ;
--- /dev/null
+A tool that uses annotations to determine which code paths are taken.
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: unix.linux.epoll
-USING: alien.c-types alien.syntax classes.struct math unix.types ;
+USING: alien.c-types alien.syntax classes.struct math
+unix.types ;
FUNCTION: int epoll_create ( int size ) ;
{ u32 uint32_t }
{ u64 uint64_t } ;
-STRUCT: epoll-event
+PACKED-STRUCT: epoll-event
{ events uint32_t }
{ data epoll-data } ;
}
"Creating " { $link "network-addressing" } " from URLs:"
{ $subsections url-addr }
-"The URL implemention encodes and decodes components of " { $link url } " instances automatically, but sometimes this functionality is needed for non-URL strings."
+"The URL implementation encodes and decodes components of " { $link url } " instances automatically, but sometimes this functionality is needed for non-URL strings."
{ $subsections "url-encoding" }
"Utility words used by the URL implementation:"
{ $subsections "url-utilities" } ;
ABOUT: "xml.syntax"
ARTICLE: "xml.syntax" "Syntax extensions for XML"
-"The " { $link "xml.syntax" } " vocabulary defines a number of new parsing words forXML processing."
+"The " { $link "xml.syntax" } " vocabulary defines a number of new parsing words for XML processing."
{ $subsections
{ "xml.syntax" "tags" }
{ "xml.syntax" "literals" }
pprint-xml>string
pprint-xml
}
-"Certain variables can be changed to mainpulate prettyprinting"
+"Certain variables can be changed to manipulate prettyprinting"
{ $subsections
sensitive-tags
indenter
"Rectangles, parallelograms and circles are all shapes. We support two operations on shapes:"
{ $list
"Computing the area"
- "Computing the perimiter"
+ "Computing the perimeter"
}
-"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimiter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:"
+"Rectangles and parallelograms use the same algorithm for computing the area, whereas they use different algorithms for computing perimeter. Also, rectangles and parallelograms both have " { $snippet "width" } " and " { $snippet "height" } " slots. We can exploit this with subclassing:"
{ $code
"USING: accessors kernel math math.constants math.functions ;"
"GENERIC: area ( shape -- n )"
- "GENERIC: perimiter ( shape -- n )"
+ "GENERIC: perimeter ( shape -- n )"
""
"TUPLE: shape ;"
""
"TUPLE: circle < shape radius ;"
"M: circle area radius>> sq pi * ;"
- "M: circle perimiter radius>> 2 * pi * ;"
+ "M: circle perimeter radius>> 2 * pi * ;"
""
"TUPLE: quad < shape width height ;"
"M: quad area [ width>> ] [ height>> ] bi * ;"
""
"TUPLE: rectangle < quad ;"
- "M: rectangle perimiter [ width>> 2 * ] [ height>> 2 * ] bi + ;"
+ "M: rectangle perimeter [ width>> 2 * ] [ height>> 2 * ] bi + ;"
""
": hypot ( a b -- c ) [ sq ] bi@ + sqrt ;"
""
"TUPLE: parallelogram < quad skew ;"
- "M: parallelogram perimiter"
+ "M: parallelogram perimeter"
" [ width>> 2 * ] [ [ height>> ] [ skew>> ] bi hypot 2 * ] bi + ;"
} ;
HELP: distribute-buckets
{ $values { "alist" "an alist" } { "initial" object } { "quot" { $quotation "( obj -- assoc )" } } { "buckets" "a new array" } }
{ $description "Sorts the entries of " { $snippet "assoc" } " into buckets, using the quotation to yield a set of keys for each entry. The hashcode of each key is computed, and the entry is placed in all corresponding buckets. Each bucket is initially cloned from " { $snippet "initial" } "; this should either be an empty vector or a one-element vector containing a pair." }
-{ $notes "This word is used in the implemention of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
+{ $notes "This word is used in the implementation of " { $link hash-case-quot } " and " { $link standard-combination } "." } ;
HELP: dispatch ( n array -- )
{ $values { "n" "a fixnum" } { "array" "an array of quotations" } }
"errors-post-mortem"
"errors-anti-examples"
}
-"When Factor encouters a critical error, it calls the following word:"
+"When Factor encounters a critical error, it calls the following word:"
{ $subsections die } ;
ARTICLE: "continuations.private" "Continuation implementation details"
[ 12 ] [ 4 3 2 <parallelogram> area ] unit-test
[ t ] [ 2 <circle> area 4 pi * = ] unit-test
-GENERIC: perimiter ( shape -- n )
+GENERIC: perimeter ( shape -- n )
-: rectangle-perimiter ( l w -- n ) + 2 * ;
+: rectangle-perimeter ( l w -- n ) + 2 * ;
-M: rectangle perimiter
+M: rectangle perimeter
[ width>> ] [ height>> ] bi
- rectangle-perimiter ;
+ rectangle-perimeter ;
: hypotenuse ( a b -- c ) [ sq ] bi@ + sqrt ;
-M: parallelogram perimiter
+M: parallelogram perimeter
[ width>> ]
[ [ height>> ] [ skew>> ] bi hypotenuse ] bi
- rectangle-perimiter ;
+ rectangle-perimeter ;
-M: circle perimiter 2 * pi * ;
+M: circle perimeter 2 * pi * ;
-[ 14 ] [ 4 3 <rectangle> perimiter ] unit-test
-[ 30.0 ] [ 10 4 3 <parallelogram> perimiter ] unit-test
+[ 14 ] [ 4 3 <rectangle> perimeter ] unit-test
+[ 30.0 ] [ 10 4 3 <parallelogram> perimeter ] unit-test
PREDICATE: very-funny < funnies number? ;
IN: hashtables
ARTICLE: "hashtables.private" "Hashtable implementation details"
-"This hashtable implementation uses only one auxilliary array in addition to the hashtable tuple itself. The array stores keys in even slots and values in odd slots. Values are looked up with a hashing strategy that uses linear probing to resolve collisions."
+"This hashtable implementation uses only one auxiliary array in addition to the hashtable tuple itself. The array stores keys in even slots and values in odd slots. Values are looked up with a hashing strategy that uses linear probing to resolve collisions."
$nl
"There are two special objects: the " { $link ((tombstone)) } " marker and the " { $link ((empty)) } " marker. Neither of these markers can be used as hashtable keys."
$nl
} ;
HELP: when*
-{ $values { "?" "a generalized boolean" } { "true" { $quotation "( cond -- ... )" } } }
+{ $values { "?" "a generalized boolean" } { "true" { $quotation "( ..a ? -- ..a )" } } }
{ $description "Variant of " { $link if* } " with no false quotation."
$nl
"The following two lines are equivalent:"
{ $code "X [ Y ] when*" "X dup [ Y ] [ drop ] if" } } ;
HELP: unless*
-{ $values { "?" "a generalized boolean" } { "false" "a quotation " } }
+{ $values { "?" "a generalized boolean" } { "false" { $quotation "( ..a -- ..a x )" } } { "x" object } }
{ $description "Variant of " { $link if* } " with no true quotation." }
{ $notes
"The following two lines are equivalent:"
[ 2drop f f ]
if ; inline
-: (accumulate) ( seq identity quot -- seq identity quot )
+: (accumulate) ( seq identity quot -- identity seq quot )
[ swap ] dip [ curry keep ] curry ; inline
PRIVATE>
USING: sets tools.test kernel prettyprint hash-sets sorting ;
IN: sets.tests
-[ { } ] [ { } { } intersect ] unit-test
-[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
-[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 5 } intersect ] unit-test
-[ { 2 3 4 } ] [ { 1 2 3 4 } { 2 3 4 } intersect ] unit-test
-[ { 2 3 } ] [ { 1 2 2 3 } { 2 3 3 4 } intersect ] unit-test
+[ V{ 1 2 3 } ] [ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
+[ V{ 1 2 } ] [ 2 V{ 1 2 } clone [ adjoin ] keep ] unit-test
-[ { } ] [ { } { } diff ] unit-test
-[ { 1 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
-[ { 1 } ] [ { 1 2 3 } { 2 3 4 5 } diff ] unit-test
-[ { 1 } ] [ { 1 2 3 4 } { 2 3 4 } diff ] unit-test
-[ { 1 } ] [ { 1 1 2 3 } { 2 3 4 4 } diff ] unit-test
+[ t ] [ 4 { 2 4 5 } in? ] unit-test
+[ f ] [ 1 { 2 4 5 } in? ] unit-test
-[ { } ] [ { } { } within ] unit-test
-[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } within ] unit-test
-[ { 2 2 3 } ] [ { 1 2 2 3 } { 2 3 3 4 } within ] unit-test
+[ V{ 1 2 } ] [ 3 V{ 1 2 } clone [ delete ] keep ] unit-test
+[ V{ 2 } ] [ 1 V{ 1 2 } clone [ delete ] keep ] unit-test
-[ { } ] [ { } { } without ] unit-test
-[ { 1 } ] [ { 1 2 3 } { 2 3 4 } without ] unit-test
-[ { 1 1 } ] [ { 1 1 2 3 3 } { 2 3 4 4 } without ] unit-test
+[ { 1 2 3 } ] [ { 1 1 1 2 2 3 3 3 3 3 } dup set-like natural-sort ] unit-test
+[ { 1 2 3 } ] [ HS{ 1 2 3 } { } set-like natural-sort ] unit-test
+[ { 1 2 3 } ] [ { 1 2 2 3 3 } { } set-like ] unit-test
+[ { 3 2 1 } ] [ { 3 3 2 2 1 } { } set-like ] unit-test
+
+[ HS{ 1 2 3 } ] [ { 1 2 3 } fast-set ] unit-test
+
+[ { 1 } ] [ { 1 } members ] unit-test
[ { } ] [ { } { } union ] unit-test
[ { 1 2 3 4 } ] [ { 1 2 3 } { 2 3 4 } union ] unit-test
-[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
+[ { } ] [ { } { } intersect ] unit-test
+[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } intersect ] unit-test
+[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 5 } intersect ] unit-test
+[ { 2 3 4 } ] [ { 1 2 3 4 } { 2 3 4 } intersect ] unit-test
+[ { 2 3 } ] [ { 1 2 2 3 } { 2 3 3 4 } intersect ] unit-test
+[ t ] [ { 1 2 } { 1 3 } intersects? ] unit-test
[ f ] [ { 4 2 } { 1 3 } intersects? ] unit-test
-
[ f ] [ { } { 1 } intersects? ] unit-test
-
[ f ] [ { 1 } { } intersects? ] unit-test
+[ f ] [ { } { } intersects? ] unit-test
-[ t ] [ 4 { 2 4 5 } in? ] unit-test
-[ f ] [ 1 { 2 4 5 } in? ] unit-test
+[ { } ] [ { } { } diff ] unit-test
+[ { 1 } ] [ { 1 2 3 } { 2 3 4 } diff ] unit-test
+[ { 1 } ] [ { 1 2 3 } { 2 3 4 5 } diff ] unit-test
+[ { 1 } ] [ { 1 2 3 4 } { 2 3 4 } diff ] unit-test
+[ { 1 } ] [ { 1 1 2 3 } { 2 3 4 4 } diff ] unit-test
-[ V{ 1 2 3 } ] [ 3 V{ 1 2 } clone [ adjoin ] keep ] unit-test
-[ V{ 1 2 } ] [ 2 V{ 1 2 } clone [ adjoin ] keep ] unit-test
-[ V{ 1 2 } ] [ 3 V{ 1 2 } clone [ delete ] keep ] unit-test
-[ V{ 2 } ] [ 1 V{ 1 2 } clone [ delete ] keep ] unit-test
+[ f ] [ { 1 2 3 4 } { 1 2 } subset? ] unit-test
+[ t ] [ { 1 2 3 4 } { 1 2 } swap subset? ] unit-test
+[ t ] [ { 1 2 } { 1 2 } subset? ] unit-test
+[ t ] [ { } { 1 2 } subset? ] unit-test
+[ t ] [ { } { } subset? ] unit-test
+[ f ] [ { 1 } { } subset? ] unit-test
[ t ] [ { 1 2 3 } { 2 1 3 } set= ] unit-test
[ f ] [ { 2 3 } { 1 2 3 } set= ] unit-test
[ f ] [ { 1 2 3 } { 2 3 } set= ] unit-test
-[ { 1 } ] [ { 1 } members ] unit-test
-
-[ { 1 2 3 } ] [ { 1 1 1 2 2 3 3 3 3 3 } dup set-like natural-sort ] unit-test
-[ { 1 2 3 } ] [ HS{ 1 2 3 } { } set-like natural-sort ] unit-test
-
-[ HS{ 1 2 3 } ] [ { 1 2 3 } fast-set ] unit-test
-
-[ { 1 2 3 } ] [ { { 1 } { 2 } { 1 3 } } combine ] unit-test
-
-[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
-[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
-
-[ { 1 2 3 } ] [ { 1 2 2 3 3 } { } set-like ] unit-test
-[ { 3 2 1 } ] [ { 3 3 2 2 1 } { } set-like ] unit-test
-
[ { 2 1 2 1 } ] [ { 1 2 3 2 1 2 1 } duplicates ] unit-test
[ f ] [ HS{ 1 2 3 1 2 1 } duplicates ] unit-test
-[ H{ { 3 HS{ 1 2 } } } ] [ H{ } clone 1 3 pick adjoin-at 2 3 pick adjoin-at ] unit-test
+[ f ] [ { 0 1 1 2 3 5 } all-unique? ] unit-test
+[ t ] [ { 0 1 2 3 4 5 } all-unique? ] unit-test
[ t ] [ f null? ] unit-test
[ f ] [ { 4 } null? ] unit-test
[ 1 ] [ { 1 } cardinality ] unit-test
[ 1 ] [ HS{ 1 } cardinality ] unit-test
[ 3 ] [ HS{ 1 2 3 } cardinality ] unit-test
+
+[ { } ] [ { } { } within ] unit-test
+[ { 2 3 } ] [ { 1 2 3 } { 2 3 4 } within ] unit-test
+[ { 2 2 3 } ] [ { 1 2 2 3 } { 2 3 3 4 } within ] unit-test
+
+[ { } ] [ { } { } without ] unit-test
+[ { 1 } ] [ { 1 2 3 } { 2 3 4 } without ] unit-test
+[ { 1 1 } ] [ { 1 1 2 3 3 } { 2 3 4 4 } without ] unit-test
+
+[ { 1 2 3 } ] [ { { 1 } { 2 } { 1 3 } } combine ] unit-test
+
+[ H{ { 3 HS{ 1 2 } } } ] [ H{ } clone 1 3 pick adjoin-at 2 3 pick adjoin-at ] unit-test
+
+[ H{ { 3 H{ { 1 1 } { 2 2 } } } } ] [ H{ } clone 1 3 pick conjoin-at 2 3 pick conjoin-at ] unit-test
+
small/large sequence/tester any? ;
M: set subset?
- small/large sequence/tester all? ;
+ sequence/tester all? ;
M: set set=
2dup [ cardinality ] bi@ eq? [ subset? ] [ 2drop f ] if ;
path
top-level-form
checksum
-definitions ;
+definitions
+main ;
: record-top-level-form ( quot file -- )
top-level-form<<
"hello world" "s" set
[ ] [ HEX: 1234 1 "s" get set-nth ] unit-test
+[ HEX: 1234 ] [ 1 "s" get nth ] unit-test
+
[ ] [ HEX: 4321 3 "s" get set-nth ] unit-test
-[ ] [ HEX: 654321 5 "s" get set-nth ] unit-test
+[ HEX: 4321 ] [ 3 "s" get nth ] unit-test
-[ ] [ HEX: -1 5 "s" get set-nth ] unit-test
-[ ] [ HEX: 80,0000 5 "s" get set-nth ] unit-test
-[ ] [ HEX: 100,0000 5 "s" get set-nth ] unit-test
+[ ] [ HEX: 654321 5 "s" get set-nth ] unit-test
+[ HEX: 654321 ] [ 5 "s" get nth ] unit-test
[
{
[ <string> clone resize-string first ] keep =
] all-integers?
] unit-test
+
+"X" "s" set
+[ ] [ HEX: 100,0000 0 "s" get set-nth ] unit-test
+[ 0 ] [ 0 "s" get nth ] unit-test
+
+[ ] [ -1 0 "s" get set-nth ] unit-test
+[ HEX: 7fffff ] [ 0 "s" get nth ] unit-test
USING: generic help.syntax help.markup kernel math parser words
effects classes classes.tuple generic.math generic.single arrays
io.pathnames vocabs.loader io sequences assocs words.symbol
-words.alias words.constant combinators vocabs.parser ;
+words.alias words.constant combinators vocabs.parser command-line ;
IN: syntax
ARTICLE: "parser-algorithm" "Parser algorithm"
HELP: MAIN:
{ $syntax "MAIN: word" }
{ $values { "word" word } }
-{ $description "Defines the main entry point for the current vocabulary. This word will be executed when this vocabulary is passed to " { $link run } "." } ;
+{ $description "Defines the main entry point for the current vocabulary and source file. This word will be executed when this vocabulary is passed to " { $link run } " or the source file is passed to " { $link run-script } "." } ;
HELP: <PRIVATE
{ $syntax "<PRIVATE ... PRIVATE>" }
io.pathnames vocabs vocabs.parser classes.parser classes.union
classes.intersection classes.mixin classes.predicate
classes.singleton classes.tuple.parser compiler.units
-combinators effects.parser slots hash-sets ;
+combinators effects.parser slots hash-sets source-files ;
IN: bootstrap.syntax
! These words are defined as a top-level form, instead of with
"))" parse-effect suffix!
] define-core-syntax
- "MAIN:" [ scan-word current-vocab main<< ] define-core-syntax
+ "MAIN:" [
+ scan-word
+ [ current-vocab main<< ]
+ [ file get [ main<< ] [ drop ] if* ] bi
+ ] define-core-syntax
"<<" [
[
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays ascii assocs fry io.encodings.ascii io.files
+kernel math math.order memoize sequences sorting ;
+
+IN: anagrams
+
+: (all-anagrams) ( seq assoc -- )
+ '[ dup natural-sort _ push-at ] each ;
+
+: all-anagrams ( seq -- assoc )
+ H{ } clone [ (all-anagrams) ] keep
+ [ nip length 1 > ] assoc-filter ;
+
+MEMO: dict-words ( -- seq )
+ "/usr/share/dict/words" ascii file-lines [ >lower ] map ;
+
+MEMO: dict-anagrams ( -- assoc )
+ dict-words all-anagrams ;
+
+: anagrams ( str -- seq/f )
+ >lower natural-sort dict-anagrams at ;
+
+: longest ( seq -- subseq )
+ dup 0 [ length max ] reduce '[ length _ = ] filter ;
+
+: most-anagrams ( -- seq )
+ dict-anagrams values longest ;
+
+: longest-anagrams ( -- seq )
+ dict-anagrams [ keys longest ] keep '[ _ at ] map ;
+
+
+
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors destructors kernel io.binary io.sockets
+sequences ;
+
+IN: benchmark.echo
+
+: send/recv ( packet server client -- )
+ [ over over addr>> ] [ send ] bi* receive drop assert= ;
+
+: udp-echo ( -- )
+ [
+ 10000 iota [ 4 >be ] map
+ f 0 <inet4> <datagram>
+ f 0 <inet4> <datagram>
+ [ send/recv ] 2curry each
+ ] with-destructors ;
+
+MAIN: udp-echo
! Copyright (C) 2009 John Benediktsson
! See http://factorcode.org/license.txt for BSD license
-USING: accessors assocs fry io io.streams.string kernel macros math
-peg.ebnf prettyprint quotations sequences strings ;
+USING: accessors assocs fry io io.streams.string kernel macros
+math peg.ebnf prettyprint sequences strings ;
IN: brainfuck
TUPLE: brainfuck pointer memory ;
-: <brainfuck> ( -- brainfuck )
+: <brainfuck> ( -- brainfuck )
0 H{ } clone brainfuck boa ;
: get-memory ( brainfuck -- brainfuck value )
: (>) ( brainfuck n -- brainfuck )
[ dup pointer>> ] dip + >>pointer ;
-: (<) ( brainfuck n -- brainfuck )
+: (<) ( brainfuck n -- brainfuck )
[ dup pointer>> ] dip - >>pointer ;
-: (#) ( brainfuck -- brainfuck )
- dup
- [ "ptr=" write pointer>> pprint ]
+: (#) ( brainfuck -- brainfuck )
+ dup
+ [ "ptr=" write pointer>> pprint ]
[ ",mem=" write memory>> pprint nl ] bi ;
-: compose-all ( seq -- quot )
+: compose-all ( seq -- quot )
[ ] [ compose ] reduce ;
EBNF: parse-brainfuck
-inc-ptr = (">")+ => [[ length 1quotation [ (>) ] append ]]
-dec-ptr = ("<")+ => [[ length 1quotation [ (<) ] append ]]
-inc-mem = ("+")+ => [[ length 1quotation [ (+) ] append ]]
-dec-mem = ("-")+ => [[ length 1quotation [ (-) ] append ]]
+inc-ptr = (">")+ => [[ length [ (>) ] curry ]]
+dec-ptr = ("<")+ => [[ length [ (<) ] curry ]]
+inc-mem = ("+")+ => [[ length [ (+) ] curry ]]
+dec-mem = ("-")+ => [[ length [ (-) ] curry ]]
output = "." => [[ [ (.) ] ]]
input = "," => [[ [ (,) ] ]]
debug = "#" => [[ [ (#) ] ]]
-space = (" "|"\t"|"\r\n"|"\n")+ => [[ [ ] ]]
+space = (" "|"\t"|"\r\n"|"\n")+ => [[ [ ] ]]
unknown = (.) => [[ "Invalid input" throw ]]
ops = inc-ptr|dec-ptr|inc-mem|dec-mem|output|input|debug|space
-loop = "[" {loop|ops}+ "]" => [[ second compose-all 1quotation [ [ (?) ] ] prepend [ while ] append ]]
+loop = "[" {loop|ops}+ "]" => [[ second compose-all [ while ] curry [ (?) ] prefix ]]
code = (loop|ops|unknown)* => [[ compose-all ]]
MACRO: run-brainfuck ( code -- )
[ <brainfuck> ] swap parse-brainfuck [ drop flush ] 3append ;
-: get-brainfuck ( code -- result )
- [ run-brainfuck ] with-string-writer ; inline
+: get-brainfuck ( code -- result )
+ [ run-brainfuck ] with-string-writer ; inline
factor.get_word("kernel", "using").execute(next);
}
+var fjsc_repl = false;
+
Factor.prototype.set_in = function(v, next) {
factor.cont.data_stack.push(v);
factor.get_word("kernel", "set-in").execute(next);
+ if (fjsc_repl) {
+ fjsc_repl.ps = '( ' + v + ' )';
+ }
}
Factor.prototype.get_word = function(vocab,name) {
! Copyright (C) 2009, 2010 Jose Antonio Ortega Ruiz.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors debugger io io.encodings.utf8 io.servers
-kernel listener math namespaces ;
-IN: fuel.remote
-<PRIVATE
+USING: accessors io io.encodings.utf8 io.servers kernel math
+namespaces tty-server ;
-: start-listener ( -- )
- [ [ drop print-error-and-restarts ] error-hook set listener ] with-scope ;
+IN: fuel.remote
-: server ( port -- server )
- utf8 <threaded-server>
- "tty-server" >>name
- swap local-server >>insecure
- [ start-listener ] >>handler
- f >>timeout ;
+<PRIVATE
: print-banner ( -- )
"Starting server. Connect with 'M-x connect-to-factor' in Emacs"
PRIVATE>
: fuel-start-remote-listener ( port/f -- )
- print-banner integer? [ 9000 ] unless* server start-server drop ;
+ print-banner integer? [ 9000 ] unless* <tty-server> start-server drop ;
: fuel-start-remote-listener* ( -- ) f fuel-start-remote-listener ;
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: alien.data alien.syntax combinators core-foundation
+formatting io.binary kernel math ;
+
+IN: gestalt
+
+<PRIVATE
+
+TYPEDEF: SInt16 OSErr
+
+TYPEDEF: UInt32 OSType
+
+FUNCTION: OSErr Gestalt ( OSType selector, SInt32* response ) ;
+
+PRIVATE>
+
+: gestalt ( selector -- response )
+ 0 SInt32 <ref> [ Gestalt ] keep
+ swap [ throw ] unless-zero le> ;
+
+: system-version ( -- n )
+ "sysv" be> gestalt ;
+
+: system-version-major ( -- n )
+ "sys1" be> gestalt ;
+
+: system-version-minor ( -- n )
+ "sys2" be> gestalt ;
+
+: system-version-bugfix ( -- n )
+ "sys3" be> gestalt ;
+
+: system-version-string ( -- str )
+ system-version-major
+ system-version-minor
+ system-version-bugfix
+ "%s.%s.%s" sprintf ;
+
+: system-code-name ( -- str )
+ system-version HEX: FFF0 bitand {
+ { HEX: 1070 [ "Lion" ] }
+ { HEX: 1060 [ "Snow Leopard" ] }
+ { HEX: 1050 [ "Leopard" ] }
+ { HEX: 1040 [ "Tiger" ] }
+ { HEX: 1030 [ "Panther" ] }
+ { HEX: 1020 [ "Jaguar" ] }
+ { HEX: 1010 [ "Puma" ] }
+ { HEX: 1000 [ "Cheetah" ] }
+ [ drop "Unknown" ]
+ } case ;
+
{ $slide "Unicode strings"
"Strings are sequences of 21-bit Unicode code points"
"Efficient implementation: ASCII byte string unless it has chars > 127"
- "If a byte char has high bit set, the remaining 14 bits come from auxilliary vector"
+ "If a byte char has high bit set, the remaining 14 bits come from auxiliary vector"
}
{ $slide "Unicode strings"
"Unicode-aware case conversion, char classes, collation, word breaks, and so on..."
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays assocs colors.hex combinators formatting
+http.client images.http images.loader images.loader.private
+images.viewer kernel math math.order present sequences splitting
+urls ;
+
+IN: google.charts
+
+TUPLE: chart type width height title data data-scale labels
+background foreground margin bar-width ;
+
+: <chart> ( type -- chart )
+ chart new
+ swap >>type
+ 320 >>width
+ 240 >>height ;
+
+<PRIVATE
+
+: x,y ( seq -- str ) [ present ] map "," join ;
+
+: x|y ( seq -- str ) [ present ] map "|" join ;
+
+: chd ( chart seq -- chart )
+ [ x,y >>data ] [
+ [ infimum 0 min ] [ supremum 0 max ] bi 2array
+ x,y >>data-scale
+ ] bi ;
+
+: chl ( chart seq -- chart ) x|y >>labels ;
+
+: chd/chl ( chart assoc -- chart )
+ [ values chd ] [ keys chl ] bi ;
+
+PRIVATE>
+
+: <pie> ( assoc -- chart )
+ [ "p" <chart> ] dip chd/chl ;
+
+: <pie-3d> ( assoc -- chart )
+ [ "p3" <chart> ] dip chd/chl ;
+
+: <bar> ( assoc -- chart )
+ [ "bvs" <chart> ] dip chd/chl ;
+
+: <line> ( seq -- chart )
+ [ "lc" <chart> ] dip chd ;
+
+: <line-xy> ( seq -- chart )
+ [ "lxy" <chart> ] dip [ keys ] [ values ] bi
+ [ x,y ] bi@ "|" glue >>data ;
+
+: <scatter> ( seq -- chart )
+ [ "s" <chart> ] dip [ keys ] [ values ] bi
+ [ x,y ] bi@ "|" glue >>data ;
+
+: <sparkline> ( seq -- chart )
+ [ "ls" <chart> ] dip chd ;
+
+: <radar> ( seq -- chart )
+ [ "rs" <chart> ] dip chd ;
+
+: <qr-code> ( str -- chart )
+ [ "qr" <chart> ] dip 1array chl ;
+
+: <formula> ( str -- chart )
+ [ "tx" <chart> ] dip 1array chl f >>width f >>height ;
+
+<PRIVATE
+
+: chart>url ( chart -- url )
+ [ URL" http://chart.googleapis.com/chart" ] dip {
+ [ type>> "cht" set-query-param ]
+ [
+ [ width>> ] [ height>> ] bi 2dup and [
+ "%sx%s" sprintf "chs" set-query-param
+ ] [ 2drop ] if
+ ]
+ [ title>> "chtt" set-query-param ]
+ [ data>> "t:" prepend "chd" set-query-param ]
+ [ data-scale>> [ "chds" set-query-param ] when* ]
+ [ labels>> "chl" set-query-param ]
+ [
+ background>> [
+ rgba>hex "bg,s," prepend "chf" set-query-param
+ ] when*
+ ]
+ [
+ foreground>> [
+ rgba>hex "chco" set-query-param
+ ] when*
+ ]
+ [ margin>> [ x,y "chma" set-query-param ] when* ]
+ [ bar-width>> [ "chbh" set-query-param ] when* ]
+ } cleave ;
+
+PRIVATE>
+
+: chart. ( chart -- )
+ chart>url present dup length 2000 < [ http-image. ] [
+ "?" split1 swap http-post nip
+ "png" (image-class) load-image* image.
+ ] if ;
--- /dev/null
+Google Chart API
--- /dev/null
+Doug Coleman
--- /dev/null
+! Copyright (C) 2010 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs combinators fry grouping http.client io
+json.reader kernel locals namespaces sequences ;
+IN: google.translate
+
+CONSTANT: google-translate-url "http://ajax.googleapis.com/ajax/services/language/translate"
+
+CONSTANT: maximum-translation-size 5120
+
+: parameters>assoc ( text from to -- assoc )
+ "|" glue [
+ [ "q" set ] [ "langpair" set ] bi*
+ "1.0" "v" set
+ ] { } make-assoc ;
+
+: assoc>query-response ( assoc -- response )
+ google-translate-url http-post nip ;
+
+ERROR: response-error response error ;
+
+: throw-response-error ( response -- * )
+ "responseDetails" over at response-error ;
+
+: check-response ( response -- response )
+ "responseStatus" over at {
+ { 200 [ ] }
+ { 400 [ throw-response-error ] }
+ [ drop throw-response-error ]
+ } case ;
+
+: query-response>text ( response -- text )
+ json> check-response
+ "responseData" swap at
+ "translatedText" swap at ;
+
+: (translate) ( text from to -- text' )
+ parameters>assoc
+ assoc>query-response
+ query-response>text ;
+
+: translate ( text from to -- text' )
+ [ maximum-translation-size group ] 2dip
+ '[ _ _ (translate) ] map concat ;
+
+:: translation-party ( text source target -- )
+ text dup print [
+ dup source target translate dup print
+ target source translate dup print
+ swap dupd = not
+ ] loop drop ;
+
+! Example:
+! "dog" "en" "de" translate .
+! "Hund"
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors combinators combinators.short-circuit
+continuations formatting fry io kernel math math.functions
+math.order math.parser math.ranges random sequences strings ;
+
+IN: hamurabi
+
+<PRIVATE
+
+TUPLE: game year population births deaths stores harvest yield
+plague acres eaten cost feed planted birth-factor rat-factor
+total-births total-deaths ;
+
+: <game> ( -- game )
+ game new
+ 0 >>year
+ 95 >>population
+ 5 >>births
+ 0 >>deaths
+ 2800 >>stores
+ 3000 >>harvest
+ 3 >>yield
+ f >>plague
+ 0 >>cost
+ dup births>> >>total-births
+ dup deaths>> >>total-deaths
+ dup births>> '[ _ + ] change-population
+ dup [ harvest>> ] [ yield>> ] bi / >>acres
+ dup [ harvest>> ] [ stores>> ] bi - >>eaten ;
+
+: #acres-available ( game -- n )
+ [ stores>> ] [ cost>> ] bi /i ;
+
+: #acres-per-person ( game -- n )
+ [ acres>> ] [ population>> ] bi / ;
+
+: #harvested ( game -- n )
+ [ planted>> ] [ yield>> ] bi * ;
+
+: #eaten ( game -- n )
+ dup rat-factor>> odd?
+ [ [ stores>> ] [ rat-factor>> ] bi / ] [ drop 0 ] if ;
+
+: #stored ( game -- n )
+ [ harvest>> ] [ eaten>> ] bi - ;
+
+: #percent-died ( game -- n )
+ [ total-deaths>> 100 * ] [ total-births>> ] [ year>> ] tri / / ;
+
+: #births ( game -- n )
+ {
+ [ acres>> 20 * ]
+ [ stores>> + ]
+ [ birth-factor>> * ]
+ [ population>> / ]
+ } cleave 100 /i 1 + ;
+
+: #starved ( game -- n )
+ [ population>> ] [ feed>> 20 /i ] bi - 0 max ;
+
+: leave-fink ( -- )
+ "DUE TO THIS EXTREME MISMANAGEMENT YOU HAVE NOT ONLY" print
+ "BEEN IMPEACHED AND THROWN OUT OF OFFICE BUT YOU HAVE" print
+ "ALSO BEEN DECLARED 'NATIONAL FINK' !!" print ;
+
+: leave-starved ( game -- game )
+ dup deaths>> "YOU STARVED %d PEOPLE IN ONE YEAR!!!\n" printf
+ leave-fink "exit" throw ;
+
+: leave-nero ( -- )
+ "YOUR HEAVY-HANDED PERFORMANCE SMACKS OF NERO AND IVAN IV." print
+ "THE PEOPLE (REMAINING) FIND YOU AN UNPLEASANT RULER, AND" print
+ "FRANKLY, HATE YOUR GUTS!" print ;
+
+: leave-not-too-bad ( game -- game )
+ "YOUR PERFORMANCE COULD HAVE BEEN SOMEWHAT BETTER, BUT" print
+ "REALLY WASN'T TOO BAD AT ALL." print
+ dup population>> 4/5 * floor [0,b] random
+ "%d PEOPLE WOULD DEARLY LIKE TO SEE YOU ASSASSINATED\n" printf
+ "BUT WE ALL HAVE OUR TRIVIAL PROBLEMS" print ;
+
+: leave-best ( -- )
+ "A FANTASTIC PERFORMANCE!!! CHARLEMANGE, DISRAELI, AND" print
+ "JEFFERSON COMBINED COULD NOT HAVE DONE BETTER!" print ;
+
+: leave ( game -- )
+ dup [ #percent-died ] [ #acres-per-person ] bi
+ {
+ { [ 2dup [ 33 > ] [ 7 < ] bi* or ] [ leave-fink ] }
+ { [ 2dup [ 10 > ] [ 9 < ] bi* or ] [ leave-nero ] }
+ { [ 2dup [ 3 > ] [ 10 < ] bi* or ] [ leave-not-too-bad ] }
+ [ leave-best ]
+ } cond 3drop ;
+
+: check-number ( n -- )
+ { [ f eq? ] [ 0 < ] [ fixnum? not ] } 1|| [
+ "HAMURABI: I CANNOT DO WHAT YOU WISH." print
+ "GET YOURSELF ANOTHER STEWARD!!!!!" print
+ "exit" throw
+ ] when ;
+
+: input ( prompt -- n/f )
+ write flush readln string>number [ check-number ] keep ;
+
+: bad-stores ( game -- )
+ stores>>
+ "HAMURABI: THINK AGAIN. YOU HAVE ONLY" print
+ "%d BUSHELS OF STORES. NOW THEN," printf nl ;
+
+: bad-acres ( game -- )
+ acres>>
+ "HAMURABI: THINK AGAIN. YOU ONLY OWN %d ACRES. NOW THEN,"
+ printf nl ;
+
+: bad-population ( game -- )
+ population>>
+ "BUT YOU HAVE ONLY %d PEOPLE TO TEND THE FIELDS. NOW THEN,"
+ printf nl ;
+
+: check-error ( game n error -- game n ? )
+ {
+ { "acres" [ over bad-acres t ] }
+ { "stores" [ over bad-stores t ] }
+ { "population" [ over bad-population t ] }
+ [ drop f ]
+ } case ;
+
+: adjust-acres ( game n -- game )
+ [ '[ _ + ] change-acres ]
+ [ over cost>> * '[ _ - ] change-stores ] bi ;
+
+: buy-acres ( game -- game )
+ "HOW MANY ACRES DO YOU WISH TO BUY? " input
+ over #acres-available dupd > "stores" and check-error
+ [ drop buy-acres ] [ adjust-acres ] if ;
+
+: sell-acres ( game -- game )
+ "HOW MANY ACRES DO YOU WISH TO SELL? " input
+ over acres>> dupd >= "acres" and check-error
+ [ drop sell-acres ] [ neg adjust-acres ] if nl ;
+
+: trade-land ( game -- game )
+ dup cost>> "LAND IS TRADING AT %d BUSHELS PER ACRE.\n" printf
+ buy-acres sell-acres ;
+
+: feed-people ( game -- game )
+ "HOW MANY BUSHELS DO YOU WISH TO FEED YOUR PEOPLE? " input
+ over stores>> dupd > "stores" and check-error
+ [ drop feed-people ] [
+ [ >>feed ] [ '[ _ - ] change-stores ] bi
+ ] if nl ;
+
+: plant-seeds ( game -- game )
+ "HOW MANY ACRES DO YOU WISH TO PLANT WITH SEED? " input {
+ { [ over acres>> dupd > ] [ "acres" ] }
+ { [ over stores>> 2 * dupd > ] [ "stores" ] }
+ { [ over population>> 10 * dupd > ] [ "population" ] }
+ [ f ]
+ } cond check-error [ drop plant-seeds ] [
+ [ >>planted ] [ 2/ '[ _ - ] change-stores ] bi
+ ] if nl ;
+
+: report-status ( game -- game )
+ "HAMURABI: I BEG TO REPORT TO YOU," print
+ dup [ year>> ] [ deaths>> ] [ births>> ] tri
+ "IN YEAR %d, %d PEOPLE STARVED, %d CAME TO THE CITY\n" printf
+ dup plague>> [
+ "A HORRIBLE PLAGUE STRUCK! HALF THE PEOPLE DIED." print
+ ] when
+ dup population>> "POPULATION IS NOW %d.\n" printf
+ dup acres>> "THE CITY NOW OWNS %d ACRES.\n" printf
+ dup yield>> "YOU HARVESTED %d BUSHELS PER ACRE.\n" printf
+ dup eaten>> "RATS ATE %d BUSHELS.\n" printf
+ dup stores>> "YOU NOW HAVE %d BUSHELS IN STORE.\n\n" printf ;
+
+: update-randomness ( game -- game )
+ 17 26 [a,b] random >>cost
+ 5 [1,b] random >>yield
+ 5 [1,b] random >>birth-factor
+ 5 [1,b] random >>rat-factor
+ 100 random 15 < >>plague ;
+
+: update-stores ( game -- game )
+ dup #harvested >>harvest
+ dup #eaten >>eaten
+ dup #stored '[ _ + ] change-stores ;
+
+: update-births ( game -- game )
+ dup #births
+ [ >>births ]
+ [ '[ _ + ] change-total-births ]
+ [ '[ _ + ] change-population ] tri ;
+
+: update-deaths ( game -- game )
+ dup #starved
+ [ >>deaths ]
+ [ '[ _ + ] change-total-deaths ]
+ [ '[ _ - ] change-population ] tri ;
+
+: check-plague ( game -- game )
+ dup plague>> [ [ 2/ ] change-population ] when ;
+
+: check-starvation ( game -- game )
+ dup [ deaths>> ] [ population>> 0.45 * ] bi >
+ [ leave-starved ] when ;
+
+: year ( game -- game )
+ [ 1 + ] change-year
+ report-status
+ update-randomness
+ trade-land
+ feed-people
+ plant-seeds
+ update-stores
+ update-births
+ update-deaths
+ check-plague
+ check-starvation ;
+
+: spaces ( n -- )
+ CHAR: \s <string> write ;
+
+: welcome ( -- )
+ 32 spaces "HAMURABI" print
+ 15 spaces "CREATIVE COMPUTING MORRISTOWN, NEW JERSEY" print
+ nl nl nl
+ "TRY YOUR HAND AT GOVERNING ANCIENT SUMERIA" print
+ "SUCCESSFULLY FOR A TEN-YEAR TERM OF OFFICE" print nl ;
+
+: finish ( game -- )
+ dup #percent-died
+ "IN YOUR 10-YEAR TERM OF OFFICE, %d PERCENT OF THE\n" printf
+ "POPULATION STARVED PER YEAR ON AVERAGE, I.E., A TOTAL OF" print
+ dup total-deaths>> "%d PEOPLE DIED!!\n" printf
+ "YOU STARTED WITH 10 ACRES PER PERSON AND ENDED WITH" print
+ dup #acres-per-person "%d ACRES PER PERSON\n" printf
+ nl leave nl "SO LONG FOR NOW." print ;
+
+PRIVATE>
+
+! FIXME: "exit" throw is used to break early, perhaps use bool?
+
+: hamurabi ( -- )
+ welcome <game> [
+ 10 [ year ] times finish
+ ] [ 2drop ] recover ;
+
+MAIN: hamurabi
+
--- /dev/null
+Port of the HAMURABI.BAS game
"The " { $vocab-link "images.viewer" } " vocabulary uses the " { $vocab-link "opengl.textures" }
" vocabulary to display any instance of " { $link image } "."$nl
"An " { $link image-gadget } " can be used for static images and " { $instance image-control }
-" for changing images (for example a video feed). For changing images, the image should be containted in " { $instance model }
+" for changing images (for example a video feed). For changing images, the image should be contained in " { $instance model }
". Change the model value with " { $link set-model } " or mutate the image and call "
{ $link notify-connections } " when you want to update the image. To stop refreshing the image, call " { $link stop-control } "."
" To start refreshing again, call " { $link start-control } "."
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: assocs hashtables help.syntax help.markup io strings ;
+
+IN: ini-file
+
+HELP: read-ini
+{ $values { "assoc" assoc } }
+{ $description
+ "Reads and parses an INI configuration from the " { $link input-stream }
+ " and returns the result as a nested " { $link hashtable }
+ "."
+} ;
+
+HELP: write-ini
+{ $values { "assoc" assoc } }
+{ $description
+ "Writes a configuration to the " { $link output-stream }
+ " in the INI format."
+} ;
+
+HELP: string>ini
+{ $values { "str" string } { "assoc" assoc } }
+{ $description
+ "Parses the specified " { $link string } " as an INI configuration"
+ " and returns the result as a nested " { $link hashtable }
+ "."
+} ;
+
+HELP: ini>string
+{ $values { "assoc" assoc } { "str" string } }
+{ $description
+ "Encodes the specified " { $link hashtable } " as an INI configuration."
+} ;
+
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: ini-file tools.test ;
+
+IN: ini-file.tests
+
+[ H{ } ] [ "" string>ini ] unit-test
+
+[ H{ { "section" H{ } } } ] [ "[section]" string>ini ] unit-test
+
+[ H{ { "section" H{ } } } ] [ "[\"section\" ]" string>ini ] unit-test
+
+[ H{ { " some name with spaces " H{ } } } ]
+[ "[ \" some name with spaces \"]" string>ini ] unit-test
+
+[ H{ { "[]" H{ } } } ] [ "[\\[\\]]" string>ini ] unit-test
+
+[ H{ { "foo" "bar" } } ] [ "foo=bar" string>ini ] unit-test
+
+[ H{ { "foo" "bar" } { "baz" "quz" } } ]
+[ "foo=bar\nbaz= quz" string>ini ] unit-test
+
+[ H{ { "section" H{ { "foo" "abc def" } } } } ]
+[
+ """
+ [section]
+ foo = abc def
+ """ string>ini
+] unit-test
+
+[ H{ { "section" H{ { "foo" "abc def" } } } } ]
+[
+ """
+ [section]
+ foo = abc \\
+ "def"
+ """ string>ini
+] unit-test
+
+[ H{ { "section" H{ { "foo" "abc def" } } } } ]
+[
+ """
+ [section]
+ foo = "abc " \\
+ def
+ """ string>ini
+] unit-test
+
+[ H{ { "section" H{ { "foo" "abc def" } } } } ]
+[
+ """
+ [section] foo = "abc def"
+ """ string>ini
+] unit-test
+
+[ H{ { "section" H{ { "foo" "abc def" } } } } ]
+[
+ """
+ [section] foo = abc \\
+ "def"
+ """ string>ini
+] unit-test
+
+[ H{ { "section" H{ { "foo" "" } } } } ]
+[
+ """
+ [section]
+ foo=
+ """ string>ini
+] unit-test
+
+[ H{ { "section" H{ { "foo" "" } } } } ]
+[
+ """
+ [section]
+ foo
+ """ string>ini
+] unit-test
+
+[ H{ { "" H{ { "" "" } } } } ]
+[
+ """
+ []
+ =
+ """ string>ini
+] unit-test
+
+[ H{ { "owner" H{ { "name" "John Doe" }
+ { "organization" "Acme Widgets Inc." } } }
+ { "database" H{ { "server" "192.0.2.62" }
+ { "port" "143" }
+ { "file" "payroll.dat" } } } } ]
+[
+ """
+ ; last modified 1 April 2001 by John Doe
+ [owner]
+ name=John Doe
+ organization=Acme Widgets Inc.
+
+ [database]
+ server=192.0.2.62 ; use IP address in case network name resolution is not working
+ port=143
+ file = "payroll.dat"
+ """ string>ini
+] unit-test
+
+[ H{ { "a long section name"
+ H{ { "a long key name" "a long value name" } } } } ]
+[
+ """
+ [a long section name ]
+ a long key name= a long value name
+ """ string>ini
+] unit-test
+
+[ H{ { "key with \n esc\ape \r codes \""
+ "value with \t esc\ape codes" } } ]
+[
+ """
+ key with \\n esc\\ape \\r codes \\\" = value with \\t esc\\ape codes
+ """ string>ini
+] unit-test
+
+
+[ """key with \\n esc\\ape \\r codes \\\"=value with \\t esc\\ape codes\n""" ]
+[
+ H{ { "key with \n esc\ape \r codes \""
+ "value with \t esc\ape codes" } } ini>string
+] unit-test
+
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays assocs combinators combinators.short-circuit
+formatting hashtables io io.streams.string kernel make math
+namespaces quoting sequences splitting strings strings.parser ;
+
+IN: ini-file
+
+<PRIVATE
+
+: escape ( ch -- ch' )
+ H{
+ { CHAR: a CHAR: \a }
+ { CHAR: b HEX: 08 } ! \b
+ { CHAR: f HEX: 0c } ! \f
+ { CHAR: n CHAR: \n }
+ { CHAR: r CHAR: \r }
+ { CHAR: t CHAR: \t }
+ { CHAR: v HEX: 0b } ! \v
+ { CHAR: ' CHAR: ' }
+ { CHAR: " CHAR: " }
+ { CHAR: \\ CHAR: \\ }
+ { CHAR: ? CHAR: ? }
+ { CHAR: ; CHAR: ; }
+ { CHAR: [ CHAR: [ }
+ { CHAR: ] CHAR: ] }
+ { CHAR: = CHAR: = }
+ } ?at [ bad-escape ] unless ;
+
+: (unescape-string) ( str -- )
+ CHAR: \\ over index [
+ cut-slice [ % ] dip rest-slice
+ dup empty? [ "Missing escape code" throw ] when
+ unclip-slice escape , (unescape-string)
+ ] [ % ] if* ;
+
+: unescape-string ( str -- str' )
+ [ (unescape-string) ] "" make ;
+
+USE: xml.entities
+
+: escape-string ( str -- str' )
+ H{
+ { CHAR: \a "\\a" }
+ { HEX: 08 "\\b" }
+ { HEX: 0c "\\f" }
+ { CHAR: \n "\\n" }
+ { CHAR: \r "\\r" }
+ { CHAR: \t "\\t" }
+ { HEX: 0b "\\v" }
+ { CHAR: ' "\\'" }
+ { CHAR: " "\\\"" }
+ { CHAR: \\ "\\\\" }
+ { CHAR: ? "\\?" }
+ { CHAR: ; "\\;" }
+ { CHAR: [ "\\[" }
+ { CHAR: ] "\\]" }
+ { CHAR: = "\\=" }
+ } escape-string-by ;
+
+: space? ( ch -- ? )
+ {
+ [ CHAR: \s = ]
+ [ CHAR: \t = ]
+ [ CHAR: \n = ]
+ [ CHAR: \r = ]
+ [ HEX: 0c = ] ! \f
+ [ HEX: 0b = ] ! \v
+ } 1|| ;
+
+: unspace ( str -- str' )
+ [ space? ] trim ;
+
+: unwrap ( str -- str' )
+ 1 swap [ length 1 - ] keep subseq ;
+
+: uncomment ( str -- str' )
+ ";#" [ over index [ head ] when* ] each ;
+
+: cleanup-string ( str -- str' )
+ unspace unquote unescape-string ;
+
+SYMBOL: section
+SYMBOL: option
+
+: section? ( line -- index/f )
+ {
+ [ length 1 > ]
+ [ first CHAR: [ = ]
+ [ CHAR: ] swap last-index ]
+ } 1&& ;
+
+: line-continues? ( line -- ? )
+ { [ empty? not ] [ last CHAR: \ = ] } 1&& ;
+
+: section, ( -- )
+ section get [ , ] when* ;
+
+: option, ( name value -- )
+ section get [ second swapd set-at ] [ 2array , ] if* ;
+
+: [section] ( line -- )
+ unwrap cleanup-string H{ } clone 2array section set ;
+
+: name=value ( line -- )
+ option [
+ [ swap [ first2 ] dip ] [
+ "=" split1 [ cleanup-string "" ] [ "" or ] bi*
+ ] if*
+ dup line-continues? [
+ dup length 1 - head cleanup-string
+ dup last space? [ " " append ] unless append 2array
+ ] [
+ cleanup-string append option, f
+ ] if
+ ] change ;
+
+: parse-line ( line -- )
+ uncomment unspace dup section? [
+ section, 1 + cut [ [section] ] [ unspace ] bi*
+ ] when* [ name=value ] unless-empty ;
+
+PRIVATE>
+
+: read-ini ( -- assoc )
+ section off option off
+ [ [ parse-line ] each-line section, ] { } make
+ >hashtable ;
+
+: write-ini ( assoc -- )
+ [
+ dup string?
+ [ [ escape-string ] bi@ "%s=%s\n" printf ]
+ [
+ [ escape-string "[%s]\n" printf ] dip
+ [ [ escape-string ] bi@ "%s=%s\n" printf ]
+ assoc-each nl
+ ] if
+ ] assoc-each ;
+
+! FIXME: escaped comments "\;" don't work
+
+: string>ini ( str -- assoc )
+ [ read-ini ] with-string-reader ;
+
+: ini>string ( assoc -- str )
+ [ write-ini ] with-string-writer ;
+
--- /dev/null
+Parses INI configuration files.
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: alien.c-types alien.strings alien.syntax classes.struct
+core-foundation io.encodings.utf8 io.files.trash kernel system ;
+
+IN: io.files.trash.macosx
+
+<PRIVATE
+
+STRUCT: FSRef
+ { hidden UInt8[80] } ;
+
+TYPEDEF: SInt32 OSStatus
+
+TYPEDEF: UInt32 OptionBits
+
+CONSTANT: noErr 0
+
+CONSTANT: kFSFileOperationDefaultOptions HEX: 00
+CONSTANT: kFSFileOperationOverwrite HEX: 01
+CONSTANT: kFSFileOperationSkipSourcePermissionErrors HEX: 02
+CONSTANT: kFSFileOperationDoNotMoveAcrossVolumes HEX: 04
+CONSTANT: kFSFileOperationSkipPreflight HEX: 08
+
+CONSTANT: kFSPathMakeRefDefaultOptions HEX: 00
+CONSTANT: kFSPathMakeRefDoNotFollowLeafSymlink HEX: 01
+
+FUNCTION: OSStatus FSMoveObjectToTrashSync (
+ FSRef* source,
+ FSRef* target,
+ OptionBits options
+) ;
+
+FUNCTION: char* GetMacOSStatusCommentString (
+ OSStatus err
+) ;
+
+FUNCTION: OSStatus FSPathMakeRefWithOptions (
+ UInt8* path,
+ OptionBits options,
+ FSRef* ref,
+ Boolean* isDirectory
+) ;
+
+: check-err ( err -- )
+ dup noErr = [ drop ] [
+ GetMacOSStatusCommentString utf8 alien>string throw
+ ] if ;
+
+! FIXME: check isDirectory?
+
+: <fs-ref> ( path -- fs-ref )
+ utf8 string>alien
+ kFSPathMakeRefDoNotFollowLeafSymlink
+ FSRef <struct>
+ [ f FSPathMakeRefWithOptions check-err ] keep ;
+
+PRIVATE>
+
+M: macosx send-to-trash ( path -- )
+ <fs-ref> f kFSFileOperationDefaultOptions
+ FSMoveObjectToTrashSync check-err ;
+
+
--- /dev/null
+Send files to the trash bin.
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: help.markup help.syntax io.files.trash ;
+
+IN: io.files.trash
+
+HELP: send-to-trash
+{ $values { "path" "a file path" } }
+{ $description
+ "Send a file path to the trash bin."
+} ;
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: combinators system vocabs.loader ;
+
+IN: io.files.trash
+
+HOOK: send-to-trash os ( path -- )
+
+{
+ { [ os macosx? ] [ "io.files.trash.macosx" ] }
+ { [ os unix? ] [ "io.files.trash.unix" ] }
+ { [ os winnt? ] [ "io.files.trash.windows" ] }
+} cond require
+
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors calendar combinators.short-circuit environment
+formatting io io.directories io.encodings.utf8 io.files
+io.files.info io.files.info.unix io.files.trash io.files.types
+io.pathnames kernel math math.parser sequences system unix.stat
+unix.users ;
+
+IN: io.files.trash.unix
+
+! Implements the FreeDesktop.org Trash Specification 0.7
+
+<PRIVATE
+
+: top-directory? ( path -- ? )
+ dup ".." append-path [ link-status ] bi@
+ [ [ st_dev>> ] bi@ = not ] [ [ st_ino>> ] bi@ = ] 2bi or ;
+
+: top-directory ( path -- path' )
+ [ dup top-directory? not ] [ ".." append-path ] while ;
+
+: make-user-directory ( path -- )
+ [ make-directories ] [ OCT: 700 set-file-permissions ] bi ;
+
+: check-trash-path ( path -- )
+ {
+ [ file-info directory? ]
+ [ sticky? ]
+ [ link-info type>> +symbolic-link+ = not ]
+ } 1&& [ "invalid trash path" throw ] unless ;
+
+: trash-home ( -- path )
+ "XDG_DATA_HOME" os-env
+ home ".local/share" append-path or
+ "Trash" append-path dup check-trash-path ;
+
+: trash-1 ( root -- path )
+ ".Trash" append-path dup check-trash-path
+ real-user-id number>string append-path ;
+
+: trash-2 ( root -- path )
+ real-user-id ".Trash-%d" sprintf append-path ;
+
+: trash-path ( path -- path' )
+ top-directory dup trash-home top-directory = [
+ drop trash-home
+ ] [
+ dup ".Trash" append-path exists?
+ [ trash-1 ] [ trash-2 ] if
+ [ make-user-directory ] keep
+ ] if ;
+
+: (safe-file-name) ( path counter -- path' )
+ [
+ [ parent-directory ]
+ [ file-stem ]
+ [ file-extension dup [ "." prepend ] when ] tri
+ ] dip swap "%s%s %s%s" sprintf ;
+
+: safe-file-name ( path -- path' )
+ dup 0 [ over exists? ] [
+ [ parent-directory to-directory ] [ 1 + ] bi*
+ [ (safe-file-name) ] keep
+ ] while drop nip ;
+
+PRIVATE>
+
+M: unix send-to-trash ( path -- )
+ dup trash-path [
+ "files" append-path [ make-user-directory ] keep
+ to-directory safe-file-name
+ ] [
+ "info" append-path [ make-user-directory ] keep
+ to-directory ".trashinfo" append [ over ] dip utf8 [
+ "[Trash Info]" write nl
+ "Path=" write write nl
+ "DeletionDate=" write
+ now "%Y-%m-%dT%H:%M:%S" strftime write nl
+ ] with-file-writer
+ ] bi move-file ;
+
+
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors alien.c-types alien.data alien.strings
+alien.syntax classes.struct destructors kernel
+io.encodings.utf16n io.files.trash libc math sequences system
+windows.types ;
+
+IN: io.files.trash.windows
+
+<PRIVATE
+
+LIBRARY: shell32
+
+TYPEDEF: WORD FILEOP_FLAGS
+
+PACKED-STRUCT: SHFILEOPSTRUCTW
+ { hwnd HWND }
+ { wFunc UINT }
+ { pFrom LPCWSTR* }
+ { pTo LPCWSTR* }
+ { fFlags FILEOP_FLAGS }
+ { fAnyOperationsAborted BOOL }
+ { hNameMappings LPVOID }
+ { lpszProgressTitle LPCWSTR } ;
+
+FUNCTION: int SHFileOperationW ( SHFILEOPSTRUCTW* lpFileOp ) ;
+
+CONSTANT: FO_MOVE HEX: 0001
+CONSTANT: FO_COPY HEX: 0002
+CONSTANT: FO_DELETE HEX: 0003
+CONSTANT: FO_RENAME HEX: 0004
+
+CONSTANT: FOF_MULTIDESTFILES HEX: 0001
+CONSTANT: FOF_CONFIRMMOUSE HEX: 0002
+CONSTANT: FOF_SILENT HEX: 0004
+CONSTANT: FOF_RENAMEONCOLLISION HEX: 0008
+CONSTANT: FOF_NOCONFIRMATION HEX: 0010
+CONSTANT: FOF_WANTMAPPINGHANDLE HEX: 0020
+CONSTANT: FOF_ALLOWUNDO HEX: 0040
+CONSTANT: FOF_FILESONLY HEX: 0080
+CONSTANT: FOF_SIMPLEPROGRESS HEX: 0100
+CONSTANT: FOF_NOCONFIRMMKDIR HEX: 0200
+CONSTANT: FOF_NOERRORUI HEX: 0400
+CONSTANT: FOF_NOCOPYSECURITYATTRIBS HEX: 0800
+CONSTANT: FOF_NORECURSION HEX: 1000
+CONSTANT: FOF_NO_CONNECTED_ELEMENTS HEX: 2000
+CONSTANT: FOF_WANTNUKEWARNING HEX: 4000
+CONSTANT: FOF_NORECURSEREPARSE HEX: 8000
+
+PRIVATE>
+
+M: windows send-to-trash ( path -- )
+ [
+ utf16n string>alien B{ 0 0 } append
+ malloc-byte-array &free
+
+ SHFILEOPSTRUCTW <struct>
+ f >>hwnd
+ FO_DELETE >>wFunc
+ swap >>pFrom
+ f >>pTo
+ FOF_ALLOWUNDO
+ FOF_NOCONFIRMATION bitor
+ FOF_NOERRORUI bitor
+ FOF_SILENT bitor >>fFlags
+
+ SHFileOperationW [ throw ] unless-zero
+
+ ] with-destructors ;
+
+
+
"Provides an emulation of the original 8080 Arcade Game 'Lunar Rescue'." $nl\r
"More information on the arcade game can be obtained from " { $url "http://www.mameworld.net/maws/romset/lrescue" } "." $nl\r
"To play the game you need the ROM files for the arcade game. They should "\r
-"be placed in a directory called 'lrescue' in the location specified by "\r
+"be placed in a directory called " { $snippet "lrescue" } " in the location specified by "\r
"the variable " { $link rom-root } ". The specific files needed are:"\r
{ $list\r
"lrescue/lrescue.1"\r
! (Optional) CPU architecture to build for.
SYMBOL: target-cpu
-target-cpu get-global [
- cpu name>> target-cpu set-global
-] unless
+target-cpu get-global [ cpu target-cpu set-global ] unless
! (Optional) OS to build for.
SYMBOL: target-os
-target-os get-global [
- os name>> target-os set-global
-] unless
+target-os get-global [ os target-os set-global ] unless
! Keep test-log around?
SYMBOL: builder-debug
--- /dev/null
+USING: tools.test strings mason.platform ;
+IN: mason.platform.tests
+
+[ t ] [ platform string? ] unit-test
--- /dev/null
+! Copyright (C) 2010 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license
+
+USING: help.markup help.syntax math math.approx ;
+
+IN: math.approx
+
+HELP: approximate
+{ $values { "x" ratio } { "epsilon" ratio } { "y" ratio } }
+{ $description
+"Applied to two fractional numbers \"x\" and \"epsilon\", returns the "
+"simplest rational number within \"epsilon\" of \"x\"."
+$nl
+"A rational number \"y\" is said to be simpler than another \"y'\" if "
+"abs numerator y <= abs numerator y', and denominator y <= demoniator y'"
+$nl
+"Any real interval contains a unique simplest rational; in particular note "
+"that 0/1 is the simplest rational of all."
+} ;
--- /dev/null
+! Copyright (C) 2010 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel math math.approx math.constants
+math.floating-point sequences tools.test ;
+
+IN: math.approx.tests
+
+[ { 3 3 13/4 16/5 19/6 22/7 } ]
+[
+ pi double>ratio
+ { 1/2 1/4 1/8 1/16 1/32 1/64 }
+ [ approximate ] with map
+] unit-test
+
+[ { -3 -3 -13/4 -16/5 -19/6 -22/7 } ]
+[
+ pi double>ratio neg
+ { 1/2 1/4 1/8 1/16 1/32 1/64 }
+ [ approximate ] with map
+] unit-test
--- /dev/null
+! Copyright (C) 2010 John Benediktsson.
+! See http://factorcode.org/license.txt for BSD license
+
+USING: combinators kernel locals math math.functions ;
+
+IN: math.approx
+
+<PRIVATE
+
+:: (simplest) ( n d n' d' -- val ) ! assumes 0 < n/d < n'/d'
+ n d /mod :> ( q r )
+ n' d' /mod :> ( q' r' )
+ {
+ { [ r zero? ] [ q ] }
+ { [ q q' = not ] [ q 1 + ] }
+ [
+ d' r' d r (simplest) >fraction :> ( n'' d'' )
+ q n'' * d'' + n'' /
+ ]
+ } cond ;
+
+:: simplest ( x y -- val )
+ {
+ { [ x y > ] [ y x simplest ] }
+ { [ x y = ] [ x ] }
+ { [ x 0 > ] [ x y [ >fraction ] bi@ (simplest) ] }
+ { [ y 0 < ] [ y x [ neg >fraction ] bi@ (simplest) neg ] }
+ [ 0 ]
+ } cond ;
+
+: check-float ( x -- x )
+ dup float? [ "can't be floats" throw ] when ;
+
+PRIVATE>
+
+: approximate ( x epsilon -- y )
+ [ check-float ] bi@ [ - ] [ + ] 2bi simplest ;
+
--- /dev/null
+John Benediktsson
--- /dev/null
+Approximating rational numbers.
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: help.syntax help.markup io.sockets math memcached
+quotations sequences strings ;
+
+IN: memcached
+
+HELP: memcached-server
+{ $var-description
+ "Holds an " { $link inet } " object with the address of "
+ "an Memcached server."
+} ;
+
+HELP: with-memcached
+{ $values { "quot" quotation } }
+{ $description
+ "Opens a network connection to the " { $link memcached-server }
+ " and runs the specified quotation."
+} ;
+
+HELP: m/get
+{ $values { "key" string } { "val" string } }
+{ $description
+ "Gets a single key."
+} ;
+
+HELP: m/set
+{ $values { "val" string } { "key" string } }
+{ $description
+ "Sets a single key to a particular value, whether the item "
+ "exists or not."
+} ;
+
+HELP: m/add
+{ $values { "val" string } { "key" string } }
+{ $description
+ "Adds an item only if the item does not already exist. "
+ "If the item already exists, throws an error."
+} ;
+
+HELP: m/replace
+{ $values { "val" string } { "key" string } }
+{ $description
+ "Replaces an item only if it already eixsts. "
+ "If the item does not exist, throws an error."
+} ;
+
+HELP: m/delete
+{ $values { "key" string } }
+{ $description
+ "Deletes an item."
+} ;
+
+HELP: m/append
+{ $values { "val" string } { "key" string } }
+{ $description
+ "Appends the value to the specified item."
+} ;
+
+HELP: m/prepend
+{ $values { "val" string } { "key" string } }
+{ $description
+ "Prepends the value to the specified item."
+} ;
+
+HELP: m/incr
+{ $values { "key" string } { "val" string } }
+{ $description
+ "Increments the value of the specified item by 1."
+} ;
+
+HELP: m/incr-val
+{ $values { "amt" string } { "key" string } { "val" string } }
+{ $description
+ "Increments the value of the specified item by the specified amount."
+} ;
+
+HELP: m/decr
+{ $values { "key" string } { "val" string } }
+{ $description
+ "Decrements the value of the specified item by 1."
+} ;
+
+HELP: m/decr-val
+{ $values { "amt" string } { "key" string } { "val" string } }
+{ $description
+ "Decrements the value of the specified item by the specified amount."
+} ;
+
+HELP: m/version
+{ $values { "version" string } }
+{ $description
+ "Retrieves the version of the " { $link memcached-server } "."
+} ;
+
+HELP: m/noop
+{ $description
+ "Used as a keep-alive. Also flushes any outstanding quiet gets."
+} ;
+
+HELP: m/stats
+{ $values { "stats" sequence } }
+{ $description
+ "Get various statistics about the " { $link memcached-server } "."
+} ;
+
+HELP: m/flush
+{ $description
+ "Deletes all the items in the cache now."
+} ;
+
+HELP: m/flush-later
+{ $values { "seconds" integer } }
+{ $description
+ "Deletes all the items in the cache sometime in the future."
+} ;
+
+HELP: m/quit
+{ $description
+ "Close the connection to the " { $link memcached-server } "."
+} ;
+
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: calendar math math.functions memcached memcached.private
+kernel sequences threads tools.test ;
+
+IN: memcached.tests
+
+<PRIVATE
+
+: not-found? ( quot -- )
+ [ "key not found" = ] must-fail-with ;
+
+PRIVATE>
+
+! test version
+[ t ] [ [ m/version ] with-memcached length 0 > ] unit-test
+
+! test simple set get
+[ m/flush ] with-memcached
+[ "valuex" "x" m/set ] with-memcached
+[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
+
+! test flush
+[ m/flush ] with-memcached
+[ "valuex" "x" m/set "valuey" "y" m/set ] with-memcached
+[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
+[ "valuey" ] [ [ "y" m/get ] with-memcached ] unit-test
+[ m/flush ] with-memcached
+[ [ "x" m/get ] with-memcached ] not-found?
+[ [ "y" m/get ] with-memcached ] not-found?
+
+! test noop
+[ m/noop ] with-memcached
+
+! test delete
+[ m/flush ] with-memcached
+[ "valuex" "x" m/set ] with-memcached
+[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
+[ "x" m/delete ] with-memcached
+[ [ "x" m/get ] with-memcached ] not-found?
+
+! test replace
+[ m/flush ] with-memcached
+[ [ "x" m/get ] with-memcached ] not-found?
+[ [ "ex" "x" m/replace ] with-memcached ] not-found?
+[ "ex" "x" m/add ] with-memcached
+[ "ex" ] [ [ "x" m/get ] with-memcached ] unit-test
+[ "ex2" "x" m/replace ] with-memcached
+[ "ex2" ] [ [ "x" m/get ] with-memcached ] unit-test
+
+! test incr
+[ m/flush ] with-memcached
+[ 0 ] [ [ "x" m/incr ] with-memcached ] unit-test
+[ 1 ] [ [ "x" m/incr ] with-memcached ] unit-test
+[ 212 ] [ [ 211 "x" m/incr-val ] with-memcached ] unit-test
+[ 8589934804 ] [ [ 2 33 ^ "x" m/incr-val ] with-memcached ] unit-test
+
+! test decr
+[ m/flush ] with-memcached
+[ "5" "x" m/set ] with-memcached
+[ 4 ] [ [ "x" m/decr ] with-memcached ] unit-test
+[ 0 ] [ [ 211 "x" m/decr-val ] with-memcached ] unit-test
+
+! test timebombed flush
+[ m/flush ] with-memcached
+[ [ "x" m/get ] with-memcached ] not-found?
+[ "valuex" "x" m/set ] with-memcached
+[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
+[ 2 m/flush-later ] with-memcached
+[ "valuex" ] [ [ "x" m/get ] with-memcached ] unit-test
+3 seconds sleep
+[ [ "x" m/get ] with-memcached ] not-found?
+
+! test append
+[ m/flush ] with-memcached
+[ "some" "x" m/set ] with-memcached
+[ "thing" "x" m/append ] with-memcached
+[ "something" ] [ [ "x" m/get ] with-memcached ] unit-test
+
+! test prepend
+[ m/flush ] with-memcached
+[ "some" "x" m/set ] with-memcached
+[ "thing" "x" m/prepend ] with-memcached
+[ "thingsome" ] [ [ "x" m/get ] with-memcached ] unit-test
+
+! test multi-get
+[ m/flush ] with-memcached
+[ H{ } ] [ [ { "x" "y" "z" } m/getseq ] with-memcached ] unit-test
+[ "5" "x" m/set ] with-memcached
+[ "valuex" "y" m/set ] with-memcached
+[ H{ { "x" "5" } { "y" "valuex" } } ]
+[ [ { "x" "y" "z" } m/getseq ] with-memcached ] unit-test
+
+
+
+
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays assocs byte-arrays combinators fry
+io io.encodings.binary io.sockets kernel make math math.parser
+namespaces pack random sequences strings ;
+
+IN: memcached
+
+! TODO:
+! - quiet commands
+! - CAS
+! - expirations
+! - initial-value for incr/decr
+
+
+SYMBOL: memcached-server
+"127.0.0.1" 11211 <inet> memcached-server set-global
+
+: with-memcached ( quot -- )
+ memcached-server get-global
+ binary [ call ] with-client ; inline
+
+<PRIVATE
+
+! Commands
+CONSTANT: GET HEX: 00
+CONSTANT: SET HEX: 01
+CONSTANT: ADD HEX: 02
+CONSTANT: REPLACE HEX: 03
+CONSTANT: DELETE HEX: 04
+CONSTANT: INCR HEX: 05
+CONSTANT: DECR HEX: 06
+CONSTANT: QUIT HEX: 07
+CONSTANT: FLUSH HEX: 08
+CONSTANT: GETQ HEX: 09
+CONSTANT: NOOP HEX: 0A
+CONSTANT: VERSION HEX: 0B
+CONSTANT: GETK HEX: 0C
+CONSTANT: GETKQ HEX: 0D
+CONSTANT: APPEND HEX: 0E
+CONSTANT: PREPEND HEX: 0F
+CONSTANT: STAT HEX: 10
+CONSTANT: SETQ HEX: 11
+CONSTANT: ADDQ HEX: 12
+CONSTANT: REPLACEQ HEX: 13
+CONSTANT: DELETEQ HEX: 14
+CONSTANT: INCRQ HEX: 15
+CONSTANT: DECRQ HEX: 16
+CONSTANT: QUITQ HEX: 17
+CONSTANT: FLUSHQ HEX: 18
+CONSTANT: APPENDQ HEX: 19
+CONSTANT: PREPENDQ HEX: 1A
+
+! Errors
+CONSTANT: NOT_FOUND HEX: 01
+CONSTANT: EXISTS HEX: 02
+CONSTANT: TOO_LARGE HEX: 03
+CONSTANT: INVALID_ARGS HEX: 04
+CONSTANT: NOT_STORED HEX: 05
+CONSTANT: NOT_NUMERIC HEX: 06
+CONSTANT: UNKNOWN_CMD HEX: 81
+CONSTANT: MEMORY HEX: 82
+
+TUPLE: request cmd key val extra opaque cas ;
+
+: <request> ( cmd -- request )
+ "" "" "" random-32 0 \ request boa ;
+
+: send-header ( request -- )
+ {
+ [ cmd>> ]
+ [ key>> length ]
+ [ extra>> length ]
+ [
+ [ key>> length ]
+ [ extra>> length ]
+ [ val>> length ] tri + +
+ ]
+ [ opaque>> ]
+ [ cas>> ]
+ } cleave
+ ! magic, opcode, keylen, extralen, datatype, status,
+ ! bodylen, opaque, cas [ big-endian ]
+ '[ HEX: 80 _ _ _ 0 0 _ _ _ ] "CCSCCSIIQ" pack-be write ;
+
+: (send) ( str -- )
+ [ >byte-array write ] unless-empty ;
+
+: send-request ( request -- )
+ {
+ [ send-header ]
+ [ extra>> (send) ]
+ [ key>> (send) ]
+ [ val>> (send) ]
+ } cleave flush ;
+
+: read-header ( -- header )
+ "CCSCCSIIQ" [ packed-length read ] [ unpack-be ] bi ;
+
+: check-magic ( header -- )
+ first HEX: 81 = [ "bad magic" throw ] unless ;
+
+: check-status ( header -- )
+ [ 5 ] dip nth {
+ { NOT_FOUND [ "key not found" throw ] }
+ { EXISTS [ "key exists" throw ] }
+ { TOO_LARGE [ "value too large" throw ] }
+ { INVALID_ARGS [ "invalid arguments" throw ] }
+ { NOT_STORED [ "item not stored" throw ] }
+ { NOT_NUMERIC [ "value not numeric" throw ] }
+ { UNKNOWN_CMD [ "unknown command" throw ] }
+ { MEMORY [ "out of memory" throw ] }
+ [ drop ]
+ } case ;
+
+: check-opaque ( opaque header -- ? )
+ [ 7 ] dip nth = ;
+
+: (read) ( n -- str )
+ dup 0 > [ read >string ] [ drop "" ] if ;
+
+: read-key ( header -- key )
+ [ 2 ] dip nth (read) ;
+
+: read-val ( header -- val )
+ [ [ 6 ] dip nth ] [ [ 2 ] dip nth ] bi - (read) ;
+
+: read-body ( header -- val key )
+ {
+ [ check-magic ]
+ [ check-status ]
+ [ read-key ]
+ [ read-val ]
+ } cleave swap ;
+
+: read-response ( -- val key )
+ read-header read-body ;
+
+: submit ( request -- response )
+ send-request read-response drop ;
+
+: (cmd) ( key cmd -- request )
+ <request> swap >>key ;
+
+: (incr/decr) ( amt key cmd -- response )
+ (cmd) swap '[ _ 0 0 ] "QQI" pack-be >>extra ! amt init exp
+ submit "Q" unpack-be first ;
+
+: (mutate) ( val key cmd -- )
+ (cmd) swap >>val { 0 0 } "II" pack-be >>extra ! flags exp
+ submit drop ;
+
+: (cat) ( val key cmd -- )
+ (cmd) swap >>val submit drop ;
+
+PRIVATE>
+
+: m/version ( -- version ) VERSION <request> submit ;
+
+: m/noop ( -- ) NOOP <request> submit drop ;
+
+: m/incr-val ( amt key -- val ) INCR (incr/decr) ;
+
+: m/incr ( key -- val ) 1 swap m/incr-val ;
+
+: m/decr-val ( amt key -- val ) DECR (incr/decr) ;
+
+: m/decr ( key -- val ) 1 swap m/decr-val ;
+
+: m/get ( key -- val ) GET (cmd) submit 4 tail ;
+
+: m/getq ( opaque key -- )
+ GETQ (cmd) swap >>opaque send-request ;
+
+: m/getseq ( keys -- vals )
+ [ H{ } clone ] dip
+ [ <enum> [ m/getq ] assoc-each ]
+ [ length 10 + NOOP <request> swap >>opaque send-request ]
+ [
+ <enum> [
+ assoc-size 10 + '[
+ _ read-header [ check-opaque ] keep swap
+ ]
+ ] [
+ '[
+ [ read-body drop 4 tail ]
+ [ [ 7 ] dip nth _ at ]
+ bi pick set-at
+ ]
+ ] bi until drop
+ ] tri ;
+
+: m/set ( val key -- ) SET (mutate) ;
+
+: m/add ( val key -- ) ADD (mutate) ;
+
+: m/replace ( val key -- ) REPLACE (mutate) ;
+
+: m/delete ( key -- ) DELETE (cmd) submit drop ;
+
+: m/append ( val key -- ) APPEND (cat) ;
+
+: m/prepend ( val key -- ) PREPEND (cat) ;
+
+: m/flush-later ( seconds -- )
+ FLUSH <request> swap 1array "I" pack-be >>extra ! timebomb
+ submit drop ;
+
+: m/flush ( -- ) 0 m/flush-later ;
+
+: m/stats ( -- stats )
+ STAT <request> send-request
+ [ read-response dup length 0 > ]
+ [ swap 2array ] produce 2nip ;
+
+: m/quit ( -- ) QUIT <request> submit drop ;
+
+
--- /dev/null
+Provides access to memcached, a high-performance, distributed memory object caching system.
--- /dev/null
+John Benediktsson
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: help.syntax help.markup ntp ntp.private strings ;
+
+IN: ntp
+
+HELP: <ntp>
+{ $values { "host" string } { "ntp" ntp } }
+{ $description
+ "Requests the time from the specified NTP time server."
+} ;
+
--- /dev/null
+! Copyright (C) 2010 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays calendar combinators destructors
+fry formatting kernel io io.sockets math pack random
+sequences ;
+
+IN: ntp
+
+<PRIVATE
+
+CONSTANT: REQUEST B{ HEX: 1b 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0
+ 0 0 0 0 0 0 0 0 }
+
+: (time) ( sequence -- timestamp )
+ [ first ] [ second 32 2^ / ] bi + seconds
+ 1900 1 1 0 0 0 instant <timestamp> time+ ;
+
+: (leap) ( leap -- string/f )
+ {
+ { 0 [ "no warning" ] }
+ { 1 [ "last minute has 61 seconds" ] }
+ { 2 [ "last minute has 59 seconds" ] }
+ { 3 [ "alarm condition (clock not synchronized)" ] }
+ [ drop f ]
+ } case ;
+
+: (mode) ( mode -- string )
+ {
+ { 0 [ "unspecified" ] }
+ { 1 [ "symmetric active" ] }
+ { 2 [ "symmetric passive" ] }
+ { 3 [ "client" ] }
+ { 4 [ "server" ] }
+ { 5 [ "broadcast" ] }
+ { 6 [ "reserved for NTP control message" ] }
+ { 7 [ "reserved for private use" ] }
+ [ drop f ]
+ } case ;
+
+: (stratum) ( stratum -- string )
+ {
+ { 0 [ "unspecified or unavailable" ] }
+ { 1 [ "primary reference (e.g., radio clock)" ] }
+ [
+ [ 1 > ] [ 255 < ] bi and
+ [ "secondary reference (via NTP or SNTP)" ]
+ [ "invalid stratum" throw ] if
+ ]
+ } case ;
+
+: (ref-id) ( ref-id stratum -- string )
+ [
+ {
+ [ -24 shift HEX: ff bitand ]
+ [ -16 shift HEX: ff bitand ]
+ [ -8 shift HEX: ff bitand ]
+ [ HEX: ff bitand ]
+ } cleave
+ ] dip {
+ { 0 [ "%c%c%c%c" sprintf ] }
+ { 1 [ "%c%c%c%c" sprintf ] }
+ [
+ [ 1 > ] [ 255 < ] bi and
+ [ "%d.%d.%d.%d" sprintf ]
+ [ "invalid stratum" throw ] if
+ ]
+ } case ;
+
+TUPLE: ntp leap version mode stratum poll precision
+root-delay root-dispersion ref-id ref-timestamp
+orig-timestamp recv-timestamp tx-timestamp ;
+
+: (ntp) ( payload -- ntp )
+ "CCCcIIIIIIIIIII" unpack-be {
+ [ first -6 shift HEX: 3 bitand ] ! leap
+ [ first -3 shift HEX: 7 bitand ] ! version
+ [ first HEX: 7 bitand ] ! mode
+ [ second ] ! stratum
+ [ third ] ! poll
+ [ [ 3 ] dip nth ] ! precision
+ [ [ 4 ] dip nth 16 2^ / ] ! root-delay
+ [ [ 5 ] dip nth 16 2^ / ] ! root-dispersion
+ [ [ 6 ] dip nth ] ! ref-id
+ [ [ { 7 8 } ] dip nths (time) ] ! ref-timestamp
+ [ [ { 9 10 } ] dip nths (time) ] ! orig-timestamp
+ [ [ { 11 12 } ] dip nths (time) ] ! recv-timestamp
+ [ [ { 13 14 } ] dip nths (time) ] ! tx-timestamp
+ } cleave ntp boa
+ dup stratum>> '[ _ (ref-id) ] change-ref-id
+ [ dup (leap) 2array ] change-leap
+ [ dup (mode) 2array ] change-mode
+ [ dup (stratum) 2array ] change-stratum ;
+
+PRIVATE>
+
+! TODO:
+! - socket timeout?
+! - format request properly?
+! - strftime should format millis?
+! - why does <inet4> resolve-host not work?
+
+: <ntp> ( host -- ntp )
+ 123 <inet> resolve-host [ inet4? ] filter random
+ f 0 <inet4> <datagram> [
+ [ REQUEST ] 2dip [ send ] [ receive drop ] bi (ntp)
+ ] with-disposal ;
+
+: default-ntp ( -- ntp )
+ "pool.ntp.org" <ntp> ;
+
+: local-ntp ( -- ntp )
+ "localhost" <ntp> ;
+
--- /dev/null
+Client for NTP protocol
}
! { $slide "Stack languages are fundamental"
! "Very simple semantics"
- ! "Easy to generate stack code programatically"
+ ! "Easy to generate stack code programmatically"
! "Everything is almost entirely library code in Factor"
! "Factor is easy to extend"
! }
} ;
ARTICLE: "readline" "Readline"
-{ $vocab-link "readline" }
-;
+"The " { $vocab-link "readline" } " vocabulary binds to the C readline library and provides Emacs-style key bindings for editing text. Currently, it only works from the non-graphical UI." $nl
+"To read a line:"
+{ $subsections readline }
+"To set a completion hook:"
+{ $subsections set-completion } ;
ABOUT: "readline"
--- /dev/null
+John Benediktsson
--- /dev/null
+Reader and writer for "tagged netstrings"
--- /dev/null
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: kernel tnetstrings sequences tools.test ;
+
+[ t ] [
+ {
+ { H{ } "0:}" }
+ { { } "0:]" }
+ { "" "0:\"" }
+ { t "4:true!" }
+ { f "5:false!" }
+ { 12345 "5:12345#" }
+ { "this is cool" "12:this is cool\"" }
+ {
+ H{ { "hello" { 12345678901 "this" } } }
+ "34:5:hello\"22:11:12345678901#4:this\"]}"
+ }
+ {
+ { 12345 67890 "xxxxx" }
+ "24:5:12345#5:67890#5:xxxxx\"]"
+ }
+ } [
+ first2 [ tnetstring> = ] [ swap >tnetstring = ] 2bi and
+ ] all?
+] unit-test
--- /dev/null
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: arrays assocs combinators formatting hashtables kernel
+math math.parser sequences splitting strings ;
+
+IN: tnetstrings
+
+<PRIVATE
+
+: parse-payload ( data -- remain payload payload-type )
+ ":" split1 swap string>number cut unclip swapd ;
+
+DEFER: parse-tnetstring
+
+: parse-list ( data -- value )
+ [ { } ] [
+ [ dup empty? not ] [ parse-tnetstring ] produce nip
+ ] if-empty ;
+
+: parse-pair ( data -- extra value key )
+ parse-tnetstring [
+ [ "Unbalanced dictionary store" throw ] when-empty
+ parse-tnetstring
+ [ "Invalid value, null not allowed" throw ] unless*
+ ] dip ;
+
+: parse-dict ( data -- value )
+ [ H{ } ] [
+ [ dup empty? not ] [ parse-pair swap 2array ] produce
+ nip >hashtable
+ ] if-empty ;
+
+: parse-bool ( data -- ? )
+ {
+ { "true" [ t ] }
+ { "false" [ f ] }
+ [ "Invalid bool: %s" sprintf throw ]
+ } case ;
+
+: parse-null ( data -- f )
+ [ f ] [ drop "Payload must be 0 length" throw ] if-empty ;
+
+: parse-tnetstring ( data -- remain value )
+ parse-payload {
+ { CHAR: # [ string>number ] }
+ { CHAR: " [ ] }
+ { CHAR: } [ parse-dict ] }
+ { CHAR: ] [ parse-list ] }
+ { CHAR: ! [ parse-bool ] }
+ { CHAR: ~ [ parse-null ] }
+ { CHAR: , [ ] }
+ [ "Invalid payload type: %c" sprintf throw ]
+ } case ;
+
+PRIVATE>
+
+: tnetstring> ( string -- value )
+ parse-tnetstring swap [
+ "Had trailing junk: %s" sprintf throw
+ ] unless-empty ;
+
+<PRIVATE
+
+DEFER: dump-tnetstring
+
+: dump ( string type -- string )
+ [ [ length ] keep ] dip "%d:%s%s" sprintf ;
+
+: dump-number ( data -- string ) number>string "#" dump ;
+
+: dump-string ( data -- string ) "\"" dump ;
+
+: dump-list ( data -- string )
+ [ dump-tnetstring ] map "" concat-as "]" dump ;
+
+: dump-dict ( data -- string )
+ >alist [ first2 [ dump-tnetstring ] bi@ append ] map
+ "" concat-as "}" dump ;
+
+: dump-bool ( ? -- string )
+ "4:true!" "5:false!" ? ;
+
+: dump-tnetstring ( data -- string )
+ {
+ { [ dup boolean? ] [ dump-bool ] }
+ { [ dup number? ] [ dump-number ] }
+ { [ dup string? ] [ dump-string ] }
+ { [ dup sequence? ] [ dump-list ] }
+ { [ dup assoc? ] [ dump-dict ] }
+ [ "Can't serialize object" throw ]
+ } cond ;
+
+PRIVATE>
+
+: >tnetstring ( value -- string )
+ dump-tnetstring ;
+
-USING: listener io.servers io.encodings.utf8 accessors kernel ;
+USING: accessors debugger kernel listener io.servers
+io.encodings.utf8 namespaces ;
+
IN: tty-server
-: <tty-server> ( port -- )
+: start-listener ( -- )
+ [ [ drop print-error-and-restarts ] error-hook set listener ] with-scope ;
+
+: <tty-server> ( port -- server )
utf8 <threaded-server>
"tty-server" >>name
swap local-server >>insecure
- [ listener ] >>handler
- start-server drop ;
+ [ start-listener ] >>handler
+ f >>timeout ;
-: tty-server ( -- ) 9999 <tty-server> ;
+: run-tty-server ( -- )
+ 9999 <tty-server> start-server drop ;
-MAIN: tty-server
+MAIN: run-tty-server
}
}
{ $slide "Object system"
- "We can compute perimiters now."
+ "We can compute perimeters now."
{ $code "100 20 <rectangle> perimeter ." }
{ $code "3 <circle> perimeter ." }
}
--- /dev/null
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors furnace.actions http.server
+http.server.dispatchers http.server.responses http.server.static
+kernel namespaces ;
+
+IN: webapps.benchmark
+
+: <hello-action> ( -- action )
+ <page-action>
+ [ "Hello, world!" "text/plain" <content> ] >>display ;
+
+TUPLE: benchmark < dispatcher ;
+
+: <benchmark> ( -- dispatcher )
+ benchmark new-dispatcher
+ <hello-action> "hello" add-responder
+ "resource:" <static> "static" add-responder ;
+
+: run-benchmark ( -- )
+ <benchmark>
+ main-responder set-global
+ 8080 httpd drop ;
+
+! Use this with apachebench:
+!
+! * dynamic content
+! http://localhost:8080/hello
+!
+! * static content
+! http://localhost:8080/static/readme.html
+
+MAIN: run-benchmark
-/* Copyright (C) 2007 Chris Double. All Rights Reserved.\r
- See http://factorcode.org/license.txt for BSD license. */\r
-\r
-var fjsc_repl = false;\r
-\r
-function fjsc_repl_handler() {\r
- var my_term = this;\r
- this.newLine();\r
- if(this.lineBuffer != '') {\r
- factor.server_eval(\r
- this.lineBuffer, \r
- function(text, result) { \r
- document.getElementById("compiled").value = result;\r
- display_datastack(); \r
- }, \r
- function() { my_term.prompt(); });\r
- }\r
- else\r
- my_term.prompt();\r
-}\r
-\r
-function fjsc_init_handler() {\r
- this.write(\r
- [\r
- TermGlobals.center('********************************************************'),\r
- TermGlobals.center('* *'),\r
- TermGlobals.center('* Factor to Javascript Compiler Example *'),\r
- TermGlobals.center('* *'),\r
- TermGlobals.center('********************************************************')\r
- ]);\r
- \r
- this.prompt();\r
-}\r
-\r
-function startup() {\r
- var conf = {\r
- x: 0,\r
- y: 0,\r
- cols: 64,\r
- rows: 18,\r
- termDiv: "repl",\r
- crsrBlinkMode: true,\r
- ps: "scratchpad ",\r
- initHandler: fjsc_init_handler,\r
- handler: fjsc_repl_handler\r
- };\r
- fjsc_repl = new Terminal(conf);\r
- fjsc_repl.open();\r
-}\r
-\r
-function display_datastack() {\r
- var html=[];\r
- html.push("<table border='1'>")\r
- for(var i = 0; i < factor.cont.data_stack.length; ++i) {\r
- html.push("<tr><td>")\r
- html.push(factor.cont.data_stack[i])\r
- html.push("</td></tr>")\r
- }\r
- html.push("</table>")\r
- document.getElementById('stack').innerHTML=html.join("");\r
-}\r
-\r
-jQuery(function() {\r
- startup();\r
- display_datastack();\r
-});\r
-\r
-factor.add_word("kernel", ".s", "primitive", function(next) { \r
- var stack = factor.cont.data_stack;\r
- var term = fjsc_repl;\r
- for(var i=0; i<stack.length; ++i) {\r
- term.type(""+stack[i]);\r
- term.newLine();\r
- }\r
- factor.call_next(next);\r
-});\r
-\r
-factor.add_word("io", "print", "primitive", function(next) { \r
- var stack = factor.cont.data_stack;\r
- var term = fjsc_repl;\r
- term.type(""+stack.pop());\r
- term.newLine();\r
- factor.call_next(next);\r
-});\r
-\r
-factor.add_word("io", "write", "primitive", function(next) { \r
- var stack = factor.cont.data_stack;\r
- var term = fjsc_repl;\r
- term.type(""+stack.pop());\r
- factor.call_next(next);\r
-});\r
-\r
-factor.add_word("io", ".", "primitive", function(next) { \r
- var stack = factor.cont.data_stack;\r
- var term = fjsc_repl;\r
- term.type(""+stack.pop());\r
- term.newLine();\r
- factor.call_next(next);\r
-});\r
+/* Copyright (C) 2007 Chris Double. All Rights Reserved.
+ See http://factorcode.org/license.txt for BSD license. */
+
+var fjsc_repl = false;
+
+function fjsc_repl_handler() {
+ var my_term = this;
+ this.newLine();
+ if(this.lineBuffer != '') {
+ factor.server_eval(
+ this.lineBuffer,
+ function(text, result) {
+ document.getElementById("compiled").value = result;
+ display_datastack();
+ },
+ function() { my_term.prompt(); });
+ }
+ else
+ my_term.prompt();
+}
+
+function fjsc_init_handler() {
+ this.write(
+ [
+ TermGlobals.center('********************************************************'),
+ TermGlobals.center('* *'),
+ TermGlobals.center('* Factor to Javascript Compiler Example *'),
+ TermGlobals.center('* *'),
+ TermGlobals.center('********************************************************')
+ ]);
+
+ this.prompt();
+}
+
+function startup() {
+ var conf = {
+ x: 0,
+ y: 0,
+ cols: 64,
+ rows: 18,
+ termDiv: "repl",
+ crsrBlinkMode: true,
+ ps: "( scratchpad )",
+ initHandler: fjsc_init_handler,
+ handler: fjsc_repl_handler
+ };
+ fjsc_repl = new Terminal(conf);
+ fjsc_repl.open();
+}
+
+function display_datastack() {
+ var html=[];
+ html.push("<table border='1'>")
+ for(var i = 0; i < factor.cont.data_stack.length; ++i) {
+ html.push("<tr><td>")
+ html.push(factor.cont.data_stack[i])
+ html.push("</td></tr>")
+ }
+ html.push("</table>")
+ document.getElementById('stack').innerHTML=html.join("");
+}
+
+jQuery(function() {
+ startup();
+ display_datastack();
+});
+
+factor.add_word("kernel", ".s", "primitive", function(next) {
+ var stack = factor.cont.data_stack;
+ var term = fjsc_repl;
+ for(var i=0; i<stack.length; ++i) {
+ term.type(""+stack[i]);
+ term.newLine();
+ }
+ factor.call_next(next);
+});
+
+factor.add_word("io", "print", "primitive", function(next) {
+ var stack = factor.cont.data_stack;
+ var term = fjsc_repl;
+ term.type(""+stack.pop());
+ term.newLine();
+ factor.call_next(next);
+});
+
+factor.add_word("io", "write", "primitive", function(next) {
+ var stack = factor.cont.data_stack;
+ var term = fjsc_repl;
+ term.type(""+stack.pop());
+ factor.call_next(next);
+});
+
+factor.add_word("io", ".", "primitive", function(next) {
+ var stack = factor.cont.data_stack;
+ var term = fjsc_repl;
+ term.type(""+stack.pop());
+ term.newLine();
+ factor.call_next(next);
+});
: platform ( builder -- string )
[ os>> ] [ cpu>> ] bi (platform) ;
+SLOT: last-release
+
: binary-package-name ( builder -- string )
[ [ platform % "/" % ] [ last-release>> % ] bi ] "" make
remote-directory ;
<li><a href="http://concatenative.org/wiki/view/Factor/FAQ">Get answers to frequently-asked questions</a></li>
<li><a href="http://docs.factorcode.org/">Read Factor reference documentation online</a></li>
<li><a href="http://concatenative.org/wiki/view/Concatenative%20language">Learn more about concatenative programming</a></li>
+<li><a href="http://github.com/slavapestov/factor/issues">Report a bug</a></li>
</ul>
<p>Most of the above links point to pages on the <a href="http://concatenative.org">concatenative.org wiki</a>.</p>
"resource:extra/websites/factorcode/examples.txt" utf8 file-lines
{ "----" } split random
"factor" [ highlight-lines ] with-html-writer
-[ xml>string write-html ] each
+xml>string write-html
%></pre>
<p>See the <a href="http://concatenative.org/wiki/view/Factor/Examples">example programs</a> page on the wiki for more.</p>
--- /dev/null
+John Benediktsson
--- /dev/null
+Query API for Wolfram Alpha
--- /dev/null
+! Copyright (C) 2011 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors colors.constants formatting http http.client
+images.gif images.http io io.styles kernel namespaces sequences
+splitting ui urls.encoding xml xml.data xml.traversal ;
+
+IN: wolfram-alpha
+
+SYMBOL: wolfram-api-id
+
+! "XXXXXX-XXXXXXXXXX" wolfram-api-id set-global
+
+<PRIVATE
+
+: query ( query -- xml )
+ url-encode wolfram-api-id get-global
+ "http://api.wolframalpha.com/v2/query?input=%s&appid=%s"
+ sprintf http-get nip string>xml ;
+
+PRIVATE>
+
+: wolfram-image. ( query -- )
+ query "pod" tags-named [
+ [
+ "title" attr "%s:\n" sprintf H{
+ { foreground COLOR: slate-gray }
+ { font-name "sans-serif" }
+ { font-style bold }
+ } format
+ ] [
+ "img" deep-tags-named [
+ "src" attr " " write http-image.
+ ] each
+ ] bi
+ ] each ;
+
+: wolfram-text. ( query -- )
+ query "pod" tags-named [
+ [ "title" attr "%s:\n" printf ]
+ [
+ "plaintext" deep-tags-named [
+ children>string string-lines
+ [ " %s\n" printf ] each
+ ] each
+ ] bi
+ ] each ;
+
+: wolfram. ( query -- )
+ ui-running? [ wolfram-image. ] [ wolfram-text. ] if ;
projects / factor.git / commitdiff