Merge branch 'master' into xml

Conflicts:

	extra/rss/rss.factor
	extra/sequences/lib/lib.factor
	extra/xml/data/data.factor
db4
Daniel Ehrenberg 2007-12-19 12:40:55 -05:00
commit b8f210a3be
401 changed files with 66923 additions and 2994 deletions

View File

@ -57,12 +57,12 @@ default:
@echo "openbsd-x86-32"
@echo "openbsd-x86-64"
@echo "macosx-x86-32"
@echo "macosx-x86-64"
@echo "macosx-ppc"
@echo "solaris-x86-32"
@echo "solaris-x86-64"
@echo "windows-ce-arm"
@echo "windows-nt-x86-32"
@echo "windows-nt-x86-64"
@echo ""
@echo "Additional modifiers:"
@echo ""
@ -93,6 +93,9 @@ macosx-ppc: macosx-freetype
macosx-x86-32: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86.32
macosx-x86-64: macosx-freetype
$(MAKE) $(EXECUTABLE) macosx.app CONFIG=vm/Config.macosx.x86.64
linux-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.linux.x86.32
@ -114,9 +117,6 @@ solaris-x86-64:
windows-nt-x86-32:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
windows-nt-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
windows-ce-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
@ -142,7 +142,7 @@ clean:
rm -f vm/*.o
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
windres vm/factor.rs vm/resources.o
.c.o:
$(CC) -c $(CFLAGS) -o $@ $<

View File

@ -74,6 +74,10 @@ following command line:
./factor -i=boot.<cpu>.image
Or this command for Mac OS X systems:
./Factor.app/Contents/MacOS/factor -i=boot.<cpu>.image
Bootstrap can take a while, depending on your system. When the process
completes, a 'factor.image' file will be generated. Note that this image
is both CPU and OS-specific, so in general cannot be shared between

2
core/alien/syntax/syntax.factor Normal file → Executable file
View File

@ -59,4 +59,4 @@ M: alien pprint*
{ [ t ] [ \ ALIEN: [ alien-address pprint* ] pprint-prefix ] }
} cond ;
M: dll pprint* dll-path dup "DLL\" " pprint-string ;
M: dll pprint* dll-path dup "DLL\" " "\"" pprint-string ;

View File

@ -87,3 +87,9 @@ unit-test
[ H{ { 1 2 } { 3 4 } } ]
[ "hi" 5 H{ { 1 2 } { 3 4 } } clone [ rename-at ] keep ]
unit-test
[
H{ { 1.0 1.0 } { 2.0 2.0 } }
] [
F{ 1.0 2.0 } [ dup ] H{ } map>assoc
] unit-test

View File

@ -135,7 +135,7 @@ M: assoc assoc-clone-like ( assoc exemplar -- newassoc )
[ 0 or + ] change-at ;
: map>assoc ( seq quot exemplar -- assoc )
>r [ 2array ] compose map r> assoc-like ; inline
>r [ 2array ] compose { } map-as r> assoc-like ; inline
M: assoc >alist [ 2array ] { } assoc>map ;

View File

@ -14,7 +14,7 @@ $nl
ABOUT: "bootstrap.image"
HELP: make-image
{ $values { "architecture" "a string" } }
{ $values { "arch" "a string" } }
{ $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:"
{ $code "x86.32" "x86.64" "ppc" "arm" }
"The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;

View File

@ -67,10 +67,12 @@ IN: bootstrap.stage2
[
boot
do-init-hooks
[ parse-command-line ] try
[ run-user-init ] try
[ "run" get run ] try
stdio get [ stream-flush ] when*
[
parse-command-line
run-user-init
"run" get run
stdio get [ stream-flush ] when*
] [ print-error 1 exit ] recover
] set-boot-quot
: count-words all-words swap subset length pprint ;

View File

@ -5,7 +5,7 @@ classes.predicate ;
IN: classes
ARTICLE: "builtin-classes" "Built-in classes"
"Every object is an instance of to exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
"Every object is an instance of exactly one canonical " { $emphasis "built-in class" } " which defines its layout in memory and basic behavior."
$nl
"Corresponding to every built-in class is a built-in type number. An object can be asked for its built-in type number:"
{ $subsection type }
@ -203,17 +203,3 @@ HELP: define-class
{ $values { "word" word } { "members" "a sequence of class words" } { "superclass" class } { "metaclass" class } }
{ $description "Sets a property indicating this word is a class word, thus making it an instance of " { $link class } ", and registers it with " { $link typemap } " and " { $link class<map } "." }
$low-level-note ;
: $predicate ( element -- )
{ { "object" object } { "?" "a boolean" } } $values
[
"Tests if the object is an instance of the " ,
first "predicating" word-prop \ $link swap 2array ,
" class." ,
] { } make $description ;
M: predicate word-help* drop \ $predicate ;
HELP: $predicate
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
{ $description "Prints the boilerplate description of a class membership predicate word such as " { $link array? } " or " { $link integer? } "." } ;

View File

@ -79,6 +79,10 @@ M: sequence hashcode*
dup empty? [
drop
] [
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append
dup length 4 <= [
case>quot
] [
hash-case-table hash-dispatch-quot
[ dup hashcode >fixnum ] swap append
] if
] if ;

View File

@ -16,9 +16,10 @@ M: object inference-error-major? drop t ;
: begin-batch ( seq -- )
batch-mode on
[
"Compiling " % length # " words..." %
] "" make print flush
"quiet" get [ drop ] [
[ "Compiling " % length # " words..." % ] "" make
print flush
] if
V{ } clone compile-errors set-global ;
: compile-error. ( pair -- )

View File

@ -50,7 +50,7 @@ IN: temporary
global keys =
] unit-test
[ 3 ] [ 1 2 [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test
[ 3 ] [ 1 [ 2 ] [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test
[ 3 ] [ t [ 3 [ ] curry 4 [ ] curry if ] compile-1 ] unit-test

View File

@ -56,3 +56,8 @@ IN: temporary
\ recursive compile
[ ] [ t recursive ] unit-test
! Make sure error reporting works
[ [ dup ] compile-1 ] unit-test-fails
[ [ drop ] compile-1 ] unit-test-fails

View File

@ -85,7 +85,7 @@ HELP: continuation
{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ;
HELP: >continuation<
{ $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } { "c" array } }
{ $values { "continuation" continuation } { "data" vector } { "retain" vector } { "call" vector } { "name" vector } { "catch" vector } }
{ $description "Takes a continuation apart into its constituents." } ;
HELP: ifcc

View File

@ -48,11 +48,10 @@ HELP: literal-table
{ $var-description "Holds a vector of literal objects referenced from the currently compiling word. If " { $link compiled-stack-traces? } " is on, " { $link init-generator } " ensures that the first entry is the word being compiled." } ;
HELP: init-generator
{ $values { "word" word } }
{ $description "Prepares to generate machine code for a word." } ;
HELP: generate-1
{ $values { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
{ $values { "word" word } { "label" word } { "node" "a dataflow node" } { "quot" "a quotation with stack effect " { $snippet "( node -- )" } } }
{ $description "Generates machine code for " { $snippet "label" } " by applying the quotation to the dataflow node." } ;
HELP: generate-node

View File

@ -4,7 +4,7 @@ generic.math ;
HELP: math-upgrade
{ $values { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation with stack effect " { $snippet "( n n -- n n )" } } }
{ $description "Outputs a quotation for upgrading numberical types. It takes two numbers on the stack, an instance of " { $snippet "class1" } ", and an instance of " { $snippet "class2" } ", and converts the one with the lower priority to the higher priority type." }
{ $examples { $example "USE: generic.math" "fixnum bignum math-upgrade ." "[ >r >bignum r> ]" } } ;
{ $examples { $example "USE: generic.math" "fixnum bignum math-upgrade ." "[ [ >bignum ] dip ]" } } ;
HELP: no-math-method
{ $values { "left" "an object" } { "right" "an object" } { "generic" "a generic word" } }
@ -14,7 +14,7 @@ HELP: no-math-method
HELP: math-method
{ $values { "word" "a generic word" } { "class1" "a class word" } { "class2" "a class word" } { "quot" "a quotation" } }
{ $description "Generates a definition for " { $snippet "word" } " when the two inputs are instances of " { $snippet "class1" } " and " { $snippet "class2" } ", respectively." }
{ $examples { $example "USE: generic.math" "\\ + fixnum float math-method ." "[ >r >float r> float+ ]" } } ;
{ $examples { $example "USE: generic.math" "\\ + fixnum float math-method ." "[ [ >float ] dip float+ ]" } } ;
HELP: math-class
{ $class-description "The class of subtypes of " { $link number } " which are not " { $link null } "." } ;

View File

@ -96,7 +96,7 @@ HELP: hash-deleted+
{ $side-effects "hash" } ;
HELP: (set-hash)
{ $values { "value" "a value" } { "key" "a key to add" } { "hash" hashtable } }
{ $values { "value" "a value" } { "key" "a key to add" } { "hash" hashtable } { "new?" "a boolean" } }
{ $description "Stores the key/value pair into the hashtable. This word does not grow the hashtable if it exceeds capacity, therefore a hang can result. User code should use " { $link set-at } " instead, which grows the hashtable if necessary." }
{ $side-effects "hash" } ;

View File

@ -104,7 +104,7 @@ HELP: file-modified
HELP: parent-directory
{ $values { "path" "a pathname string" } { "parent" "a pathname string" } }
{ $description "Strips the last component off a pathname." }
{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc" } } ;
{ $examples { $example "USE: io.files" "\"/etc/passwd\" parent-directory print" "/etc/" } } ;
HELP: file-name
{ $values { "path" "a pathname string" } { "string" string } }

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
IN: io.files
USING: io.backend io.files.private io hashtables kernel math
memory namespaces sequences strings arrays definitions system
combinators splitting ;
memory namespaces sequences strings assocs arrays definitions
system combinators splitting ;
HOOK: <file-reader> io-backend ( path -- stream )
@ -126,3 +126,34 @@ TUPLE: pathname string ;
C: <pathname> pathname
M: pathname <=> [ pathname-string ] compare ;
HOOK: library-roots io-backend ( -- seq )
HOOK: binary-roots io-backend ( -- seq )
: find-file ( seq str -- path/f )
[
[ path+ exists? ] curry find nip
] keep over [ path+ ] [ drop ] if ;
: find-library ( str -- path/f )
library-roots swap find-file ;
: find-binary ( str -- path/f )
binary-roots swap find-file ;
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] curry* map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [
get-paths dup % [ (walk-dir) ] each
] [
drop
] if ;
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;

View File

@ -134,12 +134,13 @@ $nl
$io-error ;
HELP: make-block-stream
{ $values { "quot" "a quotation" } { "style" "a hashtable" } { "stream" "an output stream" } }
{ $contract "Calls the quotation in a new dynamic scope with the " { $link stdio } " stream rebound to a nested paragraph stream, with formatting information applied."
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-span-stream } ", this creates a new paragraph block in the output."
$nl
"The " { $snippet "style" } " hashtable holds paragraph style information. See " { $link "paragraph-styles" } "." }
{ $notes "Instead of calling this word directly, use " { $link with-nesting } "." }
$io-error ;
HELP: stream-write-table
@ -151,16 +152,17 @@ $nl
$io-error ;
HELP: make-cell-stream
{ $values { "quot" quotation } { "style" hashtable } { "stream" "an output stream" } { "table-cell" object } }
{ $contract "Creates a table cell by calling the quotation in a new scope with a rebound " { $link stdio } " stream. Callers should not make any assumptions about the type of this word's output value; it should be treated like an opaque handle passed to " { $link stream-write-table } "." }
{ $values { "style" hashtable } { "stream" "an output stream" } { "stream'" object } }
{ $contract "Creates an output stream which writes to a table cell object." }
{ $notes "Instead of calling this word directly, use " { $link tabular-output } "." }
$io-error ;
HELP: make-span-stream
{ $values { "style" "a hashtable" } { "quot" "a quotation" } { "stream" "an output stream" } }
{ $contract "Calls the quotation in a new dynamic scope where calls to " { $link write } ", " { $link format } " and other stream output words automatically inherit style settings from " { $snippet "style" } "."
{ $values { "style" "a hashtable" } { "stream" "an output stream" } { "stream'" "an output stream" } }
{ $contract "Creates an output stream which wraps " { $snippet "stream" } " and adds " { $snippet "style" } " on calls to " { $link stream-write } " and " { $link stream-format } "."
$nl
"Unlike " { $link make-block-stream } ", the quotation's output is inline, and not nested in a paragraph block." }
"Unlike " { $link make-block-stream } ", the stream output is inline, and not nested in a paragraph block." }
{ $notes "Instead of calling this word directly, use " { $link with-style } "." }
$io-error ;
HELP: stream-print

View File

@ -32,7 +32,7 @@ $nl
{ $subsection >r }
{ $subsection r> }
"The top of the data stack is ``hidden'' between " { $link >r } " and " { $link r> } ":"
{ $example "1 2 3 >r .s r>" "2\n1" }
{ $example "1 2 3 >r .s r>" "1\n2" }
"Words must not leave objects on the retain stack, nor expect values to be there on entry. The retain stack is for local storage within a word only, and occurrences of " { $link >r } " and " { $link r> } " must be balanced inside a single quotation. One exception is the following trick involving " { $link if } "; values may be pushed on the retain stack before the condition value is computed, as long as both branches of the " { $link if } " pop the values off the retain stack before returning:"
{ $code
": foo ( m ? n -- m+n/n )"
@ -542,7 +542,7 @@ HELP: 3compose
} ;
HELP: while
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "quot" "a quotation" } { "tail" "a quotation" } }
{ $values { "pred" "a quotation with stack effect " { $snippet "( -- ? )" } } { "body" "a quotation" } { "tail" "a quotation" } }
{ $description "Repeatedly calls " { $snippet "pred" } ". If it yields " { $link f } ", iteration stops, otherwise " { $snippet "quot" } " is called. After iteration stops, " { $snippet "tail" } " is called." }
{ $notes "In most cases, tail recursion should be used, because it is simpler both in terms of implementation and conceptually. However in some cases this combinator expresses intent better and should be used."
$nl

View File

@ -3,7 +3,7 @@
USING: kernel.private ;
IN: kernel
: version ( -- str ) "0.91" ; foldable
: version ( -- str ) "0.92" ; foldable
! Stack stuff
: roll ( x y z t -- y z t x ) >r rot r> swap ; inline

View File

@ -25,7 +25,7 @@ HELP: memcpy
{ $warning "As per the BSD C library documentation, the behavior is undefined if the source and destination overlap." } ;
HELP: check-ptr
{ $values { "c-ptr" "an alien address, byte array, or " { $link f } } { "checked" "an alien address or byte array with non-zero address" } }
{ $values { "c-ptr" "an alien address, byte array, or " { $link f } } }
{ $description "Throws an error if the input is " { $link f } ". Otherwise the object remains on the data stack." } ;
HELP: free

View File

@ -222,12 +222,12 @@ $nl
HELP: bit?
{ $values { "x" integer } { "n" integer } { "?" "a boolean" } }
{ $description "Tests if the " { $snippet "n" } "th bit of " { $snippet "x" } " is set." }
{ $examples { $example "BIN: 101 3 bit? ." "t" } } ;
{ $examples { $example "BIN: 101 2 bit? ." "t" } } ;
HELP: log2
{ $values { "n" "a positive integer" } { "b" integer } }
{ $description "Outputs the largest integer " { $snippet "b" } " such that " { $snippet "2^b" } " is less than " { $snippet "n" } "." }
{ $errors "Throws an error if " { $snippet "n" } " is zero or negative." } ;
{ $values { "x" "a positive integer" } { "n" integer } }
{ $description "Outputs the largest integer " { $snippet "n" } " such that " { $snippet "2^n" } " is less than " { $snippet "x" } "." }
{ $errors "Throws an error if " { $snippet "x" } " is zero or negative." } ;
HELP: 1+
{ $values { "x" number } { "y" number } }
@ -344,7 +344,7 @@ HELP: each-integer
{ $notes "This word is used to implement " { $link each } "." } ;
HELP: all-integers?
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "i" "an integer or " { $link f } } }
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( i -- ? )" } } { "?" "a boolean" } }
{ $description "Applies the quotation to each integer from 0 up to " { $snippet "n" } ", excluding " { $snippet "n" } ". Iterationi stops when the quotation outputs " { $link f } " or the end is reached. If the quotation yields a false value for some integer, this word outputs " { $link f } ". Otherwise, this word outputs " { $link t } "." }
{ $notes "This word is used to implement " { $link all? } "." } ;

View File

@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
io.streams.string layouts splitting math.intervals
math.floats.private tuples tuples.private classes
optimizer.def-use optimizer.backend optimizer.pattern-match
float-arrays combinators.private ;
float-arrays combinators.private combinators ;
! the output of <tuple> and <tuple-boa> has the class which is
! its second-to-last input
@ -50,6 +50,20 @@ float-arrays combinators.private ;
{ [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
} define-optimizers
: literal-member? ( #call -- ? )
node-in-d peek dup value?
[ value-literal sequence? ] [ drop f ] if ;
: member-quot ( seq -- newquot )
[ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
: expand-member ( #call -- )
dup node-in-d peek value-literal member-quot splice-quot ;
\ member? {
{ [ dup literal-member? ] [ expand-member ] }
} define-optimizers
! if the result of eq? is t and the second input is a literal,
! the first input is equal to the second
\ eq? [

View File

@ -111,7 +111,7 @@ optimizer.def-use generic.standard ;
: post-process ( class interval node -- classes intervals )
dupd won't-overflow?
[ >r dup { f integer } memq? [ drop fixnum ] when r> ] when
[ >r dup { f integer } member? [ drop fixnum ] when r> ] when
[ dup [ 1array ] when ] 2apply ;
: math-output-interval-1 ( node word -- interval )

View File

@ -31,7 +31,7 @@ HELP: do-string-limit
{ $description "If " { $link string-limit } " is on, trims the string such that it does not exceed the margin, appending \"...\" if trimming took place." } ;
HELP: pprint-string
{ $values { "obj" object } { "str" string } { "prefix" "a prefix string" } }
{ $values { "obj" object } { "str" string } { "prefix" string } { "suffix" string } }
{ $description "Outputs a text section consisting of the prefix, the string, and a final quote (\")." }
$prettyprinting-note ;

View File

@ -89,19 +89,20 @@ M: f pprint* drop \ f pprint-word ;
{ 0.3 0.3 0.3 1.0 } foreground set
] H{ } make-assoc ;
: unparse-string ( str prefix -- str )
[
% do-string-limit [ unparse-ch ] each CHAR: " ,
] "" make ;
: unparse-string ( str prefix suffix -- str )
[ >r % do-string-limit [ unparse-ch ] each r> % ] "" make ;
: pprint-string ( obj str prefix -- )
: pprint-string ( obj str prefix suffix -- )
unparse-string swap string-style styled-text ;
M: string pprint* dup "\"" pprint-string ;
M: string pprint*
dup "\"" "\"" pprint-string ;
M: sbuf pprint* dup "SBUF\" " pprint-string ;
M: sbuf pprint*
dup "SBUF\" " "\"" pprint-string ;
M: pathname pprint* dup pathname-string "P\" " pprint-string ;
M: pathname pprint*
dup pathname-string "P\" " "\"" pprint-string ;
! Sequences
: nesting-limit? ( -- ? )

View File

@ -221,7 +221,8 @@ TUPLE: column seq col ;
C: <column> column
M: column virtual-seq column-seq ;
M: column virtual@ dup column-col -rot column-seq nth ;
M: column virtual@
dup column-col -rot column-seq nth bounds-check ;
M: column length column-seq length ;
INSTANCE: column virtual-sequence
@ -546,11 +547,6 @@ M: sequence <=>
: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
: flip ( matrix -- newmatrix )
dup empty? [
dup first length [ <column> dup like ] curry* map
] unless ;
: exchange ( m n seq -- )
pick over bounds-check 2drop 2dup bounds-check 2drop
exchange-unsafe ;
@ -667,7 +663,19 @@ PRIVATE>
: infimum ( seq -- n ) dup first [ min ] reduce ;
: supremum ( seq -- n ) dup first [ max ] reduce ;
: flip ( matrix -- newmatrix )
dup empty? [
dup [ length ] map infimum
[ <column> dup like ] curry* map
] unless ;
: sequence-hashcode-step ( oldhash newpart -- newhash )
swap [
dup -2 fixnum-shift >fixnum swap 5 fixnum-shift >fixnum
fixnum+fast fixnum+fast
] keep bitxor ; inline
: sequence-hashcode ( n seq -- x )
0 -rot [
hashcode* >fixnum swap 31 fixnum*fast fixnum+fast
hashcode* >fixnum sequence-hashcode-step
] curry* each ; inline

View File

@ -9,7 +9,6 @@ ARTICLE: "slots" "Slots"
$nl
{ $link "tuples" } " are composed entirely of slots, and instances of " { $link "builtin-classes" } " consist of slots together with intrinsic data."
$nl
"The "
"The " { $snippet "\"slots\"" } " word property of built-in and tuple classes holds an array of " { $emphasis "slot specifiers" } " describing the slot layout of each instance."
{ $subsection slot-spec }
"Each slot has a reader word; mutable slots have an optional writer word. All tuple slots are mutable, but some slots on built-in classes are not."

1
extra/bake/authors.txt Normal file
View File

@ -0,0 +1 @@
Eduardo Cavazos

1
extra/bake/summary.txt Normal file
View File

@ -0,0 +1 @@
Bake is similar to make but with additional features

View File

@ -26,6 +26,8 @@ HINTS: do-trans-map string ;
over push
] if ;
HINTS: do-line vector string ;
: (reverse-complement) ( seq -- )
readln [ do-line (reverse-complement) ] [ show-seq ] if* ;

1
extra/cabal/authors.txt Normal file
View File

@ -0,0 +1 @@
Eduardo Cavazos

1
extra/cabal/summary.txt Normal file
View File

@ -0,0 +1 @@
Minimalist chat server

View File

@ -0,0 +1,2 @@
Matthew Willis
Eduardo Cavazos

View File

@ -0,0 +1 @@
Connects to a cabal server

View File

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables io io.streams.string kernel math
math.vectors math.functions math.parser
namespaces sequences strings tuples system ;
math.vectors math.functions math.parser namespaces sequences
strings tuples system debugger ;
IN: calendar
TUPLE: timestamp year month day hour minute second gmt-offset ;
@ -316,7 +316,28 @@ M: timestamp <=> ( ts1 ts2 -- n )
: timestamp>rfc3339 ( timestamp -- str )
>gmt [
(timestamp>rfc3339)
] string-out ;
] string-out ;
: expect read1 assert= ;
: (rfc3339>timestamp) ( -- timestamp )
4 read string>number ! year
CHAR: - expect
2 read string>number ! month
CHAR: - expect
2 read string>number ! day
CHAR: T expect
2 read string>number ! hour
CHAR: : expect
2 read string>number ! minute
CHAR: : expect
2 read string>number ! second
0 <timestamp> ;
: rfc3339>timestamp ( str -- timestamp )
[
(rfc3339>timestamp)
] string-in ;
: file-time-string ( timestamp -- string )
[

1
extra/cfdg/summary.txt Normal file
View File

@ -0,0 +1 @@
Implementation of: http://contextfreeart.org

View File

@ -13,7 +13,7 @@ HELP: <remote-channel>
"returned by " { $link publish }
}
{ $examples
{ $example "\"localhost\" 9000 <node> \"ID123456\" <remote-channel> \"foo\" over to" }
{ $code "\"localhost\" 9000 <node> \"ID123456\" <remote-channel> \"foo\" over to" }
}
{ $see-also publish unpublish } ;
@ -24,7 +24,7 @@ HELP: unpublish
"accessible by remote nodes."
}
{ $examples
{ $example "<channel> publish unpublish" }
{ $code "<channel> publish unpublish" }
}
{ $see-also <remote-channel> publish } ;
@ -37,7 +37,7 @@ HELP: publish
{ $link to } " and " { $link from } " to access the channel."
}
{ $examples
{ $example "<channel> publish" }
{ $code "<channel> publish" }
}
{ $see-also <remote-channel> unpublish } ;

View File

@ -1,8 +1,9 @@
USING: help.syntax help.markup kernel prettyprint sequences ;
USING: help.syntax help.markup kernel prettyprint sequences
quotations math ;
IN: combinators.lib
HELP: generate
{ $values { "generator" "a quotation" } { "predicate" "a quotation" } { "obj" "an object" } }
{ $values { "generator" quotation } { "predicate" quotation } { "obj" object } }
{ $description "Loop until the generator quotation generates an object that satisfies predicate quotation." }
{ $unchecked-example
"! Generate a random 20-bit prime number congruent to 3 (mod 4)"
@ -12,7 +13,7 @@ HELP: generate
} ;
HELP: ndip
{ $values { "quot" "a quotation" } { "n" "a number" } }
{ $values { "quot" quotation } { "n" number } }
{ $description "A generalisation of " { $link dip } " that can work "
"for any stack depth. The quotation will be called with a stack that "
"has 'n' items removed first. The 'n' items are then put back on the "
@ -25,7 +26,7 @@ HELP: ndip
{ $see-also dip dipd } ;
HELP: nslip
{ $values { "n" "a number" } }
{ $values { "n" number } }
{ $description "A generalisation of " { $link slip } " that can work "
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
"removed from the stack, the quotation called, and the items restored."
@ -36,7 +37,7 @@ HELP: nslip
{ $see-also slip nkeep } ;
HELP: nkeep
{ $values { "quot" "a quotation" } { "n" "a number" } }
{ $values { "quot" quotation } { "n" number } }
{ $description "A generalisation of " { $link keep } " that can work "
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
"saved, the quotation called, and the items restored."
@ -47,7 +48,7 @@ HELP: nkeep
{ $see-also keep nslip } ;
HELP: map-withn
{ $values { "seq" "a sequence" } { "quot" "a quotation" } { "n" "a number" } { "newseq" "a sequence" } }
{ $values { "seq" sequence } { "quot" quotation } { "n" number } { "newseq" sequence } }
{ $description "A generalisation of " { $link map } ". The first " { $snippet "n" } " items after the quotation will be "
"passed to the quotation given to map-withn for each element in the sequence."
}
@ -57,43 +58,44 @@ HELP: map-withn
{ $see-also each-withn } ;
HELP: each-withn
{ $values { "seq" "a sequence" } { "quot" "a quotation" } { "n" "a number" } }
{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
{ $description "A generalisation of " { $link each } ". The first " { $snippet "n" } " items after the quotation will be "
"passed to the quotation given to each-withn for each element in the sequence."
}
{ $see-also map-withn } ;
HELP: sigma
{ $values { "seq" "a sequence" } { "quot" "a quotation" } }
{ $values { "seq" sequence } { "quot" quotation } { "n" number } }
{ $description "Like map sum, but without creating an intermediate sequence." }
{ $example
"! Find the sum of the squares [0,99]"
"USE: math.ranges"
"100 [1,b] [ sq ] sigma"
"USING: math.ranges combinators.lib ;"
"100 [1,b] [ sq ] sigma ."
"338350"
} ;
HELP: count
{ $values { "seq" "a sequence" } { "quot" "a quotation" } }
{ $values { "seq" sequence } { "quot" quotation } { "n" integer } }
{ $description "Efficiently returns the number of elements that the predicate quotation matches." }
{ $example
"USE: math.ranges"
"USING: math.ranges combinators.lib ;"
"100 [1,b] [ even? ] count ."
"50"
} ;
HELP: all-unique?
{ $values { "seq" "a sequence" } { "?" "a boolean" } }
{ $values { "seq" sequence } { "?" "a boolean" } }
{ $description "Tests whether a sequence contains any repeated elements." }
{ $example
"USE: combinators.lib"
"{ 0 1 1 2 3 5 } all-unique? ."
"f"
} ;
HELP: &&
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } }
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
{ $description "Calls each quotation in turn; outputs " { $link f } " if one of the quotations output " { $link f } ", otherwise outputs " { $link t } ". As soon as a quotation outputs " { $link f } ", evaluation stops and subsequent quotations are not called." } ;
HELP: ||
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } }
{ $values { "quots" "a sequence of quotations with stack effect " { $snippet "( ... -- ... ? )" } } { "?" "a boolean" } }
{ $description "Calls each quotation in turn; outputs " { $link t } " if one of the quotations output " { $link t } ", otherwise outputs " { $link f } ". As soon as a quotation outputs " { $link t } ", evaluation stops and subsequent quotations are not called." } ;

View File

@ -58,3 +58,5 @@ IN: temporary
[ dup array? ] [ dup vector? ] [ dup float? ]
} || nip
] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test

View File

@ -67,6 +67,9 @@ MACRO: napply ( n -- )
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
MACRO: nfirst ( n -- )
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ;

View File

@ -25,9 +25,8 @@ HELP: mailbox-put
HELP: (mailbox-block-unless-pred)
{ $values { "pred" "a quotation with stack effect " { $snippet "( X -- bool )" } }
{ "mailbox" "a mailbox object" }
{ "pred2" "same object as 'pred'" }
{ "mailbox2" "same object as 'mailbox'" }
{ "mailbox" "a mailbox object" }
{ "timeout" "a timeout in milliseconds" }
}
{ $description "Block the thread if there are no items in the mailbox that return true when the predicate is called with the item on the stack. The predicate must have stack effect " { $snippet "( X -- bool )" } "." }
{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;
@ -35,6 +34,7 @@ HELP: (mailbox-block-unless-pred)
HELP: (mailbox-block-if-empty)
{ $values { "mailbox" "a mailbox object" }
{ "mailbox2" "same object as 'mailbox'" }
{ "timeout" "a timeout in milliseconds" }
}
{ $description "Block the thread if the mailbox is empty." }
{ $see-also make-mailbox mailbox-empty? mailbox-put mailbox-get mailbox-get-all while-mailbox-empty mailbox-get? } ;

View File

@ -13,8 +13,8 @@ HELP: bitroll
{ $values { "x" "an integer (input)" } { "s" "an integer (shift)" } { "w" "an integer (wrap)" } { "y" "an integer" } }
{ $description "Roll n by s bits to the left, wrapping around after w bits." }
{ $examples
{ $example "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
{ $example "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
{ $example "USE: crypto.common" "1 -1 32 bitroll .b" "10000000000000000000000000000000" }
{ $example "USE: crypto.common" "HEX: ffff0000 8 32 bitroll .h" "ff0000ff" }
} ;
@ -22,7 +22,7 @@ HELP: hex-string
{ $values { "seq" "a sequence" } { "str" "a string" } }
{ $description "Converts a sequence of values from 0-255 to a string of hex numbers from 0-ff." }
{ $examples
{ $example "B{ 1 2 3 4 } hex-string print" "01020304" }
{ $example "USE: crypto.common" "B{ 1 2 3 4 } hex-string print" "01020304" }
}
{ $notes "Numbers are zero-padded on the left." } ;

View File

@ -65,8 +65,8 @@ PROTOCOL: prettyprint-section-protocol
: define-mimic ( group mimicker mimicked -- )
>r >r group-words r> r> [
pick "methods" word-prop at
[ method-def <method> spin define-method ] [ 3drop ] if*
pick "methods" word-prop at dup
[ method-def <method> spin define-method ] [ 3drop ] if
] 2curry each ;
: MIMIC:

View File

@ -195,11 +195,11 @@ TUPLE: one-word-elt ;
M: one-word-elt prev-elt
drop
[ [ f -rot >r 1- r> (prev-word) ] (word-elt) ] (prev-char) ;
[ f -rot >r 1- r> (prev-word) ] (word-elt) ;
M: one-word-elt next-elt
drop
[ [ f -rot (next-word) ] (word-elt) ] (next-char) ;
[ f -rot (next-word) ] (word-elt) ;
TUPLE: word-elt ;

View File

@ -1,8 +1,15 @@
USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher ;
namespaces editors io.launcher windows.shell32 io.files
io.paths strings ;
IN: editors.editpadpro
: editpadpro-path
\ editpadpro-path get-global [
program-files "JGsoft" path+ walk-dir
[ >lower "editpadpro.exe" tail? ] find nip
] unless* ;
: editpadpro ( file line -- )
[ "editpadpro.exe /l" % # " \"" % % "\"" % ] "" make run-process ;
[ editpadpro-path % " /l" % # " \"" % % "\"" % ] "" make run-detached ;
[ editpadpro ] edit-hook set-global

View File

@ -0,0 +1 @@
Aaron Schaefer

View File

@ -0,0 +1,15 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
program-files "\\EditPlus 2\\editplus.exe" append
] unless* ;
: editplus ( file line -- )
[
editplus-path % " -cursor " % # " " % %
] "" make run-detached ;
[ editplus ] edit-hook set-global

View File

@ -0,0 +1 @@
EditPlus editor integration

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,16 @@
USING: editors hardware-info.windows io.files io.launcher
kernel math.parser namespaces sequences windows.shell32 ;
IN: editors.emeditor
: emeditor-path ( -- path )
\ emeditor-path get-global [
program-files "\\EmEditor\\EmEditor.exe" path+
] unless* ;
: emeditor ( file line -- )
[
emeditor-path % " /l " % #
" " % "\"" % % "\"" %
] "" make run-detached ;
[ emeditor ] edit-hook set-global

View File

@ -0,0 +1 @@
EmEditor integration

View File

@ -1,10 +1,18 @@
USING: kernel math math.parser namespaces editors.vim ;
USING: io.backend io.files kernel math math.parser
namespaces editors.vim sequences system ;
IN: editors.gvim
TUPLE: gvim ;
HOOK: gvim-path io-backend ( -- path )
M: gvim vim-command ( file line -- string )
[ "\"" % vim-path get % "\" \"" % swap % "\" +" % # ] "" make ;
[ "\"" % gvim-path % "\" \"" % swap % "\" +" % # ] "" make ;
t vim-detach set-global ! don't block the ui
T{ gvim } vim-editor set-global
"gvim" vim-path set-global
USE-IF: unix? editors.gvim.unix
USE-IF: windows? editors.gvim.windows

View File

@ -0,0 +1,7 @@
USING: editors.gvim io.unix.backend kernel namespaces ;
IN: editors.gvim.unix
M: unix-io gvim-path
\ gvim-path get-global [
"gvim"
] unless* ;

View File

@ -0,0 +1,8 @@
USING: editors.gvim io.files io.windows kernel namespaces
sequences windows.shell32 ;
IN: editors.gvim.windows
M: windows-io gvim-path
\ gvim-path get-global [
program-files walk-dir [ "gvim.exe" tail? ] find nip
] unless* ;

View File

@ -1,13 +1,15 @@
USING: editors io.launcher math.parser namespaces ;
USING: editors io.files io.launcher kernel math.parser
namespaces windows.shell32 ;
IN: editors.notepadpp
: notepadpp-path
\ notepadpp-path get-global [
program-files "notepad++\\notepad++.exe" path+
] unless* ;
: notepadpp ( file line -- )
[
\ notepadpp get-global % " -n" % # " " % %
notepadpp-path % " -n" % # " " % %
] "" make run-detached ;
! Put in your .factor-boot-rc
! "c:\\Program Files\\notepad++\\notepad++.exe" \ notepadpp set-global
! "k:\\Program Files (x86)\\notepad++\\notepad++.exe" \ notepadpp set-global
[ notepadpp ] edit-hook set-global

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1 @@
TED Notepad integration

View File

@ -0,0 +1,16 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
IN: editors.ted-notepad
: ted-notepad-path
\ ted-notepad-path get-global [
program-files "\\TED Notepad\\TedNPad.exe" path+
] unless* ;
: ted-notepad ( file line -- )
[
ted-notepad-path % " /l" % #
" " % %
] "" make run-detached ;
[ ted-notepad ] edit-hook set-global

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1 @@
UltraEdit editor integration

View File

@ -0,0 +1,17 @@
USING: editors io.files io.launcher kernel math.parser
namespaces sequences windows.shell32 ;
IN: editors.ultraedit
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
program-files
"\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" path+
] unless* ;
: ultraedit ( file line -- )
[
ultraedit-path % " " % swap % "/" % # "/1" %
] "" make run-detached ;
[ ultraedit ] edit-hook set-global

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1 @@
Wordpad editor integration

View File

@ -0,0 +1,15 @@
USING: editors hardware-info.windows io.launcher kernel
math.parser namespaces sequences windows.shell32 ;
IN: editors.wordpad
: wordpad-path ( -- path )
\ wordpad-path get [
program-files "\\Windows NT\\Accessories\\wordpad.exe" append
] unless* ;
: wordpad ( file line -- )
[
wordpad-path % drop " " % "\"" % % "\"" %
] "" make run-detached ;
[ wordpad ] edit-hook set-global

114
extra/faq/faq.factor Normal file
View File

@ -0,0 +1,114 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: xml kernel sequences xml.utilities combinators.lib
math xml.data arrays assocs xml.generator xml.writer namespaces
math.parser io ;
IN: faq
: find-after ( seq quot -- elem after )
over >r find r> rot 1+ tail ; inline
: tag-named*? ( tag name -- ? )
assure-name swap tag-named? ;
! Questions
TUPLE: q/a question answer ;
C: <q/a> q/a
: li>q/a ( li -- q/a )
[ "br" tag-named*? not ] subset
[ "strong" tag-named*? ] find-after
>r tag-children r> <q/a> ;
: q/a>li ( q/a -- li )
[ q/a-question "strong" build-tag* f "br" build-tag* 2array ] keep
q/a-answer append "li" build-tag* ;
: xml>q/a ( xml -- q/a )
[ "question" tag-named tag-children ] keep
"answer" tag-named tag-children <q/a> ;
: q/a>xml ( q/a -- xml )
[ q/a-question "question" build-tag* ] keep
q/a-answer "answer" build-tag*
"\n" swap 3array "qa" build-tag* ;
! Lists of questions
TUPLE: question-list title seq ;
C: <question-list> question-list
: xml>question-list ( list -- question-list )
[ "title" swap at ] keep
tag-children [ tag? ] subset [ xml>q/a ] map
<question-list> ;
: question-list>xml ( question-list -- list )
[ question-list-seq [ q/a>xml "\n" swap 2array ]
map concat "list" build-tag* ] keep
question-list-title [ "title" pick set-at ] when* ;
: html>question-list ( h3 ol -- question-list )
>r [ children>string ] [ f ] if* r>
children-tags [ li>q/a ] map <question-list> ;
: question-list>h3 ( id question-list -- h3 )
question-list-title [
"h3" build-tag
swap number>string "id" pick set-at
] [ drop f ] if* ;
: question-list>html ( question-list start id -- h3/f ol )
-rot >r [ question-list>h3 ] keep
question-list-seq [ q/a>li ] map "ol" build-tag* r>
number>string "start" pick set-at
"margin-left: 5em" "style" pick set-at ;
! Overall everything
TUPLE: faq header lists ;
C: <faq> faq
: html>faq ( div -- faq )
unclip swap { "h3" "ol" } [ tags-named ] curry* map
first2 >r f add* r> [ html>question-list ] 2map <faq> ;
: header, ( faq -- )
dup faq-header ,
faq-lists first 1 -1 question-list>html nip , ;
: br, ( -- )
"br" contained, nl, ;
: toc-link, ( question-list number -- )
number>string "#" swap append "href" swap 2array 1array
"a" swap [ question-list-title , ] tag*, br, ;
: toc, ( faq -- )
"div" { { "style" "background-color: #eee; margin-left: 30%; margin-right: 30%; width: auto; padding: 5px; margin-top: 1em; margin-bottom: 1em" } } [
"strong" [ "The big questions" , ] tag, br,
faq-lists 1 tail dup length [ toc-link, ] 2each
] tag*, ;
: faq-sections, ( question-lists -- )
unclip question-list-seq length 1+ dupd
[ question-list-seq length + ] accumulate nip
0 -rot [ pick question-list>html [ , nl, ] 2apply 1+ ] 2each drop ;
: faq>html ( faq -- div )
"div" [
dup header,
dup toc,
faq-lists faq-sections,
] make-xml ;
: xml>faq ( xml -- faq )
[ "header" tag-named children>string ] keep
"list" tags-named [ xml>question-list ] map <faq> ;
: faq>xml ( faq -- xml )
"faq" [
"header" [ dup faq-header , ] tag,
faq-lists [ question-list>xml , nl, ] each
] make-xml ;
: read-write-faq ( xml-stream -- )
read-xml xml>faq faq>html write-xml ;

View File

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

View File

@ -28,7 +28,7 @@ TUPLE: test-tuple m n ;
[
H{
{ "bar" "hello" }
} \ foo query>quot
} \ foo query>seq
] with-scope
] unit-test

View File

@ -1,48 +1,39 @@
! Copyright (C) 2006 Slava Pestov
! Copyright (C) 2006 Slava Pestov, Doug Coleman
! See http://factorcode.org/license.txt for BSD license.
USING: kernel vectors io assocs quotations splitting strings
words sequences namespaces arrays hashtables debugger
continuations tuples classes io.files
http http.server.templating http.basic-authentication
webapps.callback html html.elements
http.server.responders furnace.validator ;
USING: arrays assocs debugger furnace.sessions furnace.validator
hashtables html.elements http http.server.responders
http.server.templating
io.files kernel namespaces quotations sequences splitting words
strings vectors webapps.callback ;
USING: continuations io prettyprint ;
IN: furnace
SYMBOL: default-action
: code>quotation ( word/quot -- quot )
dup word? [ 1quotation ] when ;
SYMBOL: default-action
SYMBOL: template-path
: define-authenticated-action ( word params realm -- )
pick swap "action-realm" set-word-prop
: render-template ( template -- )
template-path get swap path+
".furnace" append resource-path
run-template-file ;
: define-action ( word hash -- )
over t "action" set-word-prop
"action-params" set-word-prop ;
: define-action ( word params -- )
f define-authenticated-action ;
: define-form ( word1 word2 hash -- )
dupd define-action
swap code>quotation "form-failed" set-word-prop ;
: define-redirect ( word quot -- )
"action-redirect" set-word-prop ;
: default-values ( word hash -- )
"default-values" set-word-prop ;
: responder-vocab ( name -- vocab )
"webapps." swap append ;
: lookup-action ( name webapp -- word )
responder-vocab lookup dup [
dup "action" word-prop [ drop f ] unless
] when ;
: truncate-url ( url -- action-name )
CHAR: / over index [ head ] when* ;
: current-action ( url -- word/f )
dup empty? [ drop default-action get ] when
truncate-url "responder" get lookup-action ;
PREDICATE: word action "action" word-prop ;
: quot>query ( seq action -- hash )
>r >array r> "action-params" word-prop
[ first swap 2array ] 2map >hashtable ;
SYMBOL: request-params
SYMBOL: current-action
SYMBOL: validators-errored
SYMBOL: validation-errors
: action-link ( query action -- url )
[
@ -52,6 +43,34 @@ PREDICATE: word action "action" word-prop ;
word-name %
] "" make swap build-url ;
: action-param ( hash paramsepc -- obj error/f )
unclip rot at swap >quotation apply-validators ;
: query>seq ( hash word -- seq )
"action-params" word-prop [
dup first -rot
action-param [
t validators-errored >session
rot validation-errors session> set-at
] [
nip
] if*
] curry* map ;
: lookup-session ( hash -- session )
"furnace-session-id" over at* [
sessions get-global at
[ nip ] [ "furnace-session-id" over delete-at lookup-session ] if*
] [
drop new-session rot "furnace-session-id" swap set-at
] if ;
: quot>query ( seq action -- hash )
>r >array r> "action-params" word-prop
[ first swap 2array ] 2map >hashtable ;
PREDICATE: word action "action" word-prop ;
: action-call? ( quot -- ? )
>vector dup pop action? >r [ word? not ] all? r> and ;
@ -64,80 +83,130 @@ PREDICATE: word action "action" word-prop ;
t register-html-callback
] if ;
: render-link ( quot name -- )
<a swap quot-link =href a> write </a> ;
: replace-variables ( quot -- quot )
[ dup string? [ request-params session> at ] when ] map ;
: action-param ( params paramspec -- obj error/f )
unclip rot at swap >quotation apply-validators ;
: furnace-session-id ( -- hash )
"furnace-session-id" request-params session> at
"furnace-session-id" associate ;
: query>quot ( params action -- seq )
"action-params" word-prop [ action-param drop ] curry* map ;
: redirect-to-action ( -- )
current-action session>
"form-failed" word-prop replace-variables
quot-link furnace-session-id build-url permanent-redirect ;
SYMBOL: request-params
: if-form-page ( if then -- )
current-action session> "form-failed" word-prop -rot if ;
: perform-redirect ( action -- )
"action-redirect" word-prop
[ dup string? [ request-params get at ] when ] map
[ quot-link permanent-redirect ] when* ;
: do-action
current-action session> [ query>seq ] keep add >quotation call ;
: (call-action) ( params action -- )
over request-params set
[ query>quot ] keep [ add >quotation call ] keep
perform-redirect ;
: process-form ( -- )
H{ } clone validation-errors >session
request-params session> current-action session> query>seq
validators-errored session> [
drop redirect-to-action
] [
current-action session> add >quotation call
] if ;
: call-action ( params action -- )
dup "action-realm" word-prop [
[ (call-action) ] with-basic-authentication
] [ (call-action) ] if* ;
: page-submitted ( -- )
[ process-form ] [ request-params session> do-action ] if-form-page ;
: service-request ( params url -- )
current-action [
: action-first-time ( -- )
request-params session> current-action session>
[ "default-values" word-prop swap union request-params >session ] keep
request-params session> do-action ;
: page-not-submitted ( -- )
[ redirect-to-action ] [ action-first-time ] if-form-page ;
: setup-call-action ( hash word -- )
over lookup-session session set
current-action >session
request-params session> swap union
request-params >session
f validators-errored >session ;
: call-action ( hash word -- )
setup-call-action
"furnace-form-submitted" request-params session> at
[ page-submitted ] [ page-not-submitted ] if ;
: responder-vocab ( str -- newstr )
"webapps." swap append ;
: lookup-action ( str webapp -- word )
responder-vocab lookup dup [
dup "action" word-prop [ drop f ] unless
] when ;
: truncate-url ( str -- newstr )
CHAR: / over index [ head ] when* ;
: parse-action ( str -- word/f )
dup empty? [ drop default-action get ] when
truncate-url "responder" get lookup-action ;
: service-request ( hash str -- )
parse-action [
[ call-action ] [ <pre> print-error </pre> ] recover
] [
"404 no such action: " "argument" get append httpd-error
] if* ;
: service-get ( url -- ) "query" get swap service-request ;
: service-get
"query" get swap service-request ;
: service-post ( url -- ) "response" get swap service-request ;
: service-post
"response" get swap service-request ;
: explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ;
SYMBOL: model
: call-template ( model template -- )
[
>r [ dup model set explode-tuple ] when* r>
".furnace" append resource-path run-template-file
] with-scope ;
: render-template ( model template -- )
template-path get swap path+ call-template ;
: render-page* ( model body-template head-template -- )
[
[ render-template ] [ f rot render-template ] html-document
] serve-html ;
: render-titled-page* ( model body-template head-template title -- )
[
[ render-template ] swap [ <title> write </title> f rot render-template ] curry html-document
] serve-html ;
: render-page ( model template title -- )
[
[ render-template ] simple-html-document
] serve-html ;
: web-app ( name default path -- )
: web-app ( name defaul path -- )
[
template-path set
default-action set
"responder" set
[ service-get ] "get" set
[ service-post ] "post" set
! [ service-head ] "head" set
] make-responder ;
USING: classes html tuples vocabs ;
: explode-tuple ( tuple -- )
dup tuple-slots swap class "slot-names" word-prop
[ set ] 2each ;
SYMBOL: model
: with-slots ( model quot -- )
[
>r [ dup model set explode-tuple ] when* r> call
] with-scope ;
: render-component ( model template -- )
swap [ render-template ] with-slots ;
: browse-webapp-source ( vocab -- )
<a f >vocab-link browser-link-href =href a>
"Browse source" write
</a> ;
: send-resource ( name -- )
template-path get swap path+ resource-path <file-reader>
stdio get stream-copy ;
: render-link ( quot name -- )
<a swap quot-link =href a> write </a> ;
: session-var ( str -- newstr )
request-params session> at ;
: render ( str -- )
request-params session> at [ write ] when* ;
: render-error ( str error-str -- )
swap validation-errors session> at validation-error? [
write
] [
drop
] if ;

View File

@ -0,0 +1,31 @@
USING: assocs calendar init kernel math.parser namespaces random ;
IN: furnace.sessions
SYMBOL: sessions
[ H{ } clone sessions set-global ] "furnace.sessions" add-init-hook
: new-session-id ( -- str )
1 big-random number>string ;
TUPLE: session created last-seen user-agent namespace ;
: <session> ( -- obj )
now dup H{ } clone
[ set-session-created set-session-last-seen set-session-namespace ]
\ session construct ;
: new-session ( -- obj id )
<session> new-session-id [ sessions get-global set-at ] 2keep ;
: get-session ( id -- obj/f )
sessions get-global at* [ "no session found 1" throw ] unless ;
: destroy-session ( id -- )
sessions get-global delete-at ;
: session> ( str -- obj )
session get session-namespace at ;
: >session ( value key -- )
session get session-namespace set-at ;

16
extra/globs/globs.factor Normal file → Executable file
View File

@ -1,22 +1,18 @@
! Copyright (C) 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser-combinators regexp lazy-lists sequences kernel
promises ;
promises strings ;
IN: globs
<PRIVATE
: 'char'
[ ",*?" member? not ] satisfy ;
: 'char' [ ",*?" member? not ] satisfy ;
: 'string'
'char' <+> [ token ] <@ ;
: 'string' 'char' <+> [ >lower token ] <@ ;
: 'escaped-char'
"\\" token any-char-parser &> [ 1token ] <@ ;
: 'escaped-char' "\\" token any-char-parser &> [ 1token ] <@ ;
: 'escaped-string'
'string' 'escaped-char' <|> ;
: 'escaped-string' 'string' 'escaped-char' <|> ;
DEFER: 'term'
@ -39,4 +35,4 @@ PRIVATE>
: <glob> 'glob' just parse-1 just ;
: glob-matches? ( input glob -- ? )
<glob> parse nil? not ;
>r >lower r> <glob> parse nil? not ;

View File

@ -1,7 +1,7 @@
USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 ;
USING: alien.c-types hardware-info hardware-info.windows
kernel math namespaces windows windows.kernel32 ;
IN: hardware-info.windows.ce
TUPLE: wince ;
T{ wince } os set-global
: memory-status ( -- MEMORYSTATUS )

View File

@ -1,8 +1,8 @@
USING: alien alien.c-types hardware-info kernel libc math namespaces
USING: alien alien.c-types hardware-info hardware-info.windows
kernel libc math namespaces
windows windows.advapi32 windows.kernel32 ;
IN: hardware-info.windows.nt
TUPLE: winnt ;
T{ winnt } os set-global
: memory-status ( -- MEMORYSTATUSEX )

View File

@ -1,5 +1,6 @@
USING: alien alien.c-types kernel libc math namespaces
windows windows.kernel32 windows.advapi32 hardware-info ;
windows windows.kernel32 windows.advapi32 hardware-info
words ;
IN: hardware-info.windows
TUPLE: wince ;
@ -53,6 +54,22 @@ M: windows cpus ( -- n )
: sse3? ( -- ? )
PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
: <u16-string-object> ( n -- obj )
"ushort" <c-array> ;
: get-directory ( word -- str )
>r MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd r>
execute win32-error=0/f alien>u16-string ; inline
: windows-directory ( -- str )
\ GetWindowsDirectory get-directory ;
: system-directory ( -- str )
\ GetSystemDirectory get-directory ;
: system-windows-directory ( -- str )
\ GetSystemWindowsDirectory get-directory ;
USE-IF: wince? hardware-info.windows.ce
USE-IF: winnt? hardware-info.windows.nt

View File

@ -1,57 +0,0 @@
{ $subheading "Performance" }
{ $list
{ "Continuations are now supported by the static stack effect system. This means that the " { $link infer } " word and the optimizing compiler now both support code which uses continuations." }
{ "Many words which previously ran in the interpreter, such as error handling and I/O, are now compiled to optimized machine code." }
{ "A non-optimizing, just-in-time compiler replaces the interpreter with no loss in functionality or introspective ability." }
{ "The non-optimizing compiler compiles quotations the first time they are called, generating a series of stack pushes and subroutine calls." }
{ "The optimizing compiler now performs some more representation inference. Alien pointers are unboxed where possible. This improves performance of the " { $vocab-link "ogg.player" } " Ogg Theora video player considerably." }
{ "The queue of sleeping tasks is now a sorted priority queue. This improves performance considerably when there is a large number of sleeping threads (Doug Coleman)" }
{ "Improved hash code algorithm for sequences" }
{ "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" }
{ "New " { $link big-random } " word for generating large random numbers quickly" }
{ "Improved profiler no longer has to be explicitly enabled and disabled with a recompile step; instead, the " { $link profile } " word can be used at any time, and it dynamically patches all words in the code heap to increment call counts. There is no overhead when the profiler is not in use." }
}
{ $subheading "IO" }
{ $list
{ "The " { $link "stream-protocol" } " has changed" }
{ "New " { $link os-envs } " word to get the current set of environment variables" }
{ "Redesigned " { $vocab-link "io.launcher" } " supports passing environment variables to the child process" }
{ { $link <process-stream> } " implemented on Windows (Doug Coleman)" }
{ "More robust Windows CE native I/O" }
{ "Updated " { $vocab-link "io.mmap" } " for new module system, now supports Windows CE (Doug Coleman)" }
{ { $vocab-link "io.sniffer" } " - packet sniffer library (Doug Coleman, Elie Chaftari)" }
{ { $vocab-link "io.server" } " - improved logging support, logs to a file by default" }
{ { $vocab-link "io.files" } " - several new file system manipulation words added" }
{ { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" }
{ { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $vocab-link "/etc/inittab" } " and " { $snippet "/etc/init.d/" } "." }
}
{ $subheading "Tools" }
{ $list
{ "Graphical deploy tool added - see " { $link "ui.tools.deploy" } }
{ "The deploy tool now supports Windows" }
{ { $vocab-link "network-clipboard" } " - clipboard synchronization with a simple TCP/IP protocol" }
}
{ $subheading "UI" }
{ $list
{ { $vocab-link "cairo" } " - updated for new module system, new features (Sampo Vuori)" }
{ { $vocab-link "springies" } " - physics simulation UI demo (Eduardo Cavazos)" }
{ { $vocab-link "ui.gadgets.buttons" } " - added check box and radio button gadgets" }
{ "Double- and triple-click-drag now supported in the editor gadget to select words or lines at a time" }
{ "Windows can be closed on request now using " { $link close-window } }
{ "New icons (Elie Chaftari)" }
}
{ $subheading "Other" }
{ $list
{ "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } }
{ "The " { $vocab-link "http.server.responder.cgi" } " vocabulary implements CGI support for the Factor HTTP server." }
{ "The optimizing compiler no longer depends on the number tower and it is possible to bootstrap a minimal image by just passing " { $snippet "-include=compiler" } " to stage 2 bootstrap." }
{ { $vocab-link "benchmarks.knucleotide" } " - new benchmark (Eric Mertens)" }
{ { $vocab-link "channels" } " - concurrent message passing over message channels" }
{ { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" }
{ { $vocab-link "dlists" } " - various updates (Doug Coleman)" }
{ { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" }
{ { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" }
{ { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" }
{ { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" }
{ { $vocab-link "tuple.lib" } " - some utility words for working with tuples (Doug Coleman)" }
}

View File

@ -235,6 +235,7 @@ ARTICLE: "changes" "Changes in the latest release"
{ "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" }
{ "New " { $link big-random } " word for generating large random numbers quickly" }
{ "Improved profiler no longer has to be explicitly enabled and disabled with a full recompile; instead, the " { $link profile } " word can be used at any time, and it dynamically patches words to increment call counts. There is no overhead when the profiler is not in use." }
{ "Calls to " { $link member? } " with a literal sequence are now open-coded. If there are four or fewer elements, a series of conditionals are generated; if there are more than four elements, there is a hash dispatch followed by conditionals in each branch." }
}
{ $subheading "IO" }
{ $list
@ -247,7 +248,7 @@ ARTICLE: "changes" "Changes in the latest release"
{ { $vocab-link "io.server" } " - improved logging support, logs to a file by default" }
{ { $vocab-link "io.files" } " - several new file system manipulation words added" }
{ { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" }
{ { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $vocab-link "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." }
{ { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $snippet "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." }
}
{ $subheading "Tools" }
{ $list
@ -264,7 +265,7 @@ ARTICLE: "changes" "Changes in the latest release"
{ "Windows can be closed on request now using " { $link close-window } }
{ "New icons (Elie Chaftari)" }
}
{ $subheading "Other" }
{ $subheading "Libraries" }
{ $list
{ "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } }
{ "The " { $vocab-link "webapps.cgi" } " vocabulary implements CGI support for the Factor HTTP server." }
@ -273,11 +274,19 @@ ARTICLE: "changes" "Changes in the latest release"
{ { $vocab-link "channels" } " - concurrent message passing over message channels" }
{ { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" }
{ { $vocab-link "dlists" } " - various updates (Doug Coleman)" }
{ { $vocab-link "editors.emeditor" } " - EmEditor integration (Doug Coleman)" }
{ { $vocab-link "editors.editplus" } " - EditPlus integration (Aaron Schaefer)" }
{ { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" }
{ { $vocab-link "editors.ted-notepad" } " - TED Notepad integration (Doug Coleman)" }
{ { $vocab-link "editors.ultraedit" } " - UltraEdit integration (Doug Coleman)" }
{ { $vocab-link "globs" } " - simple Unix shell-style glob patterns" }
{ { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" }
{ { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" }
{ { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" }
{ { $vocab-link "tuple.lib" } " - some utility words for working with tuples (Doug Coleman)" }
{ { $vocab-link "rss" } " - add Atom feed generation (Daniel Ehrenberg)" }
{ { $vocab-link "tuples.lib" } " - some utility words for working with tuples (Doug Coleman)" }
{ { $vocab-link "webapps.pastebin" } " - improved appearance, add Atom feed generation, add syntax highlighting using " { $vocab-link "xmode" } }
{ { $vocab-link "webapps.planet" } " - add Atom feed generation" }
}
{ $heading "Factor 0.90" }
{ $subheading "Core" }

View File

@ -1,5 +1,5 @@
USING: help.markup help.crossref help.topics help.syntax
definitions io prettyprint inspector ;
definitions io prettyprint inspector help.lint arrays math ;
IN: help
ARTICLE: "printing-elements" "Printing markup elements"
@ -81,7 +81,8 @@ $nl
}
{ $subsection "element-types" }
"Related words can be cross-referenced:"
{ $subsection related-words } ;
{ $subsection related-words }
{ $see-also "help.lint" } ;
ARTICLE: "help-impl" "Help system implementation"
"Help topic protocol:"
@ -108,6 +109,7 @@ ARTICLE: "help" "Help system"
"The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words."
{ $subsection "browsing-help" }
{ $subsection "writing-help" }
{ $subsection "help.lint" }
{ $subsection "help-impl" } ;
ABOUT: "help"
@ -143,7 +145,7 @@ HELP: $index
{ $description "Calls the quotation to generate a sequence of help topics, and outputs a " { $link $subsection } " for each one." } ;
HELP: ($index)
{ $values { "seq" "a sequence of help article names and words" } { "quot" "a quotation with stack effect " { $snippet "( topic -- )" } } }
{ $values { "articles" "a sequence of help articles" } }
{ $description "Writes a list of " { $link $subsection } " elements to the " { $link stdio } " stream." } ;
HELP: xref-help
@ -154,3 +156,7 @@ HELP: sort-articles
{ $description "Sorts a sequence of help topics." } ;
{ article-children article-parent xref-help } related-words
HELP: $predicate
{ $values { "element" "a markup element of the form " { $snippet "{ word }" } } }
{ $description "Prints the boilerplate description of a class membership predicate word such as " { $link array? } " or " { $link integer? } "." } ;

View File

@ -4,7 +4,7 @@ USING: arrays io kernel namespaces parser prettyprint sequences
words assocs definitions generic quotations effects
slots continuations tuples debugger combinators
vocabs help.stylesheet help.topics help.crossref help.markup
sorting ;
sorting classes ;
IN: help
GENERIC: word-help* ( word -- content )
@ -15,12 +15,22 @@ GENERIC: word-help* ( word -- content )
[ swap 2array 1array ] [ 2drop f ] if
] ?if ;
: $predicate ( element -- )
{ { "object" object } { "?" "a boolean" } } $values
[
"Tests if the object is an instance of the " ,
first "predicating" word-prop \ $link swap 2array ,
" class." ,
] { } make $description ;
M: word word-help* drop f ;
M: slot-reader word-help* drop \ $slot-reader ;
M: slot-writer word-help* drop \ $slot-writer ;
M: predicate word-help* drop \ $predicate ;
: all-articles ( -- seq )
articles get keys
all-words [ word-help ] subset append ;

View File

@ -1,8 +1,20 @@
USING: help.markup help.syntax ;
IN: help.lint
HELP: check-help
{ $description "Checks all word and article help." } ;
HELP: check-vocab-help
{ $values { "vocab" "a vocabulary specifier" } }
{ $description "Checks all word help in the given vocabulary." } ;
ARTICLE: "help.lint" "Help lint tool"
"A quick and dirty tool to check documentation in an automated fashion."
"The " { $vocab-link "help.lint" } " vocabulary implements a tool to check documentation in an automated fashion. You should use this tool to check any documentation that you write."
$nl
"To run help lint, use one of the following two words:"
{ $subsection check-help }
{ $subsection check-vocab-help }
"Help lint performs the following checks:"
{ $list
"ensures examples run and produce stated output"
{ "ensures " { $link $see-also } " elements don't contain duplicate entries" }

View File

@ -4,7 +4,8 @@ USING: sequences parser kernel help help.markup help.topics
words strings classes tools.browser namespaces io
io.streams.string prettyprint definitions arrays vectors
combinators splitting debugger hashtables sorting effects vocabs
vocabs.loader assocs editors continuations classes.predicate ;
vocabs.loader assocs editors continuations classes.predicate
macros combinators.lib ;
IN: help.lint
: check-example ( element -- )
@ -29,7 +30,7 @@ IN: help.lint
stack-effect dup effect-in swap effect-out
append [ string? ] subset prune natural-sort ;
: check-values ( word element -- )
: contains-funky-elements? ( element -- ? )
{
$shuffle
$values-x/y
@ -38,11 +39,20 @@ IN: help.lint
$predicate
$class-description
$error-description
}
over [ elements empty? ] curry all?
pick "declared-effect" word-prop and
[ extract-values >array >r effect-values >array r> assert= ]
[ 2drop ] if ;
} swap [ elements f like ] curry contains? ;
: check-values ( word element -- )
{
[ over "declared-effect" word-prop ]
[ dup contains-funky-elements? not ]
[ over macro? not ]
[
2dup extract-values >array
>r effect-values >array
r> assert=
t
]
} && 3drop ;
: check-see-also ( word element -- )
nip \ $see-also swap elements [
@ -61,55 +71,59 @@ IN: help.lint
: check-rendering ( word element -- )
[ help ] string-out drop ;
: all-word-help ( -- seq )
all-words [ word-help ] subset ;
: all-word-help ( words -- seq )
[ word-help ] subset ;
TUPLE: help-error topic ;
: <help-error> ( topic delegate -- error )
{ set-help-error-topic set-delegate } help-error construct ;
: fix-help ( error -- )
dup delegate error.
help-error-topic >link edit
"Press ENTER when done." print flush readln drop
refresh-all ;
M: help-error error.
"In " write dup help-error-topic ($link) nl
delegate error. ;
: check-something ( obj quot -- )
over . flush [ <help-error> , ] recover ; inline
: check-word ( word -- )
dup . flush
[
dup word-help [
2dup check-examples
2dup check-values
2dup check-see-also
2dup check-modules
2dup drop check-rendering
] assert-depth 2drop
] [
dupd <help-error> fix-help check-word
] recover ;
dup word-help [
[
dup word-help [
2dup check-examples
2dup check-values
2dup check-see-also
2dup check-modules
2dup drop check-rendering
] assert-depth 2drop
] check-something
] [ drop ] if ;
: check-words ( -- )
[
all-vocabs-seq [ vocab-name ] map
"all-vocabs" set
all-word-help [ check-word ] each
] with-scope ;
: check-words ( words -- ) [ check-word ] each ;
: check-article ( article -- )
dup . flush
[
[ dup check-rendering ] assert-depth drop
] [
dupd <help-error> fix-help check-article
] recover ;
] check-something ;
: check-articles ( -- )
articles get keys [ check-article ] each ;
: check-help ( -- ) check-words check-articles ;
: with-help-lint ( quot -- )
[
all-vocabs-seq [ vocab-name ] map "all-vocabs" set
call
] { } make [ nl error. ] each ; inline
: unlinked-words ( -- seq )
: check-help ( -- )
[ all-words check-words check-articles ] with-help-lint ;
: check-vocab-help ( vocab -- )
[
child-vocabs [ words check-words ] each
] with-help-lint ;
: unlinked-words ( words -- seq )
all-word-help [ article-parent not ] subset ;
: linked-undocumented-words ( -- seq )

View File

@ -1,15 +1,23 @@
USING: assocs browser.parser kernel math sequences strings ;
IN: browser.analyzer
USING: assocs html.parser kernel math sequences strings ;
IN: html.parser.analyzer
: remove-blank-text ( vector -- vector )
: remove-blank-text ( vector -- vector' )
[
dup tag-name text = [
tag-text [ blank? not ] all?
tag-text [ blank? ] all? not
] [
drop t
] if
] subset ;
: trim-text ( vector -- vector' )
[
dup tag-name text = [
[ tag-text [ blank? ] trim ] keep
[ set-tag-text ] keep
] when
] map ;
: find-by-id ( id vector -- vector )
[ tag-attributes "id" swap at = ] curry* subset ;
@ -79,5 +87,5 @@ IN: browser.analyzer
! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html "Currency" "name" pick find-first-attribute-key-value
! clear "/Users/erg/web/hostels.html" <file-reader> contents parse-html
! "Currency" "name" pick find-first-attribute-key-value
! "Currency" "name" pick find-first-attribute-key-value
! pick find-between remove-blank-text

View File

@ -1,4 +1,4 @@
USING: browser.parser kernel tools.test ;
USING: html.parser kernel tools.test ;
IN: temporary
[

View File

@ -1,8 +1,7 @@
USING: arrays browser.utils hashtables io kernel namespaces
prettyprint quotations
USING: arrays html.parser.utils hashtables io kernel
namespaces prettyprint quotations
sequences splitting state-parser strings ;
USE: tools.interpreter
IN: browser.parser
IN: html.parser
TUPLE: tag name attributes text matched? closing? ;
@ -121,7 +120,7 @@ SYMBOL: tagstack
] unless ;
: parse-attributes ( -- hashtable )
[ (parse-attributes) ] { } make >hashtable ;
[ (parse-attributes) ] { } make >hashtable ;
: (parse-tag)
[

View File

@ -1,9 +1,9 @@
USING: assocs browser.parser browser.utils combinators
USING: assocs html.parser html.parser.utils combinators
continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
IN: browser.printer
IN: html.parser.printer
SYMBOL: no-section
SYMBOL: html
@ -42,7 +42,7 @@ HOOK: print-closing-named-tag printer ( tag -- )
M: printer print-text-tag ( tag -- )
tag-text write ;
M: printer print-comment-tag ( tag -- )
M: printer print-comment-tag ( tag -- )
"<!--" write
tag-text write
"-->" write ;
@ -67,7 +67,6 @@ M: printer print-closing-named-tag ( tag -- )
[
swap bl write "=" write ?quote write
] assoc-each ;
M: src-printer print-opening-named-tag ( tag -- )
"<" write
@ -102,7 +101,7 @@ SYMBOL: tablestack
[
V{ } clone tablestack set
] with-scope ;
! { { 1 2 } { 3 4 } }
! H{ { table-gap { 10 10 } } } [
! [ [ [ [ . ] with-cell ] each ] with-row ] each

View File

@ -2,7 +2,7 @@ USING: assocs combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings tools.test ;
USING: browser.utils ;
USING: html.parser.utils ;
IN: temporary
[ "'Rome'" ] [ "Rome" single-quote ] unit-test

View File

@ -2,8 +2,8 @@ USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
state-parser strings ;
USING: browser.parser ;
IN: browser.utils
USING: html.parser ;
IN: html.parser.utils
: string-parse-end?
get-next not ;

View File

@ -20,7 +20,7 @@ IN: http
dup letter?
over LETTER? or
over digit? or
swap "/_?." member? or ; foldable
swap "/_-?." member? or ; foldable
: url-encode ( str -- str )
[
@ -60,11 +60,18 @@ IN: http
: url-decode ( str -- str )
[ 0 swap url-decode-iter ] "" make ;
: build-url ( path query-params -- str )
: hash>query ( hash -- str )
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
"&" join ;
: build-url ( str query-params -- newstr )
[
swap % dup assoc-empty? [
"?" % dup
[ [ url-encode ] 2apply "=" swap 3append ] { } assoc>map
"&" join %
] unless drop
over %
dup assoc-empty? [
2drop
] [
CHAR: ? rot member? "&" "?" ? %
hash>query %
] if
] "" make ;

View File

@ -2,7 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
!
USING: arrays combinators io io.binary io.files io.utf16 kernel math math.parser namespaces sequences splitting strings assocs ;
USING: arrays combinators io io.binary io.files io.paths
io.utf16 kernel math math.parser namespaces sequences
splitting strings assocs ;
IN: id3
@ -121,18 +123,6 @@ C: <extended-header> extended-header
: id3v2 ( filename -- tag/f )
<file-reader> [ read-tag ] with-stream ;
: append-path ( path files -- paths )
[ path+ ] curry* map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [ get-paths dup % [ (walk-dir) ] each ] [ drop ] if ;
: walk-dir ( path -- seq )
[ (walk-dir) ] { } make ;
: file? ( path -- ? )
stat 3drop not ;

View File

@ -0,0 +1,24 @@
USING: assocs io.files kernel namespaces sequences ;
IN: io.paths
: find-file ( seq str -- path/f )
[
[ path+ exists? ] curry find nip
] keep over [ path+ ] [ drop ] if ;
<PRIVATE
: append-path ( path files -- paths )
[ path+ ] curry* map ;
: get-paths ( dir -- paths )
dup directory keys append-path ;
: (walk-dir) ( path -- )
dup directory? [
get-paths dup % [ (walk-dir) ] each
] [
drop
] if ;
PRIVATE>
: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;

View File

@ -7,7 +7,8 @@ IN: windows.ce.files
! M: windows-ce-io normalize-pathname ( string -- string )
! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
FILE_ATTRIBUTE_NORMAL bitor ;
M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
: finish-read ( port status bytes-ret -- )

View File

@ -87,9 +87,9 @@ TUPLE: CreateProcess-args
pass-environment? [
[
get-environment
[ swap % "=" % % "\0" % ] assoc-each
[ "=" swap 3append string>u16-alien % ] assoc-each
"\0" %
] "" make >c-ushort-array
] { } make >c-ushort-array
over set-CreateProcess-args-lpEnvironment
] when ;

View File

@ -62,7 +62,7 @@ M: windows-ce-io with-privileges
: mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
{ "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
>r >r open-file dup f r> 0 0 f
>r >r 0 open-file dup f r> 0 0 f
CreateFileMapping [ win32-error=0/f ] keep
dup close-later
dup

View File

@ -27,7 +27,7 @@ M: windows-nt-io normalize-pathname ( string -- string )
{ [ dup ".\\" head? ] [
>r unicode-prefix cwd r> 1 tail 3append
] }
! c:\\
! c:\\foo
{ [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] }
! \\\\?\\c:\\foo
{ [ dup unicode-prefix head? ] [ ] }
@ -38,7 +38,8 @@ M: windows-nt-io normalize-pathname ( string -- string )
dup first CHAR: \\ = [ CHAR: \\ , ] unless %
] "" make
] }
} cond [ "/\\." member? ] right-trim ;
} cond [ "/\\." member? ] right-trim
dup peek CHAR: : = [ "\\" append ] when ;
SYMBOL: io-hash

View File

@ -3,8 +3,8 @@ io.windows.nt io.windows.nt.backend kernel libc math
threads windows windows.kernel32 ;
IN: io.windows.nt.files
M: windows-nt-io CreateFile-flags ( -- DWORD )
FILE_FLAG_OVERLAPPED ;
M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
FILE_FLAG_OVERLAPPED bitor ;
M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
make-overlapped ;

View File

@ -4,7 +4,7 @@ USING: alien alien.c-types arrays destructors io io.backend
io.buffers io.files io.nonblocking io.sockets io.binary
io.sockets.impl windows.errors strings io.streams.duplex kernel
math namespaces sequences windows windows.kernel32
windows.winsock splitting ;
windows.shell32 windows.winsock splitting ;
IN: io.windows
TUPLE: windows-nt-io ;
@ -23,7 +23,7 @@ TUPLE: win32-file handle ptr overlapped ;
: <win32-duplex-stream> ( in out -- stream )
>r f <win32-file> r> f <win32-file> handle>duplex-stream ;
HOOK: CreateFile-flags io-backend ( -- DWORD )
HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
HOOK: add-completion io-backend ( port -- )
@ -31,7 +31,8 @@ M: windows-io normalize-directory ( string -- string )
"\\" ?tail drop "\\*" append ;
: share-mode ( -- fixnum )
FILE_SHARE_READ FILE_SHARE_WRITE bitor ; inline
FILE_SHARE_READ FILE_SHARE_WRITE bitor
FILE_SHARE_DELETE bitor ; foldable
M: win32-file init-handle ( handle -- )
drop ;
@ -40,24 +41,25 @@ M: win32-file close-handle ( handle -- )
win32-file-handle CloseHandle drop ;
! Clean up resources (open handle) if add-completion fails
: open-file ( path access-mode create-mode -- handle )
: open-file ( path access-mode create-mode flags -- handle )
[
>r share-mode f r> CreateFile-flags f CreateFile
>r >r >r normalize-pathname r>
share-mode f r> r> CreateFile-flags f CreateFile
dup invalid-handle? dup close-later
dup add-completion
] with-destructors ;
: open-pipe-r/w ( path -- handle )
GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING open-file ;
GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING 0 open-file ;
: open-read ( path -- handle length )
normalize-pathname GENERIC_READ OPEN_EXISTING open-file 0 ;
GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
: open-write ( path -- handle length )
normalize-pathname GENERIC_WRITE CREATE_ALWAYS open-file 0 ;
GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ;
: (open-append) ( path -- handle )
normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ;
GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
: set-file-pointer ( handle length -- )
dupd d>w/w <uint> FILE_BEGIN SetFilePointer

View File

@ -181,7 +181,7 @@ HELP: lmerge
{ $values { "list1" "a list" } { "list2" "a list" } { "result" "lazy list merging list1 and list2" } }
{ $description "Return the result of merging the two lists in a lazy manner." }
{ $examples
{ $example "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
{ $example "USE: lazy-lists" "{ 1 2 3 } >list { 4 5 6 } >list lmerge list>array ." "{ 1 4 2 5 3 6 }" }
}
{ $see-also leach lmap lmap-with lconcat ltake lsubset lfrom-by lcartesian-product lcomp } ;

View File

@ -4,7 +4,7 @@ IN: locals
<PRIVATE
: $with-locals-note
{
drop {
"This form must appear either in a word defined by " { $link POSTPONE: :: } " or " { $link POSTPONE: MACRO:: } ", or alternatively, " { $link with-locals } " must be called on the top-level form of the word to perform closure conversion."
} $notes ;
@ -28,10 +28,10 @@ HELP: [let
{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
{ $examples
{ $example
"USE: locals"
"USING: locals math.functions ;"
":: frobnicate | n seq |"
" [let | n' [ n 6 * ] |"
" seq [ n' gcd ] map ] ;"
" seq [ n' gcd nip ] map ] ;"
"6 { 36 14 } frobnicate ."
"{ 36 2 }"
}

View File

@ -273,20 +273,20 @@ HELP: mod-inv
{ $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." }
{ $errors "Throws an error if " { $snippet "n" } " is not invertible modulo " { $snippet "n" } "." }
{ $examples
{ $example "173 1119 mod-inv ." "815" }
{ $example "173 815 * 1119 mod ." "1" }
{ $example "USE: math.functions" "173 1119 mod-inv ." "815" }
{ $example "USE: math.functions" "173 815 * 1119 mod ." "1" }
} ;
HELP: each-bit
{ $values { "n" integer } { "quot" "a quotation with stack effect " { $snippet "( ? -- )" } } }
{ $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." }
{ $examples
{ $example "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" }
{ $example "[ -3 [ , ] each-bit ] { } make ." "{ f t }" }
{ $example "USE: math.functions" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" }
{ $example "USE: math.functions" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" }
} ;
HELP: ~
{ $values { "x" real } { "y" real } { "epsilon" real } }
{ $values { "x" real } { "y" real } { "epsilon" real } { "?" "a boolean" } }
{ $description "Tests if " { $snippet "x" } " and " { $snippet "y" } " are approximately equal to each other. There are three possible comparison tests, chosen based on the sign of " { $snippet "epsilon" } ":"
{ $list
{ { $snippet "epsilon" } " is zero: exact comparison." }

View File

@ -45,7 +45,7 @@ HELP: deactivate-model
{ $warning "Calls to " { $link activate-model } " and " { $link deactivate-model } " should be balanced to keep the reference counting consistent, otherwise " { $link model-changed } " might be called at the wrong time or not at all." } ;
HELP: model-changed
{ $values { "observer" object } }
{ $values { "model" model } { "observer" object } }
{ $contract "Called to notify observers of a model that the model value has changed as a result of a call to " { $link set-model } ". Observers can be registered with " { $link add-connection } "." } ;
{ add-connection remove-connection model-changed } related-words

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