Merge branch 'master' into xml
Conflicts: extra/rss/rss.factor extra/sequences/lib/lib.factor extra/xml/data/data.factordb4
Daniel Ehrenberg
commit
b8f210a3be
core
alien/syntax
bootstrap
classes
combinators
compiler
continuations
generator
generic/math
hashtables
libc
math
optimizer
known-words
math
prettyprint/backend
sequences
slots
extra
benchmark/reverse-complement
calendar
cfdg
channels/remote
combinators/lib
concurrency
crypto/common
delegate
documents
editors
editpadpro
gvim
notepadpp
ted-notepad
faq
furnace
globs
hardware-info/windows
html/parser
http
id3
io
paths
windows
ce/files
launcher
mmap
nt
backend
files
lazy-lists
locals
math/functions
models
10
Makefile
10
Makefile
|
|
@ -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 $@ $<
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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" } "." } ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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? } "." } ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } "." } ;
|
||||
|
|
|
|||
|
|
@ -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" } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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? } "." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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? [
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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? ( -- ? )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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."
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Eduardo Cavazos
|
||||
|
|
@ -0,0 +1 @@
|
|||
Bake is similar to make but with additional features
|
||||
|
|
@ -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* ;
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Eduardo Cavazos
|
||||
|
|
@ -0,0 +1 @@
|
|||
Minimalist chat server
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Matthew Willis
|
||||
Eduardo Cavazos
|
||||
|
|
@ -0,0 +1 @@
|
|||
Connects to a cabal server
|
||||
|
|
@ -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 )
|
||||
[
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Implementation of: http://contextfreeart.org
|
||||
|
|
@ -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 } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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? } ;
|
||||
|
|
|
|||
|
|
@ -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." } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Aaron Schaefer
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
EditPlus editor integration
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
EmEditor integration
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
|
@ -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* ;
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
TED Notepad integration
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
UltraEdit editor integration
|
||||
|
|
@ -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
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Wordpad editor integration
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
Slava Pestov
|
||||
Doug Coleman
|
||||
|
|
@ -28,7 +28,7 @@ TUPLE: test-tuple m n ;
|
|||
[
|
||||
H{
|
||||
{ "bar" "hello" }
|
||||
} \ foo query>quot
|
||||
} \ foo query>seq
|
||||
] with-scope
|
||||
] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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)" }
|
||||
}
|
||||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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? } "." } ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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" }
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
|
|
|||
18
extra/browser/analyzer/analyzer.factor → extra/html/parser/analyzer/analyzer.factor
Normal file → Executable file
18
extra/browser/analyzer/analyzer.factor → extra/html/parser/analyzer/analyzer.factor
Normal file → Executable 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
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
USING: browser.parser kernel tools.test ;
|
||||
USING: html.parser kernel tools.test ;
|
||||
IN: temporary
|
||||
|
||||
[
|
||||
|
|
@ -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)
|
||||
[
|
||||
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
@ -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 -- )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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 }"
|
||||
}
|
||||
|
|
|
|||
|
|
@ -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." }
|
||||
|
|
|
|||
|
|
@ -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
Loading…
Reference in New Issue