From: Alex Chapman
Date: Fri, 30 Jan 2009 10:20:28 +0000 (+1100)
Subject: Merge branch 'master' into experimental
X-Git-Tag: 0.94~2132^2~25
X-Git-Url: https://gitweb.factorcode.org/gitweb.cgi?p=factor.git;a=commitdiff_plain;h=da7a6da6a54ded7382979b618a3437a5e55f1974;hp=4e41211399df7523acd9e5fb9d4dd71ac3140727
Merge branch 'master' into experimental
Conflicts:
basis/http/client/client.factor
---
diff --git a/.gitignore b/.gitignore
index f4334f3727..a7cbeeeef3 100644
--- a/.gitignore
+++ b/.gitignore
@@ -21,3 +21,4 @@ logs
work
build-support/wordsize
*.bak
+.#*
diff --git a/Factor.app/Contents/Info.plist b/Factor.app/Contents/Info.plist
index a8943d0d32..c87520d0fd 100644
--- a/Factor.app/Contents/Info.plist
+++ b/Factor.app/Contents/Info.plist
@@ -32,7 +32,7 @@
CFBundlePackageType
APPL
NSHumanReadableCopyright
- Copyright © 2003-2008, Slava Pestov and friends
+ Copyright © 2003-2009, Slava Pestov and friends
NSServices
diff --git a/Makefile b/Makefile
index ffcbf6364c..b41e756729 100644
--- a/Makefile
+++ b/Makefile
@@ -3,6 +3,7 @@ AR = ar
LD = ld
EXECUTABLE = factor
+CONSOLE_EXECUTABLE = factor-console
VERSION = 0.92
IMAGE = factor.image
@@ -25,23 +26,25 @@ ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/alien.o \
vm/bignum.o \
+ vm/callstack.o \
+ vm/code_block.o \
+ vm/code_gc.o \
vm/code_heap.o \
+ vm/data_gc.o \
+ vm/data_heap.o \
vm/debug.o \
+ vm/errors.o \
vm/factor.o \
vm/ffi_test.o \
vm/image.o \
vm/io.o \
vm/math.o \
- vm/data_gc.o \
- vm/code_gc.o \
vm/primitives.o \
+ vm/profiler.o \
+ vm/quotations.o \
vm/run.o \
- vm/callstack.o \
vm/types.o \
- vm/quotations.o \
- vm/utilities.o \
- vm/errors.o \
- vm/profiler.o
+ vm/utilities.o
EXE_OBJS = $(PLAF_EXE_OBJS)
@@ -136,9 +139,11 @@ zlib1.dll:
winnt-x86-32: freetype6.dll zlib1.dll
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
+ $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
winnt-x86-64:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
+ $(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
wince-arm:
$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
@@ -159,6 +164,11 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
+factor-console: $(DLL_OBJS) $(EXE_OBJS)
+ $(LINKER) $(ENGINE) $(DLL_OBJS)
+ $(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+ $(CFLAGS) $(CFLAGS_CONSOLE) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
+
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor.{a,so,dylib}
diff --git a/basis/alias/alias-docs.factor b/basis/alias/alias-docs.factor
deleted file mode 100644
index 3f2eee6460..0000000000
--- a/basis/alias/alias-docs.factor
+++ /dev/null
@@ -1,26 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words help.markup help.syntax ;
-IN: alias
-
-HELP: ALIAS:
-{ $syntax "ALIAS: new-word existing-word" }
-{ $values { "new-word" word } { "existing-word" word } }
-{ $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." }
-{ $examples
- { $example "USING: alias prettyprint sequences ;"
- "IN: alias.test"
- "ALIAS: sequence-nth nth"
- "0 { 10 20 30 } sequence-nth ."
- "10"
- }
-} ;
-
-ARTICLE: "alias" "Word aliasing"
-"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl
-"Make a new word that aliases another word:"
-{ $subsection define-alias }
-"Make an alias at parse-time:"
-{ $subsection POSTPONE: ALIAS: } ;
-
-ABOUT: "alias"
diff --git a/basis/alias/alias.factor b/basis/alias/alias.factor
deleted file mode 100644
index 4de4d833fa..0000000000
--- a/basis/alias/alias.factor
+++ /dev/null
@@ -1,18 +0,0 @@
-! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors words quotations kernel effects sequences parser ;
-IN: alias
-
-PREDICATE: alias < word "alias" word-prop ;
-
-M: alias reset-word
- [ call-next-method ] [ f "alias" set-word-prop ] bi ;
-
-M: alias stack-effect
- def>> first stack-effect ;
-
-: define-alias ( new old -- )
- [ 1quotation define-inline ]
- [ drop t "alias" set-word-prop ] 2bi ;
-
-: ALIAS: CREATE-WORD scan-word define-alias ; parsing
diff --git a/basis/alias/authors.txt b/basis/alias/authors.txt
deleted file mode 100644
index 1901f27a24..0000000000
--- a/basis/alias/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Slava Pestov
diff --git a/basis/alias/summary.txt b/basis/alias/summary.txt
deleted file mode 100644
index 15690a7b9b..0000000000
--- a/basis/alias/summary.txt
+++ /dev/null
@@ -1 +0,0 @@
-Defining multiple words with the same name
diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor
index 31542b2699..40171f56e7 100644
--- a/basis/alien/c-types/c-types-tests.factor
+++ b/basis/alien/c-types/c-types-tests.factor
@@ -8,10 +8,6 @@ sequences system libc alien.strings io.encodings.utf8 ;
[ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
-: foo ( -- n ) &: fdafd [ 123 ] unless* ;
-
-[ 123 ] [ foo ] unit-test
-
[ -1 ] [ -1 *char ] unit-test
[ -1 ] [ -1 *short ] unit-test
[ -1 ] [ -1 *int ] unit-test
diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor
index ae148e3ac0..d1354cb04e 100644
--- a/basis/alien/c-types/c-types.factor
+++ b/basis/alien/c-types/c-types.factor
@@ -234,17 +234,16 @@ M: long-long-type box-return ( type -- )
f swap box-parameter ;
: define-deref ( name -- )
- [ CHAR: * prefix "alien.c-types" create ]
- [ c-getter 0 prefix ] bi
- define-inline ;
+ [ CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
+ (( c-ptr -- value )) define-inline ;
: define-out ( name -- )
[ "alien.c-types" constructor-word ]
- [ dup c-setter '[ _ [ 0 @ ] keep ] ]
- bi define-inline ;
+ [ dup c-setter '[ _ [ 0 @ ] keep ] ] bi
+ (( value -- c-ptr )) define-inline ;
: c-bool> ( int -- ? )
- zero? not ;
+ 0 = not ; inline
: define-primitive-type ( type name -- )
[ typedef ]
diff --git a/basis/alien/remote-control/remote-control-tests.factor b/basis/alien/remote-control/remote-control-tests.factor
new file mode 100644
index 0000000000..8b6c5e9b22
--- /dev/null
+++ b/basis/alien/remote-control/remote-control-tests.factor
@@ -0,0 +1,44 @@
+USING: interpolate multiline
+io io.directories io.encodings.ascii io.files
+io.files.temp io.launcher io.streams.string kernel locals system
+tools.test sequences ;
+IN: alien.remote-control.tests
+
+: compile-file ( contents -- )
+ "test.c" ascii set-file-contents
+ { "gcc" "-I../" "-L.." "-lfactor" "test.c" }
+ os macosx? cpu x86.64? and [ "-m64" suffix ] when
+ try-process ;
+
+: run-test ( -- line )
+ os windows? "temp/a.exe" "temp/a.out" ?
+ ascii [ readln ] with-process-reader ;
+
+:: test-embedding ( code -- line )
+ image :> image
+
+ [
+ I[
+#include
+#include
+#include
+
+int main(int argc, char **argv)
+{
+ F_PARAMETERS p;
+ default_parameters(&p);
+ p.image_path = STRING_LITERAL("${image}");
+ init_factor(&p);
+ start_embedded_factor(&p);
+ ${code}
+ printf("Done.\n");
+ return 0;
+}
+ ]I
+ ] with-string-writer
+ "resource:temp" [ compile-file ] with-directory
+ "resource:" [ run-test ] with-directory ;
+
+! [ "Done." ] [ "" test-embedding ] unit-test
+
+! [ "Done." ] [ "factor_yield();" test-embedding ] unit-test
\ No newline at end of file
diff --git a/basis/alien/remote-control/remote-control.factor b/basis/alien/remote-control/remote-control.factor
index 9cd9050ea8..4da06ec4c9 100644
--- a/basis/alien/remote-control/remote-control.factor
+++ b/basis/alien/remote-control/remote-control.factor
@@ -15,7 +15,7 @@ IN: alien.remote-control
"void" { "long" } "cdecl" [ sleep ] alien-callback ;
: ?callback ( word -- alien )
- dup compiled>> [ execute ] [ drop f ] if ; inline
+ dup optimized>> [ execute ] [ drop f ] if ; inline
: init-remote-control ( -- )
\ eval-callback ?callback 16 setenv
diff --git a/basis/alien/strings/windows/tags.txt b/basis/alien/strings/windows/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/alien/strings/windows/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor
index abce91f56f..f5537fa239 100644
--- a/basis/alien/structs/fields/fields.factor
+++ b/basis/alien/structs/fields/fields.factor
@@ -52,8 +52,8 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
[ (>>offset) ] [ type>> heap-size + ] 2bi
] reduce ;
-: define-struct-slot-word ( word quot spec -- )
- offset>> prefix define-inline ;
+: define-struct-slot-word ( word quot spec effect -- )
+ [ offset>> prefix ] dip define-inline ;
: define-getter ( type spec -- )
[ set-reader-props ] keep
@@ -62,11 +62,13 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
type>>
[ c-getter ] [ c-type-boxer-quot ] bi append
]
- [ ] tri define-struct-slot-word ;
+ [ ] tri
+ (( c-ptr -- value )) define-struct-slot-word ;
: define-setter ( type spec -- )
[ set-writer-props ] keep
- [ writer>> ] [ type>> c-setter ] [ ] tri define-struct-slot-word ;
+ [ writer>> ] [ type>> c-setter ] [ ] tri
+ (( value c-ptr -- )) define-struct-slot-word ;
: define-field ( type spec -- )
[ define-getter ] [ define-setter ] 2bi ;
diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor
index 15d82884f9..bed454e81d 100644
--- a/basis/alien/syntax/syntax.factor
+++ b/basis/alien/syntax/syntax.factor
@@ -4,7 +4,7 @@ USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
sequences words quotations math.parser splitting grouping
effects assocs combinators lexer strings.parser alien.parser
-fry ;
+fry vocabs.parser words.constant ;
IN: alien.syntax
: DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
@@ -31,10 +31,11 @@ IN: alien.syntax
: C-ENUM:
";" parse-tokens
- dup length
- [ [ create-in ] dip 1quotation define ] 2each ;
+ [ [ create-in ] dip define-constant ] each-index ;
parsing
+: address-of ( name library -- value )
+ load-library dlsym [ "No such symbol" throw ] unless* ;
+
: &:
- scan "c-library" get
- '[ _ _ load-library dlsym ] over push-all ; parsing
+ scan "c-library" get '[ _ _ address-of ] over push-all ; parsing
diff --git a/basis/ascii/ascii-docs.factor b/basis/ascii/ascii-docs.factor
index 6af697cf89..b2bbc16836 100644
--- a/basis/ascii/ascii-docs.factor
+++ b/basis/ascii/ascii-docs.factor
@@ -37,8 +37,30 @@ HELP: quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }
{ $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
-ARTICLE: "ascii" "ASCII character classes"
-"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"
+HELP: ascii?
+{ $values { "ch" "a character" } { "?" "a boolean" } }
+{ $description "Tests for whether a number is an ASCII character." } ;
+
+HELP: ch>lower
+{ $values { "ch" "a character" } { "lower" "a character" } }
+{ $description "Converts an ASCII character to lower case." } ;
+
+HELP: ch>upper
+{ $values { "ch" "a character" } { "upper" "a character" } }
+{ $description "Converts an ASCII character to upper case." } ;
+
+HELP: >lower
+{ $values { "str" "a string" } { "lower" "a string" } }
+{ $description "Converts an ASCII string to lower case." } ;
+
+HELP: >upper
+{ $values { "str" "a string" } { "upper" "a string" } }
+{ $description "Converts an ASCII string to upper case." } ;
+
+ARTICLE: "ascii" "ASCII"
+"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."
+$nl
+"ASCII character classes:"
{ $subsection blank? }
{ $subsection letter? }
{ $subsection LETTER? }
@@ -46,6 +68,11 @@ ARTICLE: "ascii" "ASCII character classes"
{ $subsection printable? }
{ $subsection control? }
{ $subsection quotable? }
-"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode.categories" } ")." ;
+{ $subsection ascii? }
+"ASCII case conversion:"
+{ $subsection ch>lower }
+{ $subsection ch>upper }
+{ $subsection >lower }
+{ $subsection >upper } ;
ABOUT: "ascii"
diff --git a/basis/ascii/ascii-tests.factor b/basis/ascii/ascii-tests.factor
index 7dacce734b..6f39b32a01 100644
--- a/basis/ascii/ascii-tests.factor
+++ b/basis/ascii/ascii-tests.factor
@@ -12,3 +12,8 @@ IN: ascii.tests
0 "There are Four Upper Case characters"
[ LETTER? [ 1+ ] when ] each
] unit-test
+
+[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test
+
+[ "HELLO HOW ARE YOU?" ] [ "hellO hOw arE YOU?" >upper ] unit-test
+[ "i'm good thx bai" ] [ "I'm Good THX bai" >lower ] unit-test
diff --git a/basis/ascii/ascii.factor b/basis/ascii/ascii.factor
index c009c66cde..193e847d27 100644
--- a/basis/ascii/ascii.factor
+++ b/basis/ascii/ascii.factor
@@ -1,27 +1,23 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.order sequences
-combinators.short-circuit ;
+USING: kernel math math.order sequences strings
+combinators.short-circuit hints ;
IN: ascii
+: ascii? ( ch -- ? ) 0 127 between? ; inline
: blank? ( ch -- ? ) " \t\n\r" member? ; inline
-
: letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
-
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
-
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
-
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
-
-: control? ( ch -- ? )
- "\0\e\r\n\t\u000008\u00007f" member? ; inline
-
-: quotable? ( ch -- ? )
- dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline
-
-: Letter? ( ch -- ? )
- [ [ letter? ] [ LETTER? ] ] 1|| ;
-
-: alpha? ( ch -- ? )
- [ [ Letter? ] [ digit? ] ] 1|| ;
+: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline
+: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
+: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
+: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
+: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ; inline
+: >lower ( str -- lower ) [ ch>lower ] map ;
+: ch>upper ( ch -- upper ) dup letter? [ HEX: 20 - ] when ; inline
+: >upper ( str -- upper ) [ ch>upper ] map ;
+
+HINTS: >lower string ;
+HINTS: >upper string ;
\ No newline at end of file
diff --git a/basis/assoc-heaps/assoc-heaps-docs.factor b/basis/assoc-heaps/assoc-heaps-docs.factor
new file mode 100644
index 0000000000..b148995cb8
--- /dev/null
+++ b/basis/assoc-heaps/assoc-heaps-docs.factor
@@ -0,0 +1,32 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax io.streams.string assocs
+heaps.private ;
+IN: assoc-heaps
+
+HELP:
+{ $values { "assoc" assoc } { "heap" heap } { "assoc-heap" assoc-heap } }
+{ $description "Constructs a new " { $link assoc-heap } " from two existing data structures." } ;
+
+HELP:
+{ $values { "unique-heap" assoc-heap } }
+{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a max-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
+
+HELP:
+{ $values { "unique-heap" assoc-heap } }
+{ $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a min-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
+
+{ } related-words
+
+HELP: assoc-heap
+{ $description "A data structure containing an assoc and a heap to get certain properties with better time constraints at the expense of more space and complexity. For instance, a hashtable and a heap can be combined into one assoc-heap to get a sorted data structure with O(1) lookup. Operations on assoc-heap may update both the assoc and the heap or leave them out of sync if it's advantageous." } ;
+
+ARTICLE: "assoc-heaps" "Associative heaps"
+"The " { $vocab-link "assoc-heaps" } " vocabulary combines exists to synthesize data structures with better time properties than either of the two component data structures alone." $nl
+"Associative heap constructor:"
+{ $subsection }
+"Unique heaps:"
+{ $subsection }
+{ $subsection } ;
+
+ABOUT: "assoc-heaps"
diff --git a/basis/assoc-heaps/assoc-heaps-tests.factor b/basis/assoc-heaps/assoc-heaps-tests.factor
new file mode 100644
index 0000000000..6ea3fe14a4
--- /dev/null
+++ b/basis/assoc-heaps/assoc-heaps-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test assoc-heaps ;
+IN: assoc-heaps.tests
diff --git a/basis/assoc-heaps/assoc-heaps.factor b/basis/assoc-heaps/assoc-heaps.factor
new file mode 100644
index 0000000000..a495aed626
--- /dev/null
+++ b/basis/assoc-heaps/assoc-heaps.factor
@@ -0,0 +1,30 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs hashtables heaps kernel ;
+IN: assoc-heaps
+
+TUPLE: assoc-heap assoc heap ;
+
+C: assoc-heap
+
+: ( -- unique-heap )
+ H{ } clone ;
+
+: ( -- unique-heap )
+ H{ } clone ;
+
+M: assoc-heap heap-push* ( value key assoc-heap -- entry )
+ pick over assoc>> key? [
+ 3drop f
+ ] [
+ [ assoc>> swapd set-at ] [ heap>> heap-push* ] 3bi
+ ] if ;
+
+M: assoc-heap heap-pop ( assoc-heap -- value key )
+ heap>> heap-pop ;
+
+M: assoc-heap heap-peek ( assoc-heap -- value key )
+ heap>> heap-peek ;
+
+M: assoc-heap heap-empty? ( assoc-heap -- value key )
+ heap>> heap-empty? ;
diff --git a/basis/assoc-heaps/authors.txt b/basis/assoc-heaps/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/assoc-heaps/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/base64/base64-docs.factor b/basis/base64/base64-docs.factor
index ed92a19577..530caab8bd 100644
--- a/basis/base64/base64-docs.factor
+++ b/basis/base64/base64-docs.factor
@@ -7,7 +7,13 @@ HELP: >base64
{ $examples
{ $example "USING: prettyprint base64 strings ;" "\"The monorail is a free service.\" >base64 >string ." "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\"" }
}
-{ $see-also base64> } ;
+{ $see-also base64> >base64-lines } ;
+
+HELP: >base64-lines
+{ $values { "seq" sequence } { "base64" "a string of base64 characters" } }
+{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'. The result is padded with '=' if the input was not a multiple of six bits. A crlf is inserted for every 76 characters of output." }
+{ $see-also base64> >base64-lines } ;
+
HELP: base64>
{ $values { "base64" "a string of base64 characters" } { "seq" sequence } }
@@ -16,13 +22,26 @@ HELP: base64>
{ $example "USING: prettyprint base64 strings ;" "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\" base64> >string ." "\"The monorail is a free service.\"" }
}
{ $notes "This word will throw if the input string contains characters other than those allowed in base64 encodings." }
-{ $see-also >base64 } ;
+{ $see-also >base64 >base64-lines } ;
+
+HELP: encode-base64
+{ $description "Reads the standard input and writes it to standard output encoded in base64." } ;
+
+HELP: decode-base64
+{ $description "Reads the standard input and decodes it, writing to standard output." } ;
+
+HELP: encode-base64-lines
+{ $description "Reads the standard input and writes it to standard output encoded in base64 with a crlf every 76 characters." } ;
ARTICLE: "base64" "Base 64 conversions"
"The " { $vocab-link "base64" } " vocabulary implements conversions of sequences to printable characters in base 64. These plain-text representations of binary data may be passed around and converted back to binary data later." $nl
-"Converting to base 64:"
+"Converting to and from base64 as strings:"
{ $subsection >base64 }
-"Converting back to binary:"
-{ $subsection base64> } ;
+{ $subsection >base64-lines }
+{ $subsection base64> }
+"Using base64 from streams:"
+{ $subsection encode-base64 }
+{ $subsection encode-base64-lines }
+{ $subsection decode-base64 } ;
ABOUT: "base64"
diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor
index 9958e7943f..dcc4aa5240 100644
--- a/basis/base64/base64-tests.factor
+++ b/basis/base64/base64-tests.factor
@@ -1,4 +1,4 @@
-USING: kernel tools.test base64 strings ;
+USING: kernel tools.test base64 strings sequences ;
IN: base64.tests
[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
@@ -7,6 +7,7 @@ IN: base64.tests
[ "a" ] [ "a" >base64 base64> >string ] unit-test
[ "ab" ] [ "ab" >base64 base64> >string ] unit-test
[ "abc" ] [ "abc" >base64 base64> >string ] unit-test
+[ "abcde" ] [ "abcde" >base64 3 cut "\r\n" swap 3append base64> >string ] unit-test
! From http://en.wikipedia.org/wiki/Base64
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
@@ -15,5 +16,11 @@ IN: base64.tests
>base64 >string
] unit-test
+[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
+[
+ "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
+ >base64-lines >string
+] unit-test
+
\ >base64 must-infer
\ base64> must-infer
diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor
index e3033a2bde..a1668e7ce9 100644
--- a/basis/base64/base64.factor
+++ b/basis/base64/base64.factor
@@ -1,16 +1,22 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences io.binary splitting grouping
-accessors ;
+USING: combinators io io.binary io.encodings.binary
+io.streams.byte-array io.streams.string kernel math namespaces
+sequences strings io.crlf ;
IN: base64
> length ] [ to>> ] bi - ; inline
+: read1-ignoring ( ignoring -- ch )
+ read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
+
+: read-ignoring ( ignoring n -- str )
+ [ drop read1-ignoring ] with map harvest
+ [ f ] [ >string ] if-empty ;
: ch>base64 ( ch -- ch )
- "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
+ "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+ nth ; inline
: base64>ch ( ch -- ch )
{
@@ -19,32 +25,60 @@ IN: base64
f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
40 41 42 43 44 45 46 47 48 49 50 51
- } nth ;
+ } nth ; inline
+
+SYMBOL: column
+
+: write1-lines ( ch -- )
+ write1
+ column get [
+ 1+ [ 76 = [ crlf ] when ]
+ [ 76 mod column set ] bi
+ ] when* ;
-: encode3 ( seq -- seq )
+: write-lines ( str -- )
+ [ write1-lines ] each ;
+
+: encode3 ( seq -- )
be> 4 [
- -6 * shift HEX: 3f bitand ch>base64
- ] with B{ } map-as ;
+ -6 * shift HEX: 3f bitand ch>base64 write1-lines
+ ] with each ; inline
+
+: encode-pad ( seq n -- )
+ [ 3 0 pad-right binary [ encode3 ] with-byte-writer ]
+ [ 1+ ] bi* head-slice 4 CHAR: = pad-right write-lines ; inline
-: decode4 ( str -- str )
- 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
+ERROR: malformed-base64 ;
-: >base64-rem ( str -- str )
- [ 3 0 pad-right encode3 ] [ length 1+ ] bi
- head-slice 4 CHAR: = pad-right ;
+: decode4 ( seq -- )
+ [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
+ [ [ CHAR: = = ] count ] bi head-slice*
+ [ write1 ] each ; inline
PRIVATE>
+: encode-base64 ( -- )
+ 3 read dup length {
+ { 0 [ drop ] }
+ { 3 [ encode3 encode-base64 ] }
+ [ encode-pad encode-base64 ]
+ } case ;
+
+: encode-base64-lines ( -- )
+ 0 column [ encode-base64 ] with-variable ;
+
+: decode-base64 ( -- )
+ "\n\r" 4 read-ignoring dup length {
+ { 0 [ drop ] }
+ { 4 [ decode4 decode-base64 ] }
+ [ malformed-base64 ]
+ } case ;
+
: >base64 ( seq -- base64 )
- #! cut string into two pieces, convert 3 bytes at a time
- #! pad string with = when not enough bits
- dup length dup 3 mod - cut
- [ 3 [ encode3 ] map concat ]
- [ [ "" ] [ >base64-rem ] if-empty ]
- bi* append ;
+ binary [ [ encode-base64 ] with-string-reader ] with-byte-writer ;
: base64> ( base64 -- seq )
- #! input length must be a multiple of 4
- [ 4 [ decode4 ] map concat ]
- [ [ CHAR: = = ] count-end ]
- bi head* ;
+ [ binary [ decode-base64 ] with-byte-reader ] with-string-writer ;
+
+: >base64-lines ( seq -- base64 )
+ binary [ [ encode-base64-lines ] with-string-reader ] with-byte-writer ;
diff --git a/basis/base64/tags.txt b/basis/base64/tags.txt
new file mode 100644
index 0000000000..8fd3eccc9a
--- /dev/null
+++ b/basis/base64/tags.txt
@@ -0,0 +1,2 @@
+parsing
+web
diff --git a/basis/bit-arrays/bit-arrays-tests.factor b/basis/bit-arrays/bit-arrays-tests.factor
index a5ae23dde6..1de49d353d 100644
--- a/basis/bit-arrays/bit-arrays-tests.factor
+++ b/basis/bit-arrays/bit-arrays-tests.factor
@@ -76,3 +76,7 @@ IN: bit-arrays.tests
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t t
} bit-array>integer ] unit-test
+
+[ 49 ] [ 49 dup set-bits [ ] count ] unit-test
+
+[ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test
diff --git a/basis/bit-arrays/bit-arrays.factor b/basis/bit-arrays/bit-arrays.factor
index d407f0b84d..f1ba71ce1e 100644
--- a/basis/bit-arrays/bit-arrays.factor
+++ b/basis/bit-arrays/bit-arrays.factor
@@ -11,7 +11,7 @@ TUPLE: bit-array
byte -3 shift ; inline
+: n>byte ( m -- n ) -3 shift ; inline
: byte/bit ( n alien -- byte bit )
over n>byte alien-unsigned-1 swap 7 bitand ; inline
@@ -19,13 +19,13 @@ TUPLE: bit-array
: set-bit ( ? byte bit -- byte )
2^ rot [ bitor ] [ bitnot bitand ] if ; inline
-: bits>cells 31 + -5 shift ; inline
+: bits>cells ( m -- n ) 31 + -5 shift ; inline
-: bits>bytes 7 + n>byte ; inline
+: bits>bytes ( m -- n ) 7 + n>byte ; inline
: (set-bits) ( bit-array n -- )
[ [ length bits>cells ] keep ] dip swap underlying>>
- '[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
+ '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
PRIVATE>
@@ -83,7 +83,7 @@ M: bit-array byte-length length 7 + -3 shift ;
] if ;
: bit-array>integer ( bit-array -- n )
- 0 swap underlying>> dup length [
+ 0 swap underlying>> dup length [
alien-unsigned-1 swap 8 shift bitor
] with each ;
diff --git a/basis/bootstrap/compiler/compiler.factor b/basis/bootstrap/compiler/compiler.factor
index f0d9e8e131..617073bbc4 100644
--- a/basis/bootstrap/compiler/compiler.factor
+++ b/basis/bootstrap/compiler/compiler.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors compiler cpu.architecture vocabs.loader system
sequences namespaces parser kernel kernel.private classes
@@ -25,8 +25,8 @@ IN: bootstrap.compiler
enable-compiler
-: compile-uncompiled ( words -- )
- [ compiled>> not ] filter compile ;
+: compile-unoptimized ( words -- )
+ [ optimized>> not ] filter compile ;
nl
"Compiling..." write flush
@@ -48,70 +48,70 @@ nl
wrap probe
namestack*
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
bitand bitor bitxor bitnot
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
+ 1+ 1- 2/ < <= > >= shift
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
new-sequence nth push pop peek flip
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
hashcode* = get set
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
memq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
lines prefix suffix unclip new-assoc update
word-prop set-word-prop 1array 2array 3array ?nth
-} compile-uncompiled
+} compile-unoptimized
"." write flush
{
malloc calloc free memcpy
-} compile-uncompiled
+} compile-unoptimized
"." write flush
-{ build-tree } compile-uncompiled
+{ build-tree } compile-unoptimized
"." write flush
-{ optimize-tree } compile-uncompiled
+{ optimize-tree } compile-unoptimized
"." write flush
-{ optimize-cfg } compile-uncompiled
+{ optimize-cfg } compile-unoptimized
"." write flush
-{ (compile) } compile-uncompiled
+{ (compile) } compile-unoptimized
"." write flush
-vocabs [ words compile-uncompiled "." write flush ] each
+vocabs [ words compile-unoptimized "." write flush ] each
" done" print flush
diff --git a/basis/bootstrap/finish-bootstrap.factor b/basis/bootstrap/finish-bootstrap.factor
index 133b64acaa..36f6291bc6 100644
--- a/basis/bootstrap/finish-bootstrap.factor
+++ b/basis/bootstrap/finish-bootstrap.factor
@@ -12,5 +12,6 @@ namespaces eval kernel vocabs.loader io ;
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*
+ 0 exit
] [ print-error 1 exit ] recover
] set-boot-quot
diff --git a/basis/bootstrap/finish-staging.factor b/basis/bootstrap/finish-staging.factor
index a60ce04e15..49f504fd41 100644
--- a/basis/bootstrap/finish-staging.factor
+++ b/basis/bootstrap/finish-staging.factor
@@ -7,4 +7,5 @@ io ;
(command-line) parse-command-line
"run" get run
output-stream get [ stream-flush ] when*
+ 0 exit
] set-boot-quot
diff --git a/basis/bootstrap/help/help.factor b/basis/bootstrap/help/help.factor
index 5b49ce2802..145738ff45 100644
--- a/basis/bootstrap/help/help.factor
+++ b/basis/bootstrap/help/help.factor
@@ -4,6 +4,7 @@ parser vocabs.loader vocabs.loader.private accessors assocs ;
IN: bootstrap.help
: load-help ( -- )
+ "help.lint" require
"alien.syntax" require
"compiler" require
diff --git a/basis/bootstrap/image/image-docs.factor b/basis/bootstrap/image/image-docs.factor
index 91aa22b738..3856382ffb 100644
--- a/basis/bootstrap/image/image-docs.factor
+++ b/basis/bootstrap/image/image-docs.factor
@@ -1,4 +1,4 @@
-USING: help.markup help.syntax io io.files ;
+USING: help.markup help.syntax io io.files io.pathnames ;
IN: bootstrap.image
ARTICLE: "bootstrap.image" "Bootstrapping new images"
diff --git a/basis/bootstrap/image/image.factor b/basis/bootstrap/image/image.factor
index c7d87776a1..513b8972a6 100644
--- a/basis/bootstrap/image/image.factor
+++ b/basis/bootstrap/image/image.factor
@@ -1,15 +1,16 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays generic assocs hashtables assocs
-hashtables.private io kernel kernel.private math namespaces make
-parser prettyprint sequences sequences.private strings sbufs
+hashtables.private io io.binary io.files io.encodings.binary
+io.pathnames kernel kernel.private math namespaces make parser
+prettyprint sequences sequences.private strings sbufs
vectors words quotations assocs system layouts splitting
grouping growable classes classes.builtin classes.tuple
-classes.tuple.private words.private io.binary io.files vocabs
+classes.tuple.private words.private vocabs
vocabs.loader source-files definitions debugger
quotations.private sequences.private combinators
-io.encodings.binary math.order math.private accessors
-slots.private compiler.units ;
+math.order math.private accessors
+slots.private compiler.units fry ;
IN: bootstrap.image
: arch ( os cpu -- arch )
@@ -65,14 +66,14 @@ M: id equal?
SYMBOL: objects
-: (objects) objects get ; inline
+: (objects) ( obj -- id assoc ) objects get ; inline
: lookup-object ( obj -- n/f ) (objects) at ;
: put-object ( n obj -- ) (objects) set-at ;
: cache-object ( obj quot -- value )
- [ (objects) ] dip [ obj>> ] prepose cache ; inline
+ [ (objects) ] dip '[ obj>> @ ] cache ; inline
! Constants
@@ -94,7 +95,7 @@ SYMBOL: objects
SYMBOL: sub-primitives
: make-jit ( quot rc rt offset -- quad )
- { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
+ [ { } make ] 3dip 4array ; inline
: jit-define ( quot rc rt offset name -- )
[ make-jit ] dip set ; inline
@@ -343,25 +344,37 @@ M: wrapper '
[ emit ] emit-object ;
! Strings
+: native> ( object -- object )
+ big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
+
: emit-bytes ( seq -- )
- bootstrap-cell
- big-endian get [ [ be> ] map ] [ [ le> ] map ] if
- emit-seq ;
+ bootstrap-cell native> emit-seq ;
: pad-bytes ( seq -- newseq )
dup length bootstrap-cell align 0 pad-right ;
-: check-string ( string -- )
- [ 127 > ] contains?
- [ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
+: extended-part ( str -- str' )
+ dup [ 128 < ] all? [ drop f ] [
+ [ -7 shift 1 bitxor ] { } map-as
+ big-endian get
+ [ [ 2 >be ] { } map-as ]
+ [ [ 2 >le ] { } map-as ] if
+ B{ } join
+ ] if ;
+
+: ascii-part ( str -- str' )
+ [
+ [ 128 mod ] [ 128 >= ] bi
+ [ 128 bitor ] when
+ ] B{ } map-as ;
: emit-string ( string -- ptr )
- dup check-string
+ [ length ] [ extended-part ' ] [ ] tri
string type-number object tag-number [
- dup length emit-fixnum
- f ' emit
- f ' emit
- pad-bytes emit-bytes
+ [ emit-fixnum ]
+ [ emit ]
+ [ f ' emit ascii-part pad-bytes emit-bytes ]
+ tri*
] emit-object ;
M: string '
@@ -432,7 +445,7 @@ M: quotation '
array>> '
quotation type-number object tag-number [
emit ! array
- f ' emit ! compiled>>
+ f ' emit ! compiled
0 emit ! xt
0 emit ! code
] emit-object
@@ -523,11 +536,9 @@ M: quotation '
! Image output
: (write-image) ( image -- )
- bootstrap-cell big-endian get [
- [ >be write ] curry each
- ] [
- [ >le write ] curry each
- ] if ;
+ bootstrap-cell big-endian get
+ [ '[ _ >be write ] each ]
+ [ '[ _ >le write ] each ] if ;
: write-image ( image -- )
"Writing image to " write
diff --git a/basis/bootstrap/image/upload/upload.factor b/basis/bootstrap/image/upload/upload.factor
index f0edf85e65..d70a253e5f 100644
--- a/basis/bootstrap/image/upload/upload.factor
+++ b/basis/bootstrap/image/upload/upload.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: checksums checksums.openssl splitting assocs
kernel io.files bootstrap.image sequences io namespaces make
-io.launcher math io.encodings.ascii ;
+io.launcher math io.encodings.ascii io.files.temp io.pathnames
+io.directories ;
IN: bootstrap.image.upload
SYMBOL: upload-images-destination
diff --git a/basis/bootstrap/io/io.factor b/basis/bootstrap/io/io.factor
index a38107fbab..b9a49b48b8 100644
--- a/basis/bootstrap/io/io.factor
+++ b/basis/bootstrap/io/io.factor
@@ -1,12 +1,11 @@
USING: system vocabs vocabs.loader kernel combinators
-namespaces sequences io.backend ;
+namespaces sequences io.backend accessors ;
IN: bootstrap.io
"bootstrap.compiler" vocab [
- "io." {
+ "io.backend." {
{ [ "io-backend" get ] [ "io-backend" get ] }
- { [ os unix? ] [ "unix" ] }
+ { [ os unix? ] [ "unix." os name>> append ] }
{ [ os winnt? ] [ "windows.nt" ] }
- { [ os wince? ] [ "windows.ce" ] }
} cond append require
] when
diff --git a/basis/bootstrap/math/math.factor b/basis/bootstrap/math/math.factor
index 347969af0d..27b2f6b181 100644
--- a/basis/bootstrap/math/math.factor
+++ b/basis/bootstrap/math/math.factor
@@ -2,6 +2,4 @@ USING: vocabs vocabs.loader kernel ;
"math.ratios" require
"math.floats" require
-"math.complex" require
-
-"prettyprint" vocab [ "math.complex.prettyprint" require ] when
+"math.complex" require
\ No newline at end of file
diff --git a/basis/bootstrap/stage2.factor b/basis/bootstrap/stage2.factor
index fb7292b989..b521244fe0 100644
--- a/basis/bootstrap/stage2.factor
+++ b/basis/bootstrap/stage2.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors init namespaces words io
+USING: accessors init namespaces words words.symbol io
kernel.private math memory continuations kernel io.files
-io.backend system parser vocabs sequences
+io.pathnames io.backend system parser vocabs sequences
vocabs.loader combinators splitting source-files strings
-definitions assocs compiler.errors compiler.units
-math.parser generic sets command-line ;
+definitions assocs compiler.errors compiler.units math.parser
+generic sets command-line ;
IN: bootstrap.stage2
SYMBOL: core-bootstrap-time
@@ -13,7 +13,7 @@ SYMBOL: core-bootstrap-time
SYMBOL: bootstrap-time
: default-image-name ( -- string )
- vm file-name os windows? [ "." split1 drop ] when
+ vm file-name os windows? [ "." split1-last drop ] when
".image" append resource-path ;
: do-crossref ( -- )
@@ -42,7 +42,7 @@ SYMBOL: bootstrap-time
"Core bootstrap completed in " write core-bootstrap-time get print-time
"Bootstrap completed in " write bootstrap-time get print-time
- [ compiled>> ] count-words " compiled words" print
+ [ optimized>> ] count-words " compiled words" print
[ symbol? ] count-words " symbol words" print
[ ] count-words " words total" print
@@ -102,6 +102,8 @@ SYMBOL: bootstrap-time
] if
] [
drop
- load-help? off
- "resource:basis/bootstrap/bootstrap-error.factor" run-file
+ [
+ load-help? off
+ "resource:basis/bootstrap/bootstrap-error.factor" run-file
+ ] with-scope
] recover
diff --git a/basis/bootstrap/threads/threads.factor b/basis/bootstrap/threads/threads.factor
index 8b751f8458..24cbba6af8 100644
--- a/basis/bootstrap/threads/threads.factor
+++ b/basis/bootstrap/threads/threads.factor
@@ -1,11 +1,11 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: vocabs vocabs.loader kernel ;
+USING: vocabs vocabs.loader kernel io.thread threads
+compiler.utilities namespaces ;
IN: bootstrap.threads
-USE: io.thread
-USE: threads
-
"debugger" vocab [
"debugger.threads" require
] when
+
+[ yield ] yield-hook set-global
\ No newline at end of file
diff --git a/basis/bootstrap/unicode/unicode.factor b/basis/bootstrap/unicode/unicode.factor
index 1046d41bdc..3530c9d99f 100644
--- a/basis/bootstrap/unicode/unicode.factor
+++ b/basis/bootstrap/unicode/unicode.factor
@@ -1,5 +1 @@
-USING: strings.parser kernel namespaces unicode.data ;
-IN: bootstrap.unicode
-
-[ name>char [ "Invalid character" throw ] unless* ]
-name>char-hook set-global
+USE: unicode
\ No newline at end of file
diff --git a/basis/cairo/authors.txt b/basis/cairo/authors.txt
new file mode 100644
index 0000000000..68d35d192b
--- /dev/null
+++ b/basis/cairo/authors.txt
@@ -0,0 +1,2 @@
+Sampo Vuori
+Doug Coleman
diff --git a/basis/cairo/cairo.factor b/basis/cairo/cairo.factor
new file mode 100755
index 0000000000..da7f5a2f32
--- /dev/null
+++ b/basis/cairo/cairo.factor
@@ -0,0 +1,37 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: cairo.ffi kernel accessors sequences
+namespaces fry continuations destructors ;
+IN: cairo
+
+TUPLE: cairo-t alien ;
+C: cairo-t
+M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
+
+TUPLE: cairo-surface-t alien ;
+C: cairo-surface-t
+M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
+
+: check-cairo ( cairo_status_t -- )
+ dup CAIRO_STATUS_SUCCESS = [ drop ]
+ [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
+
+SYMBOL: cairo
+: cr ( -- cairo ) cairo get ; inline
+
+: (with-cairo) ( cairo-t quot -- )
+ [ alien>> cairo ] dip
+ '[ @ cr cairo_status check-cairo ]
+ with-variable ; inline
+
+: with-cairo ( cairo quot -- )
+ [ ] dip '[ _ (with-cairo) ] with-disposal ; inline
+
+: (with-surface) ( cairo-surface-t quot -- )
+ [ alien>> ] dip [ cairo_surface_status check-cairo ] bi ; inline
+
+: with-surface ( cairo_surface quot -- )
+ [ ] dip '[ _ (with-surface) ] with-disposal ; inline
+
+: with-cairo-from-surface ( cairo_surface quot -- )
+ '[ cairo_create _ with-cairo ] with-surface ; inline
diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor
new file mode 100644
index 0000000000..d29a3fb097
--- /dev/null
+++ b/basis/cairo/ffi/ffi.factor
@@ -0,0 +1,948 @@
+! Copyright (c) 2007 Sampo Vuori
+! Copyright (c) 2008 Matthew Willis
+!
+! Adapted from cairo.h, version 1.5.14
+! License: http://factorcode.org/license.txt
+
+USING: system combinators alien alien.syntax kernel
+alien.c-types accessors sequences arrays ui.gadgets ;
+
+IN: cairo.ffi
+<< "cairo" {
+ { [ os winnt? ] [ "libcairo-2.dll" ] }
+ { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
+ { [ os unix? ] [ "libcairo.so.2" ] }
+} cond "cdecl" add-library >>
+
+LIBRARY: cairo
+
+FUNCTION: int cairo_version ( ) ;
+FUNCTION: char* cairo_version_string ( ) ;
+
+TYPEDEF: int cairo_bool_t
+
+! I am leaving these and other void* types as opaque structures
+TYPEDEF: void* cairo_t
+TYPEDEF: void* cairo_surface_t
+
+C-STRUCT: cairo_matrix_t
+ { "double" "xx" }
+ { "double" "yx" }
+ { "double" "xy" }
+ { "double" "yy" }
+ { "double" "x0" }
+ { "double" "y0" } ;
+
+TYPEDEF: void* cairo_pattern_t
+
+TYPEDEF: void* cairo_destroy_func_t
+: cairo-destroy-func ( quot -- callback )
+ [ "void" { "void*" } "cdecl" ] dip alien-callback ; inline
+
+! See cairo.h for details
+C-STRUCT: cairo_user_data_key_t
+ { "int" "unused" } ;
+
+TYPEDEF: int cairo_status_t
+C-ENUM:
+ CAIRO_STATUS_SUCCESS
+ CAIRO_STATUS_NO_MEMORY
+ CAIRO_STATUS_INVALID_RESTORE
+ CAIRO_STATUS_INVALID_POP_GROUP
+ CAIRO_STATUS_NO_CURRENT_POINT
+ CAIRO_STATUS_INVALID_MATRIX
+ CAIRO_STATUS_INVALID_STATUS
+ CAIRO_STATUS_NULL_POINTER
+ CAIRO_STATUS_INVALID_STRING
+ CAIRO_STATUS_INVALID_PATH_DATA
+ CAIRO_STATUS_READ_ERROR
+ CAIRO_STATUS_WRITE_ERROR
+ CAIRO_STATUS_SURFACE_FINISHED
+ CAIRO_STATUS_SURFACE_TYPE_MISMATCH
+ CAIRO_STATUS_PATTERN_TYPE_MISMATCH
+ CAIRO_STATUS_INVALID_CONTENT
+ CAIRO_STATUS_INVALID_FORMAT
+ CAIRO_STATUS_INVALID_VISUAL
+ CAIRO_STATUS_FILE_NOT_FOUND
+ CAIRO_STATUS_INVALID_DASH
+ CAIRO_STATUS_INVALID_DSC_COMMENT
+ CAIRO_STATUS_INVALID_INDEX
+ CAIRO_STATUS_CLIP_NOT_REPRESENTABLE
+ CAIRO_STATUS_TEMP_FILE_ERROR
+ CAIRO_STATUS_INVALID_STRIDE ;
+
+TYPEDEF: int cairo_content_t
+: CAIRO_CONTENT_COLOR HEX: 1000 ;
+: CAIRO_CONTENT_ALPHA HEX: 2000 ;
+: CAIRO_CONTENT_COLOR_ALPHA HEX: 3000 ;
+
+TYPEDEF: void* cairo_write_func_t
+: cairo-write-func ( quot -- callback )
+ [ "cairo_status_t" { "void*" "uchar*" "int" } "cdecl" ] dip alien-callback ; inline
+
+TYPEDEF: void* cairo_read_func_t
+: cairo-read-func ( quot -- callback )
+ [ "cairo_status_t" { "void*" "uchar*" "int" } "cdecl" ] dip alien-callback ; inline
+
+! Functions for manipulating state objects
+FUNCTION: cairo_t*
+cairo_create ( cairo_surface_t* target ) ;
+
+FUNCTION: cairo_t*
+cairo_reference ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_destroy ( cairo_t* cr ) ;
+
+FUNCTION: uint
+cairo_get_reference_count ( cairo_t* cr ) ;
+
+FUNCTION: void*
+cairo_get_user_data ( cairo_t* cr, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_set_user_data ( cairo_t* cr, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_save ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_restore ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_push_group ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_push_group_with_content ( cairo_t* cr, cairo_content_t content ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pop_group ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_pop_group_to_source ( cairo_t* cr ) ;
+
+! Modify state
+TYPEDEF: int cairo_operator_t
+C-ENUM:
+ CAIRO_OPERATOR_CLEAR
+
+ CAIRO_OPERATOR_SOURCE
+ CAIRO_OPERATOR_OVER
+ CAIRO_OPERATOR_IN
+ CAIRO_OPERATOR_OUT
+ CAIRO_OPERATOR_ATOP
+
+ CAIRO_OPERATOR_DEST
+ CAIRO_OPERATOR_DEST_OVER
+ CAIRO_OPERATOR_DEST_IN
+ CAIRO_OPERATOR_DEST_OUT
+ CAIRO_OPERATOR_DEST_ATOP
+
+ CAIRO_OPERATOR_XOR
+ CAIRO_OPERATOR_ADD
+ CAIRO_OPERATOR_SATURATE ;
+
+FUNCTION: void
+cairo_set_operator ( cairo_t* cr, cairo_operator_t op ) ;
+
+FUNCTION: void
+cairo_set_source ( cairo_t* cr, cairo_pattern_t* source ) ;
+
+FUNCTION: void
+cairo_set_source_rgb ( cairo_t* cr, double red, double green, double blue ) ;
+
+FUNCTION: void
+cairo_set_source_rgba ( cairo_t* cr, double red, double green, double blue, double alpha ) ;
+
+FUNCTION: void
+cairo_set_source_surface ( cairo_t* cr, cairo_surface_t* surface, double x, double y ) ;
+
+FUNCTION: void
+cairo_set_tolerance ( cairo_t* cr, double tolerance ) ;
+
+TYPEDEF: int cairo_antialias_t
+C-ENUM:
+ CAIRO_ANTIALIAS_DEFAULT
+ CAIRO_ANTIALIAS_NONE
+ CAIRO_ANTIALIAS_GRAY
+ CAIRO_ANTIALIAS_SUBPIXEL ;
+
+FUNCTION: void
+cairo_set_antialias ( cairo_t* cr, cairo_antialias_t antialias ) ;
+
+TYPEDEF: int cairo_fill_rule_t
+C-ENUM:
+ CAIRO_FILL_RULE_WINDING
+ CAIRO_FILL_RULE_EVEN_ODD ;
+
+FUNCTION: void
+cairo_set_fill_rule ( cairo_t* cr, cairo_fill_rule_t fill_rule ) ;
+
+FUNCTION: void
+cairo_set_line_width ( cairo_t* cr, double width ) ;
+
+TYPEDEF: int cairo_line_cap_t
+C-ENUM:
+ CAIRO_LINE_CAP_BUTT
+ CAIRO_LINE_CAP_ROUND
+ CAIRO_LINE_CAP_SQUARE ;
+
+FUNCTION: void
+cairo_set_line_cap ( cairo_t* cr, cairo_line_cap_t line_cap ) ;
+
+TYPEDEF: int cairo_line_join_t
+C-ENUM:
+ CAIRO_LINE_JOIN_MITER
+ CAIRO_LINE_JOIN_ROUND
+ CAIRO_LINE_JOIN_BEVEL ;
+
+FUNCTION: void
+cairo_set_line_join ( cairo_t* cr, cairo_line_join_t line_join ) ;
+
+FUNCTION: void
+cairo_set_dash ( cairo_t* cr, double* dashes, int num_dashes, double offset ) ;
+
+FUNCTION: void
+cairo_set_miter_limit ( cairo_t* cr, double limit ) ;
+
+FUNCTION: void
+cairo_translate ( cairo_t* cr, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_scale ( cairo_t* cr, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_rotate ( cairo_t* cr, double angle ) ;
+
+FUNCTION: void
+cairo_transform ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_set_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_identity_matrix ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_user_to_device ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: void
+cairo_user_to_device_distance ( cairo_t* cr, double* dx, double* dy ) ;
+
+FUNCTION: void
+cairo_device_to_user ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: void
+cairo_device_to_user_distance ( cairo_t* cr, double* dx, double* dy ) ;
+
+! Path creation functions
+FUNCTION: void
+cairo_new_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_move_to ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: void
+cairo_new_sub_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_line_to ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: void
+cairo_curve_to ( cairo_t* cr, double x1, double y1, double x2, double y2, double x3, double y3 ) ;
+
+FUNCTION: void
+cairo_arc ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
+
+FUNCTION: void
+cairo_arc_negative ( cairo_t* cr, double xc, double yc, double radius, double angle1, double angle2 ) ;
+
+FUNCTION: void
+cairo_rel_move_to ( cairo_t* cr, double dx, double dy ) ;
+
+FUNCTION: void
+cairo_rel_line_to ( cairo_t* cr, double dx, double dy ) ;
+
+FUNCTION: void
+cairo_rel_curve_to ( cairo_t* cr, double dx1, double dy1, double dx2, double dy2, double dx3, double dy3 ) ;
+
+FUNCTION: void
+cairo_rectangle ( cairo_t* cr, double x, double y, double width, double height ) ;
+
+FUNCTION: void
+cairo_close_path ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_path_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+! Painting functions
+FUNCTION: void
+cairo_paint ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_paint_with_alpha ( cairo_t* cr, double alpha ) ;
+
+FUNCTION: void
+cairo_mask ( cairo_t* cr, cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_mask_surface ( cairo_t* cr, cairo_surface_t* surface, double surface_x, double surface_y ) ;
+
+FUNCTION: void
+cairo_stroke ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_stroke_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_fill ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_fill_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_copy_page ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_show_page ( cairo_t* cr ) ;
+
+! Insideness testing
+FUNCTION: cairo_bool_t
+cairo_in_stroke ( cairo_t* cr, double x, double y ) ;
+
+FUNCTION: cairo_bool_t
+cairo_in_fill ( cairo_t* cr, double x, double y ) ;
+
+! Rectangular extents
+FUNCTION: void
+cairo_stroke_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+FUNCTION: void
+cairo_fill_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+! Clipping
+FUNCTION: void
+cairo_reset_clip ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip_preserve ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_clip_extents ( cairo_t* cr, double* x1, double* y1, double* x2, double* y2 ) ;
+
+C-STRUCT: cairo_rectangle_t
+ { "double" "x" }
+ { "double" "y" }
+ { "double" "width" }
+ { "double" "height" } ;
+
+C-STRUCT: cairo_rectangle_list_t
+ { "cairo_status_t" "status" }
+ { "cairo_rectangle_t*" "rectangles" }
+ { "int" "num_rectangles" } ;
+
+FUNCTION: cairo_rectangle_list_t*
+cairo_copy_clip_rectangle_list ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_rectangle_list_destroy ( cairo_rectangle_list_t* rectangle_list ) ;
+
+! Font/Text functions
+
+TYPEDEF: void* cairo_scaled_font_t
+
+TYPEDEF: void* cairo_font_face_t
+
+C-STRUCT: cairo_glyph_t
+ { "ulong" "index" }
+ { "double" "x" }
+ { "double" "y" } ;
+
+C-STRUCT: cairo_text_extents_t
+ { "double" "x_bearing" }
+ { "double" "y_bearing" }
+ { "double" "width" }
+ { "double" "height" }
+ { "double" "x_advance" }
+ { "double" "y_advance" } ;
+
+C-STRUCT: cairo_font_extents_t
+ { "double" "ascent" }
+ { "double" "descent" }
+ { "double" "height" }
+ { "double" "max_x_advance" }
+ { "double" "max_y_advance" } ;
+
+TYPEDEF: int cairo_font_slant_t
+C-ENUM:
+ CAIRO_FONT_SLANT_NORMAL
+ CAIRO_FONT_SLANT_ITALIC
+ CAIRO_FONT_SLANT_OBLIQUE ;
+
+TYPEDEF: int cairo_font_weight_t
+C-ENUM:
+ CAIRO_FONT_WEIGHT_NORMAL
+ CAIRO_FONT_WEIGHT_BOLD ;
+
+TYPEDEF: int cairo_subpixel_order_t
+C-ENUM:
+ CAIRO_SUBPIXEL_ORDER_DEFAULT
+ CAIRO_SUBPIXEL_ORDER_RGB
+ CAIRO_SUBPIXEL_ORDER_BGR
+ CAIRO_SUBPIXEL_ORDER_VRGB
+ CAIRO_SUBPIXEL_ORDER_VBGR ;
+
+TYPEDEF: int cairo_hint_style_t
+C-ENUM:
+ CAIRO_HINT_STYLE_DEFAULT
+ CAIRO_HINT_STYLE_NONE
+ CAIRO_HINT_STYLE_SLIGHT
+ CAIRO_HINT_STYLE_MEDIUM
+ CAIRO_HINT_STYLE_FULL ;
+
+TYPEDEF: int cairo_hint_metrics_t
+C-ENUM:
+ CAIRO_HINT_METRICS_DEFAULT
+ CAIRO_HINT_METRICS_OFF
+ CAIRO_HINT_METRICS_ON ;
+
+TYPEDEF: void* cairo_font_options_t
+
+FUNCTION: cairo_font_options_t*
+cairo_font_options_create ( ) ;
+
+FUNCTION: cairo_font_options_t*
+cairo_font_options_copy ( cairo_font_options_t* original ) ;
+
+FUNCTION: void
+cairo_font_options_destroy ( cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_options_status ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_merge ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
+
+FUNCTION: cairo_bool_t
+cairo_font_options_equal ( cairo_font_options_t* options, cairo_font_options_t* other ) ;
+
+FUNCTION: ulong
+cairo_font_options_hash ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_antialias ( cairo_font_options_t* options, cairo_antialias_t antialias ) ;
+
+FUNCTION: cairo_antialias_t
+cairo_font_options_get_antialias ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_subpixel_order ( cairo_font_options_t* options, cairo_subpixel_order_t subpixel_order ) ;
+
+FUNCTION: cairo_subpixel_order_t
+cairo_font_options_get_subpixel_order ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_hint_style ( cairo_font_options_t* options, cairo_hint_style_t hint_style ) ;
+
+FUNCTION: cairo_hint_style_t
+cairo_font_options_get_hint_style ( cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_font_options_set_hint_metrics ( cairo_font_options_t* options, cairo_hint_metrics_t hint_metrics ) ;
+
+FUNCTION: cairo_hint_metrics_t
+cairo_font_options_get_hint_metrics ( cairo_font_options_t* options ) ;
+
+! This interface is for dealing with text as text, not caring about the
+! font object inside the the cairo_t.
+
+FUNCTION: void
+cairo_select_font_face ( cairo_t* cr, char* family, cairo_font_slant_t slant, cairo_font_weight_t weight ) ;
+
+FUNCTION: void
+cairo_set_font_size ( cairo_t* cr, double size ) ;
+
+FUNCTION: void
+cairo_set_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_get_font_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_set_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_get_font_options ( cairo_t* cr, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_set_font_face ( cairo_t* cr, cairo_font_face_t* font_face ) ;
+
+FUNCTION: cairo_font_face_t*
+cairo_get_font_face ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_set_scaled_font ( cairo_t* cr, cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_scaled_font_t*
+cairo_get_scaled_font ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_show_text ( cairo_t* cr, char* utf8 ) ;
+
+FUNCTION: void
+cairo_show_glyphs ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
+
+FUNCTION: void
+cairo_text_path ( cairo_t* cr, char* utf8 ) ;
+
+FUNCTION: void
+cairo_glyph_path ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs ) ;
+
+FUNCTION: void
+cairo_text_extents ( cairo_t* cr, char* utf8, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_glyph_extents ( cairo_t* cr, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_font_extents ( cairo_t* cr, cairo_font_extents_t* extents ) ;
+
+! Generic identifier for a font style
+
+FUNCTION: cairo_font_face_t*
+cairo_font_face_reference ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: void
+cairo_font_face_destroy ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: uint
+cairo_font_face_get_reference_count ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_face_status ( cairo_font_face_t* font_face ) ;
+
+TYPEDEF: int cairo_font_type_t
+C-ENUM:
+ CAIRO_FONT_TYPE_TOY
+ CAIRO_FONT_TYPE_FT
+ CAIRO_FONT_TYPE_WIN32
+ CAIRO_FONT_TYPE_QUARTZ ;
+
+FUNCTION: cairo_font_type_t
+cairo_font_face_get_type ( cairo_font_face_t* font_face ) ;
+
+FUNCTION: void*
+cairo_font_face_get_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_font_face_set_user_data ( cairo_font_face_t* font_face, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+! Portable interface to general font features.
+
+FUNCTION: cairo_scaled_font_t*
+cairo_scaled_font_create ( cairo_font_face_t* font_face, cairo_matrix_t* font_matrix, cairo_matrix_t* ctm, cairo_font_options_t* options ) ;
+
+FUNCTION: cairo_scaled_font_t*
+cairo_scaled_font_reference ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void
+cairo_scaled_font_destroy ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: uint
+cairo_scaled_font_get_reference_count ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_status_t
+cairo_scaled_font_status ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: cairo_font_type_t
+cairo_scaled_font_get_type ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void*
+cairo_scaled_font_get_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_scaled_font_set_user_data ( cairo_scaled_font_t* scaled_font, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_scaled_font_extents ( cairo_scaled_font_t* scaled_font, cairo_font_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_scaled_font_text_extents ( cairo_scaled_font_t* scaled_font, char* utf8, cairo_text_extents_t* extents ) ;
+
+FUNCTION: void
+cairo_scaled_font_glyph_extents ( cairo_scaled_font_t* scaled_font, cairo_glyph_t* glyphs, int num_glyphs, cairo_text_extents_t* extents ) ;
+
+FUNCTION: cairo_font_face_t*
+cairo_scaled_font_get_font_face ( cairo_scaled_font_t* scaled_font ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_font_matrix ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* font_matrix ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_ctm ( cairo_scaled_font_t* scaled_font, cairo_matrix_t* ctm ) ;
+
+FUNCTION: void
+cairo_scaled_font_get_font_options ( cairo_scaled_font_t* scaled_font, cairo_font_options_t* options ) ;
+
+! Query functions
+
+FUNCTION: cairo_operator_t
+cairo_get_operator ( cairo_t* cr ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_get_source ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_tolerance ( cairo_t* cr ) ;
+
+FUNCTION: cairo_antialias_t
+cairo_get_antialias ( cairo_t* cr ) ;
+
+FUNCTION: cairo_bool_t
+cairo_has_current_point ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_get_current_point ( cairo_t* cr, double* x, double* y ) ;
+
+FUNCTION: cairo_fill_rule_t
+cairo_get_fill_rule ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_line_width ( cairo_t* cr ) ;
+
+FUNCTION: cairo_line_cap_t
+cairo_get_line_cap ( cairo_t* cr ) ;
+
+FUNCTION: cairo_line_join_t
+cairo_get_line_join ( cairo_t* cr ) ;
+
+FUNCTION: double
+cairo_get_miter_limit ( cairo_t* cr ) ;
+
+FUNCTION: int
+cairo_get_dash_count ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_get_dash ( cairo_t* cr, double* dashes, double* offset ) ;
+
+FUNCTION: void
+cairo_get_matrix ( cairo_t* cr, cairo_matrix_t* matrix ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_get_target ( cairo_t* cr ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_get_group_target ( cairo_t* cr ) ;
+
+TYPEDEF: int cairo_path_data_type_t
+C-ENUM:
+ CAIRO_PATH_MOVE_TO
+ CAIRO_PATH_LINE_TO
+ CAIRO_PATH_CURVE_TO
+ CAIRO_PATH_CLOSE_PATH ;
+
+! NEED TO DO UNION HERE
+C-STRUCT: cairo_path_data_t-point
+ { "double" "x" }
+ { "double" "y" } ;
+
+C-STRUCT: cairo_path_data_t-header
+ { "cairo_path_data_type_t" "type" }
+ { "int" "length" } ;
+
+C-UNION: cairo_path_data_t "cairo_path_data_t-point" "cairo_path_data_t-header" ;
+
+C-STRUCT: cairo_path_t
+ { "cairo_status_t" "status" }
+ { "cairo_path_data_t*" "data" }
+ { "int" "num_data" } ;
+
+FUNCTION: cairo_path_t*
+cairo_copy_path ( cairo_t* cr ) ;
+
+FUNCTION: cairo_path_t*
+cairo_copy_path_flat ( cairo_t* cr ) ;
+
+FUNCTION: void
+cairo_append_path ( cairo_t* cr, cairo_path_t* path ) ;
+
+FUNCTION: void
+cairo_path_destroy ( cairo_path_t* path ) ;
+
+! Error status queries
+
+FUNCTION: cairo_status_t
+cairo_status ( cairo_t* cr ) ;
+
+FUNCTION: char*
+cairo_status_to_string ( cairo_status_t status ) ;
+
+! Surface manipulation
+
+FUNCTION: cairo_surface_t*
+cairo_surface_create_similar ( cairo_surface_t* other, cairo_content_t content, int width, int height ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_surface_reference ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_finish ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_destroy ( cairo_surface_t* surface ) ;
+
+FUNCTION: uint
+cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_status ( cairo_surface_t* surface ) ;
+
+TYPEDEF: int cairo_surface_type_t
+C-ENUM:
+ CAIRO_SURFACE_TYPE_IMAGE
+ CAIRO_SURFACE_TYPE_PDF
+ CAIRO_SURFACE_TYPE_PS
+ CAIRO_SURFACE_TYPE_XLIB
+ CAIRO_SURFACE_TYPE_XCB
+ CAIRO_SURFACE_TYPE_GLITZ
+ CAIRO_SURFACE_TYPE_QUARTZ
+ CAIRO_SURFACE_TYPE_WIN32
+ CAIRO_SURFACE_TYPE_BEOS
+ CAIRO_SURFACE_TYPE_DIRECTFB
+ CAIRO_SURFACE_TYPE_SVG
+ CAIRO_SURFACE_TYPE_OS2
+ CAIRO_SURFACE_TYPE_WIN32_PRINTING
+ CAIRO_SURFACE_TYPE_QUARTZ_IMAGE ;
+
+FUNCTION: cairo_surface_type_t
+cairo_surface_get_type ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_content_t
+cairo_surface_get_content ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_write_to_png ( cairo_surface_t* surface, char* filename ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_write_to_png_stream ( cairo_surface_t* surface, cairo_write_func_t write_func, void* closure ) ;
+
+FUNCTION: void*
+cairo_surface_get_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_surface_set_user_data ( cairo_surface_t* surface, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+FUNCTION: void
+cairo_surface_get_font_options ( cairo_surface_t* surface, cairo_font_options_t* options ) ;
+
+FUNCTION: void
+cairo_surface_flush ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_mark_dirty ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_mark_dirty_rectangle ( cairo_surface_t* surface, int x, int y, int width, int height ) ;
+
+FUNCTION: void
+cairo_surface_set_device_offset ( cairo_surface_t* surface, double x_offset, double y_offset ) ;
+
+FUNCTION: void
+cairo_surface_get_device_offset ( cairo_surface_t* surface, double* x_offset, double* y_offset ) ;
+
+FUNCTION: void
+cairo_surface_set_fallback_resolution ( cairo_surface_t* surface, double x_pixels_per_inch, double y_pixels_per_inch ) ;
+
+FUNCTION: void
+cairo_surface_copy_page ( cairo_surface_t* surface ) ;
+
+FUNCTION: void
+cairo_surface_show_page ( cairo_surface_t* surface ) ;
+
+! Image-surface functions
+
+TYPEDEF: int cairo_format_t
+C-ENUM:
+ CAIRO_FORMAT_ARGB32
+ CAIRO_FORMAT_RGB24
+ CAIRO_FORMAT_A8
+ CAIRO_FORMAT_A1
+ CAIRO_FORMAT_RGB16_565 ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create ( cairo_format_t format, int width, int height ) ;
+
+FUNCTION: int
+cairo_format_stride_for_width ( cairo_format_t format, int width ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_for_data ( uchar* data, cairo_format_t format, int width, int height, int stride ) ;
+
+FUNCTION: uchar*
+cairo_image_surface_get_data ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_format_t
+cairo_image_surface_get_format ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_width ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_height ( cairo_surface_t* surface ) ;
+
+FUNCTION: int
+cairo_image_surface_get_stride ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_from_png ( char* filename ) ;
+
+FUNCTION: cairo_surface_t*
+cairo_image_surface_create_from_png_stream ( cairo_read_func_t read_func, void* closure ) ;
+
+! Pattern creation functions
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_rgb ( double red, double green, double blue ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_rgba ( double red, double green, double blue, double alpha ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_for_surface ( cairo_surface_t* surface ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_linear ( double x0, double y0, double x1, double y1 ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_create_radial ( double cx0, double cy0, double radius0, double cx1, double cy1, double radius1 ) ;
+
+FUNCTION: cairo_pattern_t*
+cairo_pattern_reference ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_pattern_destroy ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: uint
+cairo_pattern_get_reference_count ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_status ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void*
+cairo_pattern_get_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_set_user_data ( cairo_pattern_t* pattern, cairo_user_data_key_t* key, void* user_data, cairo_destroy_func_t destroy ) ;
+
+TYPEDEF: int cairo_pattern_type_t
+C-ENUM:
+ CAIRO_PATTERN_TYPE_SOLID
+ CAIRO_PATTERN_TYPE_SURFACE
+ CAIRO_PATTERN_TYPE_LINEAR
+ CAIRO_PATTERN_TYPE_RADIA ;
+
+FUNCTION: cairo_pattern_type_t
+cairo_pattern_get_type ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: void
+cairo_pattern_add_color_stop_rgb ( cairo_pattern_t* pattern, double offset, double red, double green, double blue ) ;
+
+FUNCTION: void
+cairo_pattern_add_color_stop_rgba ( cairo_pattern_t* pattern, double offset, double red, double green, double blue, double alpha ) ;
+
+FUNCTION: void
+cairo_pattern_set_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_pattern_get_matrix ( cairo_pattern_t* pattern, cairo_matrix_t* matrix ) ;
+
+TYPEDEF: int cairo_extend_t
+C-ENUM:
+ CAIRO_EXTEND_NONE
+ CAIRO_EXTEND_REPEAT
+ CAIRO_EXTEND_REFLECT
+ CAIRO_EXTEND_PAD ;
+
+FUNCTION: void
+cairo_pattern_set_extend ( cairo_pattern_t* pattern, cairo_extend_t extend ) ;
+
+FUNCTION: cairo_extend_t
+cairo_pattern_get_extend ( cairo_pattern_t* pattern ) ;
+
+TYPEDEF: int cairo_filter_t
+C-ENUM:
+ CAIRO_FILTER_FAST
+ CAIRO_FILTER_GOOD
+ CAIRO_FILTER_BEST
+ CAIRO_FILTER_NEAREST
+ CAIRO_FILTER_BILINEAR
+ CAIRO_FILTER_GAUSSIAN ;
+
+FUNCTION: void
+cairo_pattern_set_filter ( cairo_pattern_t* pattern, cairo_filter_t filter ) ;
+
+FUNCTION: cairo_filter_t
+cairo_pattern_get_filter ( cairo_pattern_t* pattern ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_rgba ( cairo_pattern_t* pattern, double* red, double* green, double* blue, double* alpha ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_surface ( cairo_pattern_t* pattern, cairo_surface_t* *surface ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_color_stop_rgba ( cairo_pattern_t* pattern, int index, double* offset, double* red, double* green, double* blue, double* alpha ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_color_stop_count ( cairo_pattern_t* pattern, int* count ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_linear_points ( cairo_pattern_t* pattern, double* x0, double* y0, double* x1, double* y1 ) ;
+
+FUNCTION: cairo_status_t
+cairo_pattern_get_radial_circles ( cairo_pattern_t* pattern, double* x0, double* y0, double* r0, double* x1, double* y1, double* r1 ) ;
+
+! Matrix functions
+
+FUNCTION: void
+cairo_matrix_init ( cairo_matrix_t* matrix, double xx, double yx, double xy, double yy, double x0, double y0 ) ;
+
+FUNCTION: void
+cairo_matrix_init_identity ( cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_matrix_init_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_matrix_init_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_matrix_init_rotate ( cairo_matrix_t* matrix, double radians ) ;
+
+FUNCTION: void
+cairo_matrix_translate ( cairo_matrix_t* matrix, double tx, double ty ) ;
+
+FUNCTION: void
+cairo_matrix_scale ( cairo_matrix_t* matrix, double sx, double sy ) ;
+
+FUNCTION: void
+cairo_matrix_rotate ( cairo_matrix_t* matrix, double radians ) ;
+
+FUNCTION: cairo_status_t
+cairo_matrix_invert ( cairo_matrix_t* matrix ) ;
+
+FUNCTION: void
+cairo_matrix_multiply ( cairo_matrix_t* result, cairo_matrix_t* a, cairo_matrix_t* b ) ;
+
+FUNCTION: void
+cairo_matrix_transform_distance ( cairo_matrix_t* matrix, double* dx, double* dy ) ;
+
+FUNCTION: void
+cairo_matrix_transform_point ( cairo_matrix_t* matrix, double* x, double* y ) ;
+
+! Functions to be used while debugging (not intended for use in production code)
+FUNCTION: void
+cairo_debug_reset_static_data ( ) ;
diff --git a/basis/cairo/gadgets/gadgets.factor b/basis/cairo/gadgets/gadgets.factor
new file mode 100644
index 0000000000..87942b4c91
--- /dev/null
+++ b/basis/cairo/gadgets/gadgets.factor
@@ -0,0 +1,43 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math kernel byte-arrays cairo.ffi cairo
+io.backend ui.gadgets accessors opengl.gl arrays fry
+classes ui.render namespaces destructors libc ;
+IN: cairo.gadgets
+
+stride ( width -- stride ) 4 * ;
+
+: image-dims ( gadget -- width height stride )
+ dim>> first2 over width>stride ; inline
+: image-buffer ( width height stride -- alien )
+ * nip malloc ; inline
+PRIVATE>
+
+GENERIC: render-cairo* ( gadget -- )
+
+: render-cairo ( gadget -- alien )
+ [
+ image-dims
+ [ image-buffer dup CAIRO_FORMAT_ARGB32 ]
+ [ cairo_image_surface_create_for_data ] 3bi
+ ] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
+
+TUPLE: cairo-gadget < gadget ;
+
+: ( dim -- gadget )
+ cairo-gadget new-gadget
+ swap >>dim ;
+
+M: cairo-gadget draw-gadget*
+ [
+ [ dim>> ] [ render-cairo &free ] bi
+ origin get first2 glRasterPos2i
+ 1.0 -1.0 glPixelZoom
+ [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
+ glDrawPixels
+ ] with-destructors ;
+
+: copy-surface ( surface -- )
+ cr swap 0 0 cairo_set_source_surface
+ cr cairo_paint ;
diff --git a/basis/cairo/summary.txt b/basis/cairo/summary.txt
new file mode 100644
index 0000000000..f6cb370ff6
--- /dev/null
+++ b/basis/cairo/summary.txt
@@ -0,0 +1 @@
+Cairo graphics library binding
diff --git a/basis/cairo/tags.txt b/basis/cairo/tags.txt
new file mode 100644
index 0000000000..bb863cf9a0
--- /dev/null
+++ b/basis/cairo/tags.txt
@@ -0,0 +1 @@
+bindings
diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index 793c771b64..522e0c52f3 100644
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -211,7 +211,7 @@ M: real +minute ( timestamp n -- timestamp )
M: number +second ( timestamp n -- timestamp )
[ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
-: (time+)
+: (time+) ( timestamp duration -- timestamp' duration )
[ second>> +second ] keep
[ minute>> +minute ] keep
[ hour>> +hour ] keep
@@ -219,7 +219,8 @@ M: number +second ( timestamp n -- timestamp )
[ month>> +month ] keep
[ year>> +year ] keep ; inline
-: +slots [ bi@ + ] curry 2keep ; inline
+: +slots ( obj1 obj2 quot -- n obj1 obj2 )
+ [ bi@ + ] curry 2keep ; inline
PRIVATE>
diff --git a/basis/channels/remote/remote-docs.factor b/basis/channels/remote/remote-docs.factor
index 862084e1d9..309f764d2d 100644
--- a/basis/channels/remote/remote-docs.factor
+++ b/basis/channels/remote/remote-docs.factor
@@ -6,6 +6,7 @@ IN: channels.remote
HELP:
{ $values { "node" "a node object" }
{ "id" "the id of the published channel on the node" }
+ { "remote-channel" remote-channel }
}
{ $description "Create a remote channel that acts as a proxy for a "
"channel on another node. The remote node's channel must have been "
diff --git a/basis/checksums/common/common.factor b/basis/checksums/common/common.factor
index 7d5f34777d..0ae4328446 100644
--- a/basis/checksums/common/common.factor
+++ b/basis/checksums/common/common.factor
@@ -1,21 +1,20 @@
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.bitwise strings io.binary namespaces
-make grouping ;
+make grouping byte-arrays ;
IN: checksums.common
SYMBOL: bytes-read
-: calculate-pad-length ( length -- pad-length )
- dup 56 < 55 119 ? swap - ;
+: calculate-pad-length ( length -- length' )
+ [ 56 < 55 119 ? ] keep - ;
: pad-last-block ( str big-endian? length -- str )
[
- rot %
- HEX: 80 ,
- dup HEX: 3f bitand calculate-pad-length 0 %
- 3 shift 8 rot [ >be ] [ >le ] if %
- ] "" make 64 group ;
+ [ % ] 2dip HEX: 80 ,
+ [ HEX: 3f bitand calculate-pad-length % ]
+ [ 3 shift 8 rot [ >be ] [ >le ] if % ] bi
+ ] B{ } make 64 group ;
: update-old-new ( old new -- )
[ [ get ] bi@ w+ dup ] 2keep [ set ] bi@ ; inline
diff --git a/basis/checksums/md5/md5.factor b/basis/checksums/md5/md5.factor
index d919b0e313..04c6c2497e 100644
--- a/basis/checksums/md5/md5.factor
+++ b/basis/checksums/md5/md5.factor
@@ -2,9 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
-sequences byte-arrays locals sequences.private
-io.encodings.binary symbols math.bitwise checksums
-checksums.common checksums.stream ;
+sequences byte-arrays locals sequences.private macros fry
+io.encodings.binary math.bitwise checksums
+checksums.common checksums.stream combinators ;
IN: checksums.md5
! See http://www.faqs.org/rfcs/rfc1321.html
@@ -29,7 +29,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
old-c c update-old-new
old-d d update-old-new ;
-:: (ABCD) ( x s i k func a b c d -- )
+:: (ABCD) ( x a b c d k s i func -- )
#! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
a [
b get c get d get func call w+
@@ -39,11 +39,6 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
b get w+
] change ; inline
-: ABCD a b c d (ABCD) ; inline
-: BCDA b c d a (ABCD) ; inline
-: CDAB c d a b (ABCD) ; inline
-: DABC d a b c (ABCD) ; inline
-
: F ( X Y Z -- FXYZ )
#! F(X,Y,Z) = XY v not(X) Z
pick bitnot bitand [ bitand ] [ bitor ] bi* ;
@@ -60,104 +55,113 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
#! I(X,Y,Z) = Y xor (X v not(Z))
rot swap bitnot bitor bitxor ;
-: S11 7 ; inline
-: S12 12 ; inline
-: S13 17 ; inline
-: S14 22 ; inline
-: S21 5 ; inline
-: S22 9 ; inline
-: S23 14 ; inline
-: S24 20 ; inline
-: S31 4 ; inline
-: S32 11 ; inline
-: S33 16 ; inline
-: S34 23 ; inline
-: S41 6 ; inline
-: S42 10 ; inline
-: S43 15 ; inline
-: S44 21 ; inline
-
-: (process-md5-block-F) ( block -- block )
- dup S11 1 0 [ F ] ABCD
- dup S12 2 1 [ F ] DABC
- dup S13 3 2 [ F ] CDAB
- dup S14 4 3 [ F ] BCDA
- dup S11 5 4 [ F ] ABCD
- dup S12 6 5 [ F ] DABC
- dup S13 7 6 [ F ] CDAB
- dup S14 8 7 [ F ] BCDA
- dup S11 9 8 [ F ] ABCD
- dup S12 10 9 [ F ] DABC
- dup S13 11 10 [ F ] CDAB
- dup S14 12 11 [ F ] BCDA
- dup S11 13 12 [ F ] ABCD
- dup S12 14 13 [ F ] DABC
- dup S13 15 14 [ F ] CDAB
- dup S14 16 15 [ F ] BCDA ;
-
-: (process-md5-block-G) ( block -- block )
- dup S21 17 1 [ G ] ABCD
- dup S22 18 6 [ G ] DABC
- dup S23 19 11 [ G ] CDAB
- dup S24 20 0 [ G ] BCDA
- dup S21 21 5 [ G ] ABCD
- dup S22 22 10 [ G ] DABC
- dup S23 23 15 [ G ] CDAB
- dup S24 24 4 [ G ] BCDA
- dup S21 25 9 [ G ] ABCD
- dup S22 26 14 [ G ] DABC
- dup S23 27 3 [ G ] CDAB
- dup S24 28 8 [ G ] BCDA
- dup S21 29 13 [ G ] ABCD
- dup S22 30 2 [ G ] DABC
- dup S23 31 7 [ G ] CDAB
- dup S24 32 12 [ G ] BCDA ;
-
-: (process-md5-block-H) ( block -- block )
- dup S31 33 5 [ H ] ABCD
- dup S32 34 8 [ H ] DABC
- dup S33 35 11 [ H ] CDAB
- dup S34 36 14 [ H ] BCDA
- dup S31 37 1 [ H ] ABCD
- dup S32 38 4 [ H ] DABC
- dup S33 39 7 [ H ] CDAB
- dup S34 40 10 [ H ] BCDA
- dup S31 41 13 [ H ] ABCD
- dup S32 42 0 [ H ] DABC
- dup S33 43 3 [ H ] CDAB
- dup S34 44 6 [ H ] BCDA
- dup S31 45 9 [ H ] ABCD
- dup S32 46 12 [ H ] DABC
- dup S33 47 15 [ H ] CDAB
- dup S34 48 2 [ H ] BCDA ;
-
-: (process-md5-block-I) ( block -- block )
- dup S41 49 0 [ I ] ABCD
- dup S42 50 7 [ I ] DABC
- dup S43 51 14 [ I ] CDAB
- dup S44 52 5 [ I ] BCDA
- dup S41 53 12 [ I ] ABCD
- dup S42 54 3 [ I ] DABC
- dup S43 55 10 [ I ] CDAB
- dup S44 56 1 [ I ] BCDA
- dup S41 57 8 [ I ] ABCD
- dup S42 58 15 [ I ] DABC
- dup S43 59 6 [ I ] CDAB
- dup S44 60 13 [ I ] BCDA
- dup S41 61 4 [ I ] ABCD
- dup S42 62 11 [ I ] DABC
- dup S43 63 2 [ I ] CDAB
- dup S44 64 9 [ I ] BCDA ;
+CONSTANT: S11 7
+CONSTANT: S12 12
+CONSTANT: S13 17
+CONSTANT: S14 22
+CONSTANT: S21 5
+CONSTANT: S22 9
+CONSTANT: S23 14
+CONSTANT: S24 20
+CONSTANT: S31 4
+CONSTANT: S32 11
+CONSTANT: S33 16
+CONSTANT: S34 23
+CONSTANT: S41 6
+CONSTANT: S42 10
+CONSTANT: S43 15
+CONSTANT: S44 21
+
+MACRO: with-md5-round ( ops func -- )
+ '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
+
+: (process-md5-block-F) ( block -- )
+ {
+ [ a b c d 0 S11 1 ]
+ [ d a b c 1 S12 2 ]
+ [ c d a b 2 S13 3 ]
+ [ b c d a 3 S14 4 ]
+ [ a b c d 4 S11 5 ]
+ [ d a b c 5 S12 6 ]
+ [ c d a b 6 S13 7 ]
+ [ b c d a 7 S14 8 ]
+ [ a b c d 8 S11 9 ]
+ [ d a b c 9 S12 10 ]
+ [ c d a b 10 S13 11 ]
+ [ b c d a 11 S14 12 ]
+ [ a b c d 12 S11 13 ]
+ [ d a b c 13 S12 14 ]
+ [ c d a b 14 S13 15 ]
+ [ b c d a 15 S14 16 ]
+ } [ F ] with-md5-round ;
+
+: (process-md5-block-G) ( block -- )
+ {
+ [ a b c d 1 S21 17 ]
+ [ d a b c 6 S22 18 ]
+ [ c d a b 11 S23 19 ]
+ [ b c d a 0 S24 20 ]
+ [ a b c d 5 S21 21 ]
+ [ d a b c 10 S22 22 ]
+ [ c d a b 15 S23 23 ]
+ [ b c d a 4 S24 24 ]
+ [ a b c d 9 S21 25 ]
+ [ d a b c 14 S22 26 ]
+ [ c d a b 3 S23 27 ]
+ [ b c d a 8 S24 28 ]
+ [ a b c d 13 S21 29 ]
+ [ d a b c 2 S22 30 ]
+ [ c d a b 7 S23 31 ]
+ [ b c d a 12 S24 32 ]
+ } [ G ] with-md5-round ;
+
+: (process-md5-block-H) ( block -- )
+ {
+ [ a b c d 5 S31 33 ]
+ [ d a b c 8 S32 34 ]
+ [ c d a b 11 S33 35 ]
+ [ b c d a 14 S34 36 ]
+ [ a b c d 1 S31 37 ]
+ [ d a b c 4 S32 38 ]
+ [ c d a b 7 S33 39 ]
+ [ b c d a 10 S34 40 ]
+ [ a b c d 13 S31 41 ]
+ [ d a b c 0 S32 42 ]
+ [ c d a b 3 S33 43 ]
+ [ b c d a 6 S34 44 ]
+ [ a b c d 9 S31 45 ]
+ [ d a b c 12 S32 46 ]
+ [ c d a b 15 S33 47 ]
+ [ b c d a 2 S34 48 ]
+ } [ H ] with-md5-round ;
+
+: (process-md5-block-I) ( block -- )
+ {
+ [ a b c d 0 S41 49 ]
+ [ d a b c 7 S42 50 ]
+ [ c d a b 14 S43 51 ]
+ [ b c d a 5 S44 52 ]
+ [ a b c d 12 S41 53 ]
+ [ d a b c 3 S42 54 ]
+ [ c d a b 10 S43 55 ]
+ [ b c d a 1 S44 56 ]
+ [ a b c d 8 S41 57 ]
+ [ d a b c 15 S42 58 ]
+ [ c d a b 6 S43 59 ]
+ [ b c d a 13 S44 60 ]
+ [ a b c d 4 S41 61 ]
+ [ d a b c 11 S42 62 ]
+ [ c d a b 2 S43 63 ]
+ [ b c d a 9 S44 64 ]
+ } [ I ] with-md5-round ;
: (process-md5-block) ( block -- )
- 4 [ le> ] map
-
- (process-md5-block-F)
- (process-md5-block-G)
- (process-md5-block-H)
- (process-md5-block-I)
-
- drop
+ 4 [ le> ] map {
+ [ (process-md5-block-F) ]
+ [ (process-md5-block-G) ]
+ [ (process-md5-block-H) ]
+ [ (process-md5-block-I) ]
+ } cleave
update-md ;
diff --git a/basis/checksums/openssl/openssl-docs.factor b/basis/checksums/openssl/openssl-docs.factor
index fd067997a7..750e05f3c8 100644
--- a/basis/checksums/openssl/openssl-docs.factor
+++ b/basis/checksums/openssl/openssl-docs.factor
@@ -4,8 +4,8 @@ USING: help.syntax help.markup ;
HELP: openssl-checksum
{ $class-description "The class of checksum algorithms implemented by OpenSSL. The exact set of algorithms supported depends on how the OpenSSL library was compiled; " { $snippet "md5" } " and " { $snippet "sha1" } " should be universally available." } ;
-HELP: ( name -- checksum )
-{ $values { "name" "an EVP message digest name" } { "checksum" openssl-checksum } }
+HELP:
+{ $values { "name" "an EVP message digest name" } { "openssl-checksum" openssl-checksum } }
{ $description "Creates a new OpenSSL checksum object." } ;
HELP: openssl-md5
diff --git a/basis/checksums/sha1/sha1.factor b/basis/checksums/sha1/sha1.factor
index 6cdc9270aa..ede8a8f653 100644
--- a/basis/checksums/sha1/sha1.factor
+++ b/basis/checksums/sha1/sha1.factor
@@ -3,7 +3,7 @@
USING: arrays combinators kernel io io.encodings.binary io.files
io.streams.byte-array math.vectors strings sequences namespaces
make math parser sequences assocs grouping vectors io.binary
-hashtables symbols math.bitwise checksums checksums.common
+hashtables math.bitwise checksums checksums.common
checksums.stream ;
IN: checksums.sha1
diff --git a/basis/checksums/sha2/sha2.factor b/basis/checksums/sha2/sha2.factor
index beb657bd3e..898a695b34 100644
--- a/basis/checksums/sha2/sha2.factor
+++ b/basis/checksums/sha2/sha2.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel splitting grouping math sequences namespaces make
-io.binary symbols math.bitwise checksums checksums.common
+io.binary math.bitwise checksums checksums.common
sbufs strings ;
IN: checksums.sha2
diff --git a/basis/cocoa/application/application-docs.factor b/basis/cocoa/application/application-docs.factor
index e12b6eb276..60a0232a2c 100644
--- a/basis/cocoa/application/application-docs.factor
+++ b/basis/cocoa/application/application-docs.factor
@@ -30,10 +30,6 @@ HELP: cocoa-app
{ $values { "quot" quotation } }
{ $description "Initializes Cocoa, calls the quotation, and starts the Cocoa event loop." } ;
-HELP: do-event
-{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
-{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
-
HELP: add-observer
{ $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } }
{ $description "Registers an observer with the " { $snippet "NSNotificationCenter" } " singleton." } ;
@@ -52,7 +48,6 @@ HELP: objc-error
ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
"Utilities:"
{ $subsection NSApp }
-{ $subsection do-event }
{ $subsection add-observer }
{ $subsection remove-observer }
{ $subsection install-delegate }
diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
index a52aaedce2..ab2b6375a9 100644
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
-core-foundation.run-loop core-foundation.arrays
-core-foundation.data core-foundation.strings cocoa.messages
-cocoa cocoa.classes cocoa.runtime sequences threads init summary
-kernel.private assocs ;
+core-foundation.arrays core-foundation.data
+core-foundation.strings cocoa.messages cocoa cocoa.classes
+cocoa.runtime sequences threads init summary kernel.private
+assocs ;
IN: cocoa.application
: ( str -- alien ) -> autorelease ;
@@ -35,13 +35,6 @@ FUNCTION: void NSBeep ( ) ;
: with-cocoa ( quot -- )
[ NSApp drop call ] with-autorelease-pool ; inline
-: next-event ( app -- event )
- NSAnyEventMask f CFRunLoopDefaultMode 1
- -> nextEventMatchingMask:untilDate:inMode:dequeue: ;
-
-: do-event ( app -- ? )
- dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ;
-
: add-observer ( observer selector name object -- )
[
[ NSNotificationCenter -> defaultCenter ] 2dip
diff --git a/basis/cocoa/views/views-docs.factor b/basis/cocoa/views/views-docs.factor
index a1cd792436..3b533f98c3 100644
--- a/basis/cocoa/views/views-docs.factor
+++ b/basis/cocoa/views/views-docs.factor
@@ -2,7 +2,7 @@ USING: help.syntax help.markup ;
IN: cocoa.views
HELP:
-{ $values { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
+{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
{ $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ;
HELP:
diff --git a/basis/cocoa/windows/windows.factor b/basis/cocoa/windows/windows.factor
index 3a53a1cc3c..51f692d02d 100644
--- a/basis/cocoa/windows/windows.factor
+++ b/basis/cocoa/windows/windows.factor
@@ -14,7 +14,7 @@ IN: cocoa.windows
: NSBackingStoreNonretained 1 ; inline
: NSBackingStoreBuffered 2 ; inline
-: standard-window-type
+: standard-window-type ( -- n )
{
NSTitledWindowMask
NSClosableWindowMask
diff --git a/basis/columns/columns-docs.factor b/basis/columns/columns-docs.factor
index 27dc160812..1dd9257281 100644
--- a/basis/columns/columns-docs.factor
+++ b/basis/columns/columns-docs.factor
@@ -4,8 +4,8 @@ IN: columns
HELP: column
{ $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link } "." } ;
-HELP: ( seq n -- column )
-{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
+HELP:
+{ $values { "seq" sequence } { "col" "a non-negative integer" } { "column" column } }
{ $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of " { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
{ $examples
{ $example
diff --git a/basis/columns/columns.factor b/basis/columns/columns.factor
index 5ac8531f58..8f45dab872 100644
--- a/basis/columns/columns.factor
+++ b/basis/columns/columns.factor
@@ -9,7 +9,7 @@ TUPLE: column seq col ;
C: column
M: column virtual-seq seq>> ;
-M: column virtual@ dup col>> -rot seq>> nth bounds-check ;
+M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
M: column length seq>> length ;
INSTANCE: column virtual-sequence
diff --git a/basis/combinators/smart/authors.txt b/basis/combinators/smart/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/combinators/smart/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/combinators/smart/smart-docs.factor b/basis/combinators/smart/smart-docs.factor
new file mode 100644
index 0000000000..75f83c1a55
--- /dev/null
+++ b/basis/combinators/smart/smart-docs.factor
@@ -0,0 +1,125 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations math sequences
+multiline ;
+IN: combinators.smart
+
+HELP: inputarray
+{ $values
+ { "quot" quotation }
+ { "newquot" quotation }
+}
+{ $description "Infers the number or outputs from the quotation and constructs an array from those outputs." }
+{ $examples
+ { $example
+ <" USING: combinators combinators.smart math prettyprint ;
+9 [
+ { [ 1- ] [ 1+ ] [ sq ] } cleave
+] output>array .">
+ "{ 8 10 81 }"
+ }
+} ;
+
+HELP: output>sequence
+{ $values
+ { "quot" quotation } { "exemplar" "an exemplar" }
+ { "newquot" quotation }
+}
+{ $description "Infers the number of outputs from the quotation and constructs a new sequence from those objects of the same type as the exemplar." }
+{ $examples
+ { $example
+ "USING: combinators.smart kernel math prettyprint ;"
+ "4 [ [ 1 + ] [ 2 + ] [ 3 + ] tri ] V{ } output>sequence ."
+ "V{ 5 6 7 }"
+ }
+} ;
+
+HELP: reduce-outputs
+{ $values
+ { "quot" quotation } { "operation" quotation }
+ { "newquot" quotation }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and reduces them using " { $snippet "operation" } ". The identity for the " { $link reduce } " operation is the first output." }
+{ $examples
+ { $example
+ "USING: combinators.smart kernel math prettyprint ;"
+ "3 [ [ 4 * ] [ 4 / ] [ 4 - ] tri ] [ * ] reduce-outputs ."
+ "-9"
+ }
+} ;
+
+HELP: sum-outputs
+{ $values
+ { "quot" quotation }
+ { "n" integer }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns their sum." }
+{ $examples
+ { $example
+ "USING: combinators.smart kernel math prettyprint ;"
+ "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
+ "20"
+ }
+} ;
+
+HELP: append-outputs
+{ $values
+ { "quot" quotation }
+ { "seq" sequence }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns a sequence of the outputs appended." }
+{ $examples
+ { $example
+ "USING: combinators.smart prettyprint ;"
+ "[ { 1 2 } { \"A\" \"b\" } ] append-outputs ."
+ "{ 1 2 \"A\" \"b\" }"
+ }
+} ;
+
+HELP: append-outputs-as
+{ $values
+ { "quot" quotation } { "exemplar" sequence }
+ { "seq" sequence }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns a sequence of type " { $snippet "exemplar" } " of the outputs appended." }
+{ $examples
+ { $example
+ "USING: combinators.smart prettyprint ;"
+ "[ { 1 2 } { \"A\" \"b\" } ] V{ } append-outputs-as ."
+ "V{ 1 2 \"A\" \"b\" }"
+ }
+} ;
+
+{ append-outputs append-outputs-as } related-words
+
+
+ARTICLE: "combinators.smart" "Smart combinators"
+"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl
+"Smart inputs from a sequence:"
+{ $subsection inputsequence }
+{ $subsection output>array }
+"Reducing the output of a quotation:"
+{ $subsection reduce-outputs }
+"Summing the output of a quotation:"
+{ $subsection sum-outputs }
+"Appending the results of a quotation:"
+{ $subsection append-outputs }
+{ $subsection append-outputs-as } ;
+
+ABOUT: "combinators.smart"
diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor
new file mode 100644
index 0000000000..370dc26960
--- /dev/null
+++ b/basis/combinators/smart/smart-tests.factor
@@ -0,0 +1,39 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test combinators.smart math kernel ;
+IN: combinators.smart.tests
+
+: test-bi ( -- 9 11 )
+ 10 [ 1- ] [ 1+ ] bi ;
+
+[ [ test-bi ] output>array ] must-infer
+[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test
+
+[ { 9 11 } [ + ] inputsequence ( quot exemplar -- newquot )
+ [ dup infer out>> ] dip
+ '[ @ _ _ nsequence ] ;
+
+: output>array ( quot -- newquot )
+ { } output>sequence ; inline
+
+MACRO: input> ] keep
+ '[ _ firstn @ ] ;
+
+MACRO: reduce-outputs ( quot operation -- newquot )
+ [ dup infer out>> 1 [-] ] dip n*quot compose ;
+
+: sum-outputs ( quot -- n )
+ [ + ] reduce-outputs ; inline
+
+MACRO: append-outputs-as ( quot exemplar -- newquot )
+ [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
+
+: append-outputs ( quot -- seq )
+ { } append-outputs-as ; inline
diff --git a/basis/command-line/command-line.factor b/basis/command-line/command-line.factor
index 7d5a041951..38d40d8482 100644
--- a/basis/command-line/command-line.factor
+++ b/basis/command-line/command-line.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init continuations hashtables io io.encodings.utf8
-io.files kernel kernel.private namespaces parser sequences
-strings system splitting vocabs.loader ;
+io.files io.pathnames kernel kernel.private namespaces parser
+sequences strings system splitting vocabs.loader ;
IN: command-line
SYMBOL: script
diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
index d8bad5ec41..81359690db 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor
@@ -13,7 +13,7 @@ IN: compiler.cfg.alias-analysis.tests
[ ] [
{
- T{ ##load-indirect f V int-regs 1 "hello" }
+ T{ ##load-reference f V int-regs 1 "hello" }
T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
} alias-analysis drop
] unit-test
diff --git a/basis/compiler/cfg/alias-analysis/alias-analysis.factor b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
index 90227bb5da..ec8fe62dfb 100644
--- a/basis/compiler/cfg/alias-analysis/alias-analysis.factor
+++ b/basis/compiler/cfg/alias-analysis/alias-analysis.factor
@@ -68,7 +68,8 @@ IN: compiler.cfg.alias-analysis
! Map vregs -> alias classes
SYMBOL: vregs>acs
-: check [ "BUG: static type error detected" throw ] unless* ; inline
+: check ( obj -- obj )
+ [ "BUG: static type error detected" throw ] unless* ; inline
: vreg>ac ( vreg -- ac )
#! Only vregs produced by ##allot, ##peek and ##slot can
@@ -223,7 +224,7 @@ GENERIC: analyze-aliases* ( insn -- insn' )
M: ##load-immediate analyze-aliases*
dup [ val>> ] [ dst>> ] bi constants get set-at ;
-M: ##load-indirect analyze-aliases*
+M: ##load-reference analyze-aliases*
dup dst>> set-heap-ac ;
M: ##alien-global analyze-aliases*
diff --git a/basis/compiler/cfg/builder/builder-tests.factor b/basis/compiler/cfg/builder/builder-tests.factor
index c3cce1425e..0b303a8a43 100644
--- a/basis/compiler/cfg/builder/builder-tests.factor
+++ b/basis/compiler/cfg/builder/builder-tests.factor
@@ -14,7 +14,7 @@ kernel.private math ;
[ ]
[ dup ]
[ swap ]
- [ >r r> ]
+ [ [ ] dip ]
[ fixnum+ ]
[ fixnum+fast ]
[ 3 fixnum+fast ]
diff --git a/basis/compiler/cfg/hats/hats.factor b/basis/compiler/cfg/hats/hats.factor
index c0d5bf79a6..817c0f4680 100644
--- a/basis/compiler/cfg/hats/hats.factor
+++ b/basis/compiler/cfg/hats/hats.factor
@@ -5,17 +5,17 @@ sequences classes.tuple cpu.architecture compiler.cfg.registers
compiler.cfg.instructions ;
IN: compiler.cfg.hats
-: i int-regs next-vreg ; inline
-: ^^i i dup ; inline
-: ^^i1 [ ^^i ] dip ; inline
-: ^^i2 [ ^^i ] 2dip ; inline
-: ^^i3 [ ^^i ] 3dip ; inline
+: i ( -- vreg ) int-regs next-vreg ; inline
+: ^^i ( -- vreg vreg ) i dup ; inline
+: ^^i1 ( obj -- vreg vreg obj ) [ ^^i ] dip ; inline
+: ^^i2 ( obj obj -- vreg vreg obj obj ) [ ^^i ] 2dip ; inline
+: ^^i3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^i ] 3dip ; inline
-: d double-float-regs next-vreg ; inline
-: ^^d d dup ; inline
-: ^^d1 [ ^^d ] dip ; inline
-: ^^d2 [ ^^d ] 2dip ; inline
-: ^^d3 [ ^^d ] 3dip ; inline
+: d ( -- vreg ) double-float-regs next-vreg ; inline
+: ^^d ( -- vreg vreg ) d dup ; inline
+: ^^d1 ( obj -- vreg vreg obj ) [ ^^d ] dip ; inline
+: ^^d2 ( obj obj -- vreg vreg obj obj ) [ ^^d ] 2dip ; inline
+: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
: ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
: ^^peek ( loc -- dst ) ^^i1 ##peek ; inline
diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor
index 5619a70740..d152a8cc33 100644
--- a/basis/compiler/cfg/instructions/instructions.factor
+++ b/basis/compiler/cfg/instructions/instructions.factor
@@ -36,13 +36,13 @@ TUPLE: ##alien-setter < ##effect { value vreg } ;
! Stack operations
INSN: ##load-immediate < ##pure { val integer } ;
-INSN: ##load-indirect < ##pure obj ;
+INSN: ##load-reference < ##pure obj ;
GENERIC: ##load-literal ( dst value -- )
M: fixnum ##load-literal tag-fixnum ##load-immediate ;
M: f ##load-literal drop \ f tag-number ##load-immediate ;
-M: object ##load-literal ##load-indirect ;
+M: object ##load-literal ##load-reference ;
INSN: ##peek < ##read { loc loc } ;
INSN: ##replace < ##write { loc loc } ;
diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor
index 5a5df88112..30d062d4cc 100644
--- a/basis/compiler/cfg/instructions/syntax/syntax.factor
+++ b/basis/compiler/cfg/instructions/syntax/syntax.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
-make fry sequences parser ;
+make fry sequences parser accessors ;
IN: compiler.cfg.instructions.syntax
: insn-word ( -- word )
@@ -10,10 +10,13 @@ IN: compiler.cfg.instructions.syntax
#! this one.
"insn" "compiler.cfg.instructions" lookup ;
+: insn-effect ( word -- effect )
+ boa-effect [ but-last ] change-in { } >>out ;
+
: INSN:
parse-tuple-definition "regs" suffix
[ dup tuple eq? [ drop insn-word ] when ] dip
[ define-tuple-class ]
[ 2drop save-location ]
- [ 2drop dup '[ f _ boa , ] define-inline ]
+ [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
3tri ; parsing
diff --git a/basis/compiler/cfg/intrinsics/intrinsics.factor b/basis/compiler/cfg/intrinsics/intrinsics.factor
index 5f75330865..3d0a7bec9c 100644
--- a/basis/compiler/cfg/intrinsics/intrinsics.factor
+++ b/basis/compiler/cfg/intrinsics/intrinsics.factor
@@ -1,7 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: qualified words sequences kernel combinators
-cpu.architecture
+USING: words sequences kernel combinators cpu.architecture
compiler.cfg.hats
compiler.cfg.instructions
compiler.cfg.intrinsics.alien
diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
index 948302c74b..4ddd1fdc0b 100644
--- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
+++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor
@@ -1,7 +1,7 @@
IN: compiler.cfg.linear-scan.tests
USING: tools.test random sorting sequences sets hashtables assocs
kernel fry arrays splitting namespaces math accessors vectors
-math.order
+math.order grouping
cpu.architecture
compiler.cfg.instructions
compiler.cfg.registers
@@ -249,7 +249,7 @@ SYMBOL: max-uses
] with-scope ;
: random-test ( num-intervals max-uses max-registers max-insns -- )
- over >r random-live-intervals r> int-regs associate check-linear-scan ;
+ over [ random-live-intervals ] dip int-regs associate check-linear-scan ;
[ ] [ 30 2 1 60 random-test ] unit-test
[ ] [ 60 2 2 60 random-test ] unit-test
diff --git a/basis/compiler/cfg/linearization/linearization.factor b/basis/compiler/cfg/linearization/linearization.factor
index 7433df9617..584c4cd662 100644
--- a/basis/compiler/cfg/linearization/linearization.factor
+++ b/basis/compiler/cfg/linearization/linearization.factor
@@ -37,7 +37,7 @@ M: insn linearize-insn , drop ;
M: ##branch linearize-insn
drop dup successors>> first emit-branch ;
-: (binary-conditional)
+: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
[ dup successors>> first2 ]
[ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
diff --git a/basis/compiler/cfg/value-numbering/expressions/expressions.factor b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
index 476ba7d0ab..cc790c6c0a 100644
--- a/basis/compiler/cfg/value-numbering/expressions/expressions.factor
+++ b/basis/compiler/cfg/value-numbering/expressions/expressions.factor
@@ -39,8 +39,6 @@ GENERIC: >expr ( insn -- expr )
M: ##load-immediate >expr val>> ;
-M: ##load-indirect >expr obj>> ;
-
M: ##unary >expr
[ class ] [ src>> vreg>vn ] bi unary-expr boa ;
diff --git a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
index 641ccceb5d..ac9603522e 100644
--- a/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
+++ b/basis/compiler/cfg/value-numbering/value-numbering-tests.factor
@@ -81,7 +81,7 @@ sequences ;
[
{
- T{ ##load-indirect f V int-regs 1 + }
+ T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
@@ -89,7 +89,7 @@ sequences ;
}
] [
{
- T{ ##load-indirect f V int-regs 1 + }
+ T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
@@ -99,7 +99,7 @@ sequences ;
[
{
- T{ ##load-indirect f V int-regs 1 + }
+ T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
@@ -107,7 +107,7 @@ sequences ;
}
] [
{
- T{ ##load-indirect f V int-regs 1 + }
+ T{ ##load-reference f V int-regs 1 + }
T{ ##peek f V int-regs 2 D 0 }
T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 9f134c02d7..3d7f574cf8 100644
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -1,9 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
-alien.strings alien.arrays sets threads libc continuations.private
+alien.strings alien.arrays sets libc continuations.private
fry cpu.architecture
compiler.errors
compiler.alien
@@ -11,7 +11,8 @@ compiler.cfg
compiler.cfg.instructions
compiler.cfg.registers
compiler.cfg.builder
-compiler.codegen.fixup ;
+compiler.codegen.fixup
+compiler.utilities ;
IN: compiler.codegen
GENERIC: generate-insn ( insn -- )
@@ -69,8 +70,8 @@ SYMBOL: labels
M: ##load-immediate generate-insn
[ dst>> register ] [ val>> ] bi %load-immediate ;
-M: ##load-indirect generate-insn
- [ dst>> register ] [ obj>> ] bi %load-indirect ;
+M: ##load-reference generate-insn
+ [ dst>> register ] [ obj>> ] bi %load-reference ;
M: ##peek generate-insn
[ dst>> register ] [ loc>> ] bi %peek ;
@@ -95,7 +96,7 @@ M: ##dispatch-label generate-insn label>> %dispatch-label ;
M: ##dispatch generate-insn
[ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
-: >slot<
+: >slot< ( insn -- dst obj slot tag )
{
[ dst>> register ]
[ obj>> register ]
@@ -109,7 +110,7 @@ M: ##slot generate-insn
M: ##slot-imm generate-insn
>slot< %slot-imm ;
-: >set-slot<
+: >set-slot< ( insn -- src obj slot tag )
{
[ src>> register ]
[ obj>> register ]
@@ -209,7 +210,8 @@ M: ##alien-cell generate-insn dst/src %alien-cell ;
M: ##alien-float generate-insn dst/src %alien-float ;
M: ##alien-double generate-insn dst/src %alien-double ;
-: >alien-setter< [ src>> register ] [ value>> register ] bi ; inline
+: >alien-setter< ( insn -- src value )
+ [ src>> register ] [ value>> register ] bi ; inline
M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
@@ -462,7 +464,7 @@ TUPLE: callback-context ;
dup current-callback eq? [
drop
] [
- yield wait-to-return
+ yield-hook get call wait-to-return
] if ;
: do-callback ( quot token -- )
diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor
index 0d24daef71..f2f4e7aa9e 100644
--- a/basis/compiler/compiler.factor
+++ b/basis/compiler/compiler.factor
@@ -1,14 +1,14 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces arrays sequences io
words fry continuations vocabs assocs dlists definitions math
-threads graphs generic combinators deques search-deques io
+graphs generic combinators deques search-deques io
stack-checker stack-checker.state stack-checker.inlining
compiler.errors compiler.units compiler.tree.builder
compiler.tree.optimizer compiler.cfg.builder
compiler.cfg.optimizer compiler.cfg.linearization
compiler.cfg.two-operand compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen ;
+compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
IN: compiler
SYMBOL: compile-queue
@@ -24,7 +24,7 @@ SYMBOL: compiled
} cond drop ;
: maybe-compile ( word -- )
- dup compiled>> [ drop ] [ queue-compile ] if ;
+ dup optimized>> [ drop ] [ queue-compile ] if ;
SYMBOL: +failed+
@@ -107,10 +107,10 @@ t compile-dependencies? set-global
] with-return ;
: compile-loop ( deque -- )
- [ (compile) yield ] slurp-deque ;
+ [ (compile) yield-hook get call ] slurp-deque ;
: decompile ( word -- )
- f 2array 1array t modify-code-heap ;
+ f 2array 1array modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[
diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor
index e743c8484b..78e95ffb91 100644
--- a/basis/compiler/tests/codegen.factor
+++ b/basis/compiler/tests/codegen.factor
@@ -75,7 +75,7 @@ unit-test
-12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
] unit-test
-[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
+[ -1 2 ] [ 1 2 [ [ 0 swap fixnum- ] dip ] compile-call ] unit-test
[ 12 13 ] [
-12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
@@ -88,13 +88,13 @@ unit-test
! Test slow shuffles
[ 3 1 2 3 4 5 6 7 8 9 ] [
1 2 3 4 5 6 7 8 9
- [ >r >r >r >r >r >r >r >r >r 3 r> r> r> r> r> r> r> r> r> ]
+ [ [ [ [ [ [ [ [ [ [ 3 ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ]
compile-call
] unit-test
[ 2 2 2 2 2 2 2 2 2 2 1 ] [
1 2
- [ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-call
+ [ swap [ dup dup dup dup dup dup dup dup dup ] dip ] compile-call
] unit-test
[ ] [ [ 9 [ ] times ] compile-call ] unit-test
@@ -110,7 +110,7 @@ unit-test
float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
: try-breaking-dispatch-2 ( -- ? )
- 1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
+ 1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
[ t ] [
10000000 [ drop try-breaking-dispatch-2 ] all?
@@ -131,10 +131,10 @@ unit-test
2dup 1 slot eq? [ 2drop ] [
2dup array-nth tombstone? [
[
- [ array-nth ] 2keep >r 1 fixnum+fast r> array-nth
+ [ array-nth ] 2keep [ 1 fixnum+fast ] dip array-nth
pick 2dup hellish-bug-1 3drop
] 2keep
- ] unless >r 2 fixnum+fast r> hellish-bug-2
+ ] unless [ 2 fixnum+fast ] dip hellish-bug-2
] if ; inline recursive
: hellish-bug-3 ( hash array -- )
@@ -159,9 +159,9 @@ TUPLE: my-tuple ;
[ 5 ] [ "hi" foox ] unit-test
! Making sure we don't needlessly unbox/rebox
-[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-call ] unit-test
+[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ [ eq? ] dip ] compile-call ] unit-test
-[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call >r eq? r> ] unit-test
+[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call [ eq? ] dip ] unit-test
[ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test
@@ -188,7 +188,7 @@ TUPLE: my-tuple ;
[ 2 1 ] [
2 1
- [ 2dup fixnum< [ >r die r> ] when ] compile-call
+ [ 2dup fixnum< [ [ die ] dip ] when ] compile-call
] unit-test
! Regression
@@ -211,7 +211,7 @@ TUPLE: my-tuple ;
{ tuple vector } 3 slot { word } declare
dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
-[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
+[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
[ vector ] [ dispatch-alignment-regression ] unit-test
@@ -276,3 +276,9 @@ TUPLE: id obj ;
[ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
[ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test
+
+TUPLE: cucumber ;
+
+M: cucumber equal? "The cucumber has no equal" throw ;
+
+[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test
\ No newline at end of file
diff --git a/basis/compiler/tests/curry.factor b/basis/compiler/tests/curry.factor
index ecc2d87b73..1857baf503 100644
--- a/basis/compiler/tests/curry.factor
+++ b/basis/compiler/tests/curry.factor
@@ -8,7 +8,7 @@ IN: compiler.tests
[ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-call ] unit-test
[ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test
-[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test
+[ 3 ] [ 5 2 [ [ - ] 2curry [ 9 ] dip call /i ] compile-call ] unit-test
[ -10 -20 ] [ 10 20 -1 [ [ * ] curry bi@ ] compile-call ] unit-test
@@ -21,14 +21,14 @@ IN: compiler.tests
[ [ 6 2 + ] ]
[
2 5
- [ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry ]
+ [ [ [ + ] curry ] dip 0 < [ -2 ] [ 6 ] if swap curry ]
compile-call >quotation
] unit-test
[ 8 ]
[
2 5
- [ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry call ]
+ [ [ [ + ] curry ] dip 0 < [ -2 ] [ 6 ] if swap curry call ]
compile-call
] unit-test
diff --git a/basis/compiler/tests/optimizer.factor b/basis/compiler/tests/optimizer.factor
index fa6a3c7b21..c5bbe4a6c3 100644
--- a/basis/compiler/tests/optimizer.factor
+++ b/basis/compiler/tests/optimizer.factor
@@ -9,7 +9,7 @@ IN: optimizer.tests
GENERIC: xyz ( obj -- obj )
M: array xyz xyz ;
-[ t ] [ \ xyz compiled>> ] unit-test
+[ t ] [ \ xyz optimized>> ] unit-test
! Test predicate inlining
: pred-test-1
@@ -94,7 +94,7 @@ TUPLE: pred-test ;
! regression
GENERIC: void-generic ( obj -- * )
: breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage compiled>> ] unit-test
+[ t ] [ \ breakage optimized>> ] unit-test
[ breakage ] must-fail
! regression
@@ -119,7 +119,7 @@ GENERIC: void-generic ( obj -- * )
! compiling with a non-literal class failed
: -regression ( class -- tuple ) ;
-[ t ] [ \ -regression compiled>> ] unit-test
+[ t ] [ \ -regression optimized>> ] unit-test
GENERIC: foozul ( a -- b )
M: reversed foozul ;
@@ -228,7 +228,7 @@ USE: binary-search.private
: node-successor-f-bug ( x -- * )
[ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
-[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
+[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
[ ] [ [ new ] build-tree optimize-tree drop ] unit-test
@@ -242,18 +242,18 @@ USE: binary-search.private
] if
] if ;
-[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
+[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
[ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
[ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
: lift-loop-tail-test-1 ( a quot -- )
over even? [
- [ >r 3 - r> call ] keep lift-loop-tail-test-1
+ [ [ 3 - ] dip call ] keep lift-loop-tail-test-1
] [
over 0 < [
2drop
] [
- [ >r 2 - r> call ] keep lift-loop-tail-test-1
+ [ [ 2 - ] dip call ] keep lift-loop-tail-test-1
] if
] if ; inline
@@ -271,7 +271,7 @@ HINTS: recursive-inline-hang array ;
: recursive-inline-hang-1 ( -- a )
{ } recursive-inline-hang ;
-[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
+[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
DEFER: recursive-inline-hang-3
@@ -290,7 +290,7 @@ HINTS: recursive-inline-hang-3 array ;
! Wow
: counter-example ( a b c d -- a' b' c' d' )
- dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline
+ dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline
: counter-example' ( -- a' b' c' d' )
1 2 3.0 3 counter-example ;
@@ -330,7 +330,7 @@ PREDICATE: list < improper-list
[ 0 5 ] [ 0 interval-inference-bug ] unit-test
: aggressive-flush-regression ( a -- b )
- f over >r drop r> 1 + ;
+ f over [ drop ] dip 1 + ;
[ 1.0 aggressive-flush-regression drop ] must-fail
diff --git a/basis/compiler/tests/peg-regression.factor b/basis/compiler/tests/peg-regression.factor
index a0262fdc81..56a4021eed 100644
--- a/basis/compiler/tests/peg-regression.factor
+++ b/basis/compiler/tests/peg-regression.factor
@@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
USE: tools.test
-[ t ] [ \ expr compiled>> ] unit-test
-[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
+[ t ] [ \ expr optimized>> ] unit-test
+[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test
diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor
index 1b349d2296..b5835de5fd 100644
--- a/basis/compiler/tests/redefine1.factor
+++ b/basis/compiler/tests/redefine1.factor
@@ -23,36 +23,36 @@ M: integer method-redefine-test 3 + ;
: hey ( -- ) ;
: there ( -- ) hey ;
-[ t ] [ \ hey compiled>> ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ hey optimized>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ hey compiled>> ] unit-test
-[ f ] [ \ there compiled>> ] unit-test
+[ f ] [ \ hey optimized>> ] unit-test
+[ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ;
: bad ( -- ) good ;
: ugly ( -- ) bad ;
-[ t ] [ \ good compiled>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ good optimized>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ good compiled>> ] unit-test
-[ f ] [ \ bad compiled>> ] unit-test
-[ f ] [ \ ugly compiled>> ] unit-test
+[ f ] [ \ good optimized>> ] unit-test
+[ f ] [ \ bad optimized>> ] unit-test
+[ f ] [ \ ugly optimized>> ] unit-test
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
-[ t ] [ \ good compiled>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ good optimized>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
diff --git a/basis/compiler/tests/redefine3.factor b/basis/compiler/tests/redefine3.factor
index 941d086312..b25b5a1a5e 100644
--- a/basis/compiler/tests/redefine3.factor
+++ b/basis/compiler/tests/redefine3.factor
@@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
: sheeple-test ( -- string ) { } sheeple ;
[ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled>> ] unit-test
+[ t ] [ \ sheeple-test optimized>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
@@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
[ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
[ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled>> ] unit-test
+[ t ] [ \ sheeple-test optimized>> ] unit-test
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
diff --git a/basis/compiler/tests/simple.factor b/basis/compiler/tests/simple.factor
index c1e23c3e1e..a6d6c5dfb9 100644
--- a/basis/compiler/tests/simple.factor
+++ b/basis/compiler/tests/simple.factor
@@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
- "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
+ "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
] unit-test
] times
diff --git a/basis/compiler/tests/spilling.factor b/basis/compiler/tests/spilling.factor
index ee8c2f056a..4092352fd5 100644
--- a/basis/compiler/tests/spilling.factor
+++ b/basis/compiler/tests/spilling.factor
@@ -47,7 +47,7 @@ IN: compiler.tests
[ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
[ 1.0 float-spill-bug ] unit-test
-[ t ] [ \ float-spill-bug compiled>> ] unit-test
+[ t ] [ \ float-spill-bug optimized>> ] unit-test
: float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
{
@@ -132,7 +132,7 @@ IN: compiler.tests
[ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
[ 1.0 float-fixnum-spill-bug ] unit-test
-[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
: resolve-spill-bug ( a b -- c )
[ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@@ -159,7 +159,7 @@ IN: compiler.tests
16 narray
] if ;
-[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
[ 4 ] [ 1 1 resolve-spill-bug ] unit-test
diff --git a/basis/compiler/tree/checker/checker.factor b/basis/compiler/tree/checker/checker.factor
index 4f99fa015d..a5f18d6389 100644
--- a/basis/compiler/tree/checker/checker.factor
+++ b/basis/compiler/tree/checker/checker.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: sequences kernel sets namespaces accessors assocs
arrays combinators continuations columns math vectors
-stack-checker.branches
+grouping stack-checker.branches
compiler.tree
compiler.tree.def-use
compiler.tree.combinators ;
diff --git a/basis/compiler/tree/dead-code/dead-code-tests.factor b/basis/compiler/tree/dead-code/dead-code-tests.factor
index b64e30d8f9..7c28866e94 100644
--- a/basis/compiler/tree/dead-code/dead-code-tests.factor
+++ b/basis/compiler/tree/dead-code/dead-code-tests.factor
@@ -79,7 +79,7 @@ IN: compiler.tree.dead-code.tests
[ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
-[ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
+[ [ over >R + R> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
[ [ [ ] [ ] if ] ] [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test
diff --git a/basis/compiler/tree/debugger/debugger.factor b/basis/compiler/tree/debugger/debugger.factor
index e75e7f6046..9f2cc0536e 100644
--- a/basis/compiler/tree/debugger/debugger.factor
+++ b/basis/compiler/tree/debugger/debugger.factor
@@ -4,7 +4,7 @@ USING: kernel assocs match fry accessors namespaces make effects
sequences sequences.private quotations generic macros arrays
prettyprint prettyprint.backend prettyprint.custom
prettyprint.sections math words combinators
-combinators.short-circuit io sorting hints qualified
+combinators.short-circuit io sorting hints
compiler.tree
compiler.tree.recursive
compiler.tree.normalization
@@ -80,10 +80,12 @@ M: shuffle-node pprint* effect>> effect>string text ;
[ out-d>> length 1 = ]
} 1&& ;
+SYMBOLS: >R R> ;
+
M: #shuffle node>quot
{
- { [ dup #>r? ] [ drop \ >r , ] }
- { [ dup #r>? ] [ drop \ r> , ] }
+ { [ dup #>r? ] [ drop \ >R , ] }
+ { [ dup #r>? ] [ drop \ R> , ] }
{
[ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
[
diff --git a/basis/compiler/tree/escape-analysis/branches/branches.factor b/basis/compiler/tree/escape-analysis/branches/branches.factor
index 2eee3e698b..ca41ac59fc 100644
--- a/basis/compiler/tree/escape-analysis/branches/branches.factor
+++ b/basis/compiler/tree/escape-analysis/branches/branches.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces sequences sets fry columns
-stack-checker.branches
+grouping stack-checker.branches
compiler.tree
compiler.tree.propagation.branches
compiler.tree.escape-analysis.nodes
diff --git a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
index b535dfe39c..5d6a9cdea1 100644
--- a/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
+++ b/basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor
@@ -8,13 +8,13 @@ compiler.tree.debugger ;
: test-modular-arithmetic ( quot -- quot' )
build-tree optimize-tree nodes>quot ;
-[ [ >r >fixnum r> >fixnum fixnum+fast ] ]
+[ [ >R >fixnum R> >fixnum fixnum+fast ] ]
[ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
[ [ +-integer-integer dup >fixnum ] ]
[ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
-[ [ >r >fixnum r> >fixnum fixnum+fast 4 fixnum*fast ] ]
+[ [ >R >fixnum R> >fixnum fixnum+fast 4 fixnum*fast ] ]
[ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
TUPLE: declared-fixnum { x fixnum } ;
diff --git a/basis/compiler/tree/propagation/copy/copy.factor b/basis/compiler/tree/propagation/copy/copy.factor
index 53b7d17326..c989aaf672 100644
--- a/basis/compiler/tree/propagation/copy/copy.factor
+++ b/basis/compiler/tree/propagation/copy/copy.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: namespaces sequences assocs math kernel accessors fry
-combinators sets locals columns
+combinators sets locals columns grouping
stack-checker.branches
compiler.tree
compiler.tree.def-use
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index bd6d657442..7b3135e85c 100644
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -3,7 +3,7 @@
USING: accessors kernel arrays sequences math math.order
math.partial-dispatch generic generic.standard generic.math
classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations classes fry
+words namespaces continuations classes fry combinators.smart
compiler.tree
compiler.tree.builder
compiler.tree.recursive
@@ -134,17 +134,19 @@ DEFER: (flat-length)
over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
: inlining-rank ( #call word -- n )
- [ classes-known? 2 0 ? ]
[
- {
- [ body-length-bias ]
- [ "default" word-prop -4 0 ? ]
- [ "specializer" word-prop 1 0 ? ]
- [ method-body? 1 0 ? ]
- } cleave
- node-count-bias
- loop-nesting get 0 or 2 *
- ] bi* + + + + + + ;
+ [ classes-known? 2 0 ? ]
+ [
+ {
+ [ body-length-bias ]
+ [ "default" word-prop -4 0 ? ]
+ [ "specializer" word-prop 1 0 ? ]
+ [ method-body? 1 0 ? ]
+ } cleave
+ node-count-bias
+ loop-nesting get 0 or 2 *
+ ] bi*
+ ] sum-outputs ;
: should-inline? ( #call word -- ? )
dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index 4d8d935477..d5aa5318a4 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -6,7 +6,7 @@ math.parser math.order layouts words sequences sequences.private
arrays assocs classes classes.algebra combinators generic.math
splitting fry locals classes.tuple alien.accessors
classes.tuple.private slots.private definitions strings.private
-vectors hashtables
+vectors hashtables generic
stack-checker.state
compiler.tree.comparisons
compiler.tree.propagation.info
@@ -337,3 +337,12 @@ generic-comparison-ops [
bi
] [ 2drop object-info ] if
] "outputs" set-word-prop
+
+\ equal? [
+ ! If first input has a known type and second input is an
+ ! object, we convert this to [ swap equal? ].
+ in-d>> first2 value-info class>> object class= [
+ value-info class>> \ equal? specific-method
+ [ swap equal? ] f ?
+ ] [ drop f ] if
+] "custom-inlining" set-word-prop
diff --git a/basis/compiler/tree/propagation/propagation-tests.factor b/basis/compiler/tree/propagation/propagation-tests.factor
index d95245fe83..b9a88de34a 100644
--- a/basis/compiler/tree/propagation/propagation-tests.factor
+++ b/basis/compiler/tree/propagation/propagation-tests.factor
@@ -18,7 +18,7 @@ IN: compiler.tree.propagation.tests
[ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
-[ V{ fixnum } ] [ [ 1 >r r> ] final-classes ] unit-test
+[ V{ fixnum } ] [ [ 1 [ ] dip ] final-classes ] unit-test
[ V{ fixnum object } ] [ [ 1 swap ] final-classes ] unit-test
@@ -198,7 +198,7 @@ IN: compiler.tree.propagation.tests
[
{ fixnum byte-array } declare
[ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
- >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
+ [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
255 min 0 max
] final-classes
] unit-test
@@ -640,6 +640,10 @@ MIXIN: empty-mixin
[ { fixnum } declare log2 0 >= ] final-classes
] unit-test
+[ V{ POSTPONE: f } ] [
+ [ { word object } declare equal? ] final-classes
+] unit-test
+
! [ V{ string } ] [
! [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
! ] unit-test
diff --git a/basis/compiler/utilities/utilities.factor b/basis/compiler/utilities/utilities.factor
index 1f488b3dde..ec4ced8c9f 100644
--- a/basis/compiler/utilities/utilities.factor
+++ b/basis/compiler/utilities/utilities.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private arrays vectors fry
-math.order ;
+math.order namespaces assocs ;
IN: compiler.utilities
: flattener ( seq quot -- seq vector quot' )
@@ -22,10 +22,6 @@ IN: compiler.utilities
: 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
-: (3each) ( seq1 seq2 seq3 quot -- n quot' )
- [ [ [ length ] tri@ min min ] 3keep ] dip
- '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline
+SYMBOL: yield-hook
-: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
-
-: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline
+yield-hook global [ [ ] or ] change-at
diff --git a/basis/concurrency/combinators/combinators.factor b/basis/concurrency/combinators/combinators.factor
old mode 100644
new mode 100755
index 932605fc36..3d18b9e029
--- a/basis/concurrency/combinators/combinators.factor
+++ b/basis/concurrency/combinators/combinators.factor
@@ -28,7 +28,8 @@ PRIVATE>
: [future] ( quot -- quot' ) '[ _ curry future ] ; inline
-: future-values dup [ ?future ] change-each ; inline
+: future-values ( futures -- futures )
+ dup [ ?future ] change-each ; inline
PRIVATE>
diff --git a/basis/concurrency/distributed/distributed-tests.factor b/basis/concurrency/distributed/distributed-tests.factor
index 1087823aa0..996e3db4c0 100644
--- a/basis/concurrency/distributed/distributed-tests.factor
+++ b/basis/concurrency/distributed/distributed-tests.factor
@@ -1,7 +1,8 @@
IN: concurrency.distributed.tests
USING: tools.test concurrency.distributed kernel io.files
-arrays io.sockets system combinators threads math sequences
-concurrency.messaging continuations accessors prettyprint ;
+io.files.temp io.directories arrays io.sockets system
+combinators threads math sequences concurrency.messaging
+continuations accessors prettyprint ;
: test-node ( -- addrspec )
{
diff --git a/basis/concurrency/distributed/distributed.factor b/basis/concurrency/distributed/distributed.factor
index 99ad239011..ca1c5762f6 100644
--- a/basis/concurrency/distributed/distributed.factor
+++ b/basis/concurrency/distributed/distributed.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: serialize sequences concurrency.messaging threads io
io.servers.connection io.encodings.binary
-qualified arrays namespaces kernel accessors ;
+arrays namespaces kernel accessors ;
FROM: io.sockets => host-name with-client ;
IN: concurrency.distributed
diff --git a/basis/concurrency/messaging/messaging-docs.factor b/basis/concurrency/messaging/messaging-docs.factor
index 3bd2d330c3..41beedb6dc 100644
--- a/basis/concurrency/messaging/messaging-docs.factor
+++ b/basis/concurrency/messaging/messaging-docs.factor
@@ -53,7 +53,8 @@ ARTICLE: { "concurrency" "synchronous-sends" } "Synchronous sends"
{ $subsection reply-synchronous }
"An example:"
{ $example
- "USING: concurrency.messaging kernel threads ;"
+ "USING: concurrency.messaging kernel prettyprint threads ;"
+ "IN: scratchpad"
": pong-server ( -- )"
" receive [ \"pong\" ] dip reply-synchronous ;"
"[ pong-server t ] \"pong-server\" spawn-server"
diff --git a/basis/concurrency/messaging/messaging.factor b/basis/concurrency/messaging/messaging.factor
index 7a00f62e9e..61a3c38991 100644
--- a/basis/concurrency/messaging/messaging.factor
+++ b/basis/concurrency/messaging/messaging.factor
@@ -20,13 +20,13 @@ M: thread send ( message thread -- )
my-mailbox mailbox-get ?linked ;
: receive-timeout ( timeout -- message )
- my-mailbox swap mailbox-get-timeout ?linked ;
+ [ my-mailbox ] dip mailbox-get-timeout ?linked ;
: receive-if ( pred -- message )
- my-mailbox swap mailbox-get? ?linked ; inline
+ [ my-mailbox ] dip mailbox-get? ?linked ; inline
: receive-if-timeout ( timeout pred -- message )
- my-mailbox -rot mailbox-get-timeout? ?linked ; inline
+ [ my-mailbox ] 2dip mailbox-get-timeout? ?linked ; inline
: rethrow-linked ( error process supervisor -- )
[ ] dip send ;
diff --git a/basis/cords/authors.txt b/basis/cords/authors.txt
new file mode 100644
index 0000000000..1901f27a24
--- /dev/null
+++ b/basis/cords/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/cords/cords-tests.factor b/basis/cords/cords-tests.factor
new file mode 100644
index 0000000000..0058c8f07a
--- /dev/null
+++ b/basis/cords/cords-tests.factor
@@ -0,0 +1,5 @@
+IN: cords.tests
+USING: cords strings tools.test kernel sequences ;
+
+[ "hello world" ] [ "hello" " world" cord-append dup like ] unit-test
+[ "hello world" ] [ { "he" "llo" " world" } cord-concat dup like ] unit-test
diff --git a/basis/cords/cords.factor b/basis/cords/cords.factor
new file mode 100644
index 0000000000..915744491f
--- /dev/null
+++ b/basis/cords/cords.factor
@@ -0,0 +1,70 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs sequences sorting binary-search math
+math.order arrays combinators kernel ;
+IN: cords
+
+> length ] [ second>> length ] bi + ;
+
+M: simple-cord virtual-seq first>> ;
+
+M: simple-cord virtual@
+ 2dup first>> length <
+ [ first>> ] [ [ first>> length - ] [ second>> ] bi ] if ;
+
+TUPLE: multi-cord count seqs ;
+
+M: multi-cord length count>> ;
+
+M: multi-cord virtual@
+ dupd
+ seqs>> [ first <=> ] with search nip
+ [ first - ] [ second ] bi ;
+
+M: multi-cord virtual-seq
+ seqs>> [ f ] [ first second ] if-empty ;
+
+: ( seqs -- cord )
+ dup length 2 = [
+ first2 simple-cord boa
+ ] [
+ [ 0 [ length + ] accumulate ] keep zip multi-cord boa
+ ] if ;
+
+PRIVATE>
+
+UNION: cord simple-cord multi-cord ;
+
+INSTANCE: cord virtual-sequence
+
+INSTANCE: multi-cord virtual-sequence
+
+: cord-append ( seq1 seq2 -- cord )
+ {
+ { [ over empty? ] [ nip ] }
+ { [ dup empty? ] [ drop ] }
+ { [ 2dup [ cord? ] both? ] [ [ seqs>> values ] bi@ append ] }
+ { [ over cord? ] [ [ seqs>> values ] dip suffix ] }
+ { [ dup cord? ] [ seqs>> values swap prefix ] }
+ [ 2array ]
+ } cond ;
+
+: cord-concat ( seqs -- cord )
+ {
+ { [ dup empty? ] [ drop f ] }
+ { [ dup length 1 = ] [ first ] }
+ [
+ [
+ {
+ { [ dup cord? ] [ seqs>> values ] }
+ { [ dup empty? ] [ drop { } ] }
+ [ 1array ]
+ } cond
+ ] map concat
+ ]
+ } cond ;
diff --git a/basis/cords/summary.txt b/basis/cords/summary.txt
new file mode 100644
index 0000000000..3c69862b71
--- /dev/null
+++ b/basis/cords/summary.txt
@@ -0,0 +1 @@
+Virtual sequence concatenation
diff --git a/basis/cords/tags.txt b/basis/cords/tags.txt
new file mode 100644
index 0000000000..42d711b32b
--- /dev/null
+++ b/basis/cords/tags.txt
@@ -0,0 +1 @@
+collections
diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor
index 0f64c0666f..ec83ba7a8b 100644
--- a/basis/core-foundation/core-foundation.factor
+++ b/basis/core-foundation/core-foundation.factor
@@ -14,8 +14,7 @@ TYPEDEF: int SInt32
TYPEDEF: uint UInt32
TYPEDEF: ulong CFTypeID
TYPEDEF: UInt32 CFOptionFlags
-TYPEDEF: double CFTimeInterval
-TYPEDEF: double CFAbsoluteTime
+TYPEDEF: void* CFUUIDRef
FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
diff --git a/basis/core-foundation/data/data.factor b/basis/core-foundation/data/data.factor
index 043fb905ad..f4d2babca7 100644
--- a/basis/core-foundation/data/data.factor
+++ b/basis/core-foundation/data/data.factor
@@ -8,7 +8,6 @@ TYPEDEF: void* CFDictionaryRef
TYPEDEF: void* CFMutableDictionaryRef
TYPEDEF: void* CFNumberRef
TYPEDEF: void* CFSetRef
-TYPEDEF: void* CFUUIDRef
TYPEDEF: int CFNumberType
: kCFNumberSInt8Type 1 ; inline
diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor
index 7ed040b455..b0c299a831 100644
--- a/basis/core-foundation/fsevents/fsevents.factor
+++ b/basis/core-foundation/fsevents/fsevents.factor
@@ -5,7 +5,8 @@ math sequences namespaces make assocs init accessors
continuations combinators io.encodings.utf8 destructors locals
arrays specialized-arrays.direct.alien
specialized-arrays.direct.int specialized-arrays.direct.longlong
-core-foundation core-foundation.run-loop core-foundation.strings ;
+core-foundation core-foundation.run-loop core-foundation.strings
+core-foundation.time ;
IN: core-foundation.fsevents
: kFSEventStreamCreateFlagUseCFTypes 2 ; inline
diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor
index 475991a246..4b98e9a410 100644
--- a/basis/core-foundation/run-loop/run-loop.factor
+++ b/basis/core-foundation/run-loop/run-loop.factor
@@ -1,8 +1,10 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel namespaces core-foundation
-core-foundation.strings core-foundation.file-descriptors
-core-foundation.timers ;
+USING: accessors alien alien.syntax kernel math namespaces
+sequences destructors combinators threads heaps deques calendar
+core-foundation core-foundation.strings
+core-foundation.file-descriptors core-foundation.timers
+core-foundation.time ;
IN: core-foundation.run-loop
: kCFRunLoopRunFinished 1 ; inline
@@ -17,9 +19,9 @@ FUNCTION: CFRunLoopRef CFRunLoopGetMain ( ) ;
FUNCTION: CFRunLoopRef CFRunLoopGetCurrent ( ) ;
FUNCTION: SInt32 CFRunLoopRunInMode (
- CFStringRef mode,
- CFTimeInterval seconds,
- Boolean returnAfterSourceHandled
+ CFStringRef mode,
+ CFTimeInterval seconds,
+ Boolean returnAfterSourceHandled
) ;
FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
@@ -29,27 +31,27 @@ FUNCTION: CFRunLoopSourceRef CFFileDescriptorCreateRunLoopSource (
) ;
FUNCTION: void CFRunLoopAddSource (
- CFRunLoopRef rl,
- CFRunLoopSourceRef source,
- CFStringRef mode
+ CFRunLoopRef rl,
+ CFRunLoopSourceRef source,
+ CFStringRef mode
) ;
FUNCTION: void CFRunLoopRemoveSource (
- CFRunLoopRef rl,
- CFRunLoopSourceRef source,
- CFStringRef mode
+ CFRunLoopRef rl,
+ CFRunLoopSourceRef source,
+ CFStringRef mode
) ;
FUNCTION: void CFRunLoopAddTimer (
- CFRunLoopRef rl,
- CFRunLoopTimerRef timer,
- CFStringRef mode
+ CFRunLoopRef rl,
+ CFRunLoopTimerRef timer,
+ CFStringRef mode
) ;
FUNCTION: void CFRunLoopRemoveTimer (
- CFRunLoopRef rl,
- CFRunLoopTimerRef timer,
- CFStringRef mode
+ CFRunLoopRef rl,
+ CFRunLoopTimerRef timer,
+ CFStringRef mode
) ;
: CFRunLoopDefaultMode ( -- alien )
@@ -59,3 +61,80 @@ FUNCTION: void CFRunLoopRemoveTimer (
"kCFRunLoopDefaultMode"
dup \ CFRunLoopDefaultMode set-global
] when ;
+
+TUPLE: run-loop fds sources timers ;
+
+: ( -- run-loop )
+ V{ } clone V{ } clone V{ } clone \ run-loop boa ;
+
+SYMBOL: expiry-check
+
+: run-loop ( -- run-loop )
+ \ run-loop get-global not expiry-check get expired? or
+ [
+ 31337 expiry-check set-global
+ dup \ run-loop set-global
+ ] [ \ run-loop get-global ] if ;
+
+: add-source-to-run-loop ( source -- )
+ [ run-loop sources>> push ]
+ [
+ CFRunLoopGetMain
+ swap CFRunLoopDefaultMode
+ CFRunLoopAddSource
+ ] bi ;
+
+: create-fd-source ( CFFileDescriptor -- source )
+ f swap 0 CFFileDescriptorCreateRunLoopSource ;
+
+: add-fd-to-run-loop ( fd callback -- )
+ [
+ |CFRelease
+ [ run-loop fds>> push ]
+ [ create-fd-source |CFRelease add-source-to-run-loop ]
+ bi
+ ] with-destructors ;
+
+: add-timer-to-run-loop ( timer -- )
+ [ run-loop timers>> push ]
+ [
+ CFRunLoopGetMain
+ swap CFRunLoopDefaultMode
+ CFRunLoopAddTimer
+ ] bi ;
+
+CFAbsoluteTime CFRunLoopTimerSetNextFireDate ;
+
+: (reset-timer) ( timer counter -- )
+ yield {
+ { [ dup 0 = ] [ now ((reset-timer)) ] }
+ { [ run-queue deque-empty? not ] [ 1- (reset-timer) ] }
+ { [ sleep-queue heap-empty? ] [ 5 minutes hence ((reset-timer)) ] }
+ [ sleep-queue heap-peek nip micros>timestamp ((reset-timer)) ]
+ } cond ;
+
+: reset-timer ( timer -- )
+ 10 (reset-timer) ;
+
+PRIVATE>
+
+: reset-run-loop ( -- )
+ run-loop
+ [ timers>> [ reset-timer ] each ]
+ [ fds>> [ enable-all-callbacks ] each ] bi ;
+
+: timer-callback ( -- callback )
+ "void" { "CFRunLoopTimerRef" "void*" } "cdecl"
+ [ 2drop reset-run-loop yield ] alien-callback ;
+
+: init-thread-timer ( -- )
+ timer-callback add-timer-to-run-loop ;
+
+: run-one-iteration ( us -- handled? )
+ reset-run-loop
+ CFRunLoopDefaultMode
+ swap [ microseconds ] [ 5 minutes ] if* >CFTimeInterval
+ t CFRunLoopRunInMode kCFRunLoopRunHandledSource = ;
diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor
index 2e6180c897..c3a969a325 100644
--- a/basis/core-foundation/strings/strings.factor
+++ b/basis/core-foundation/strings/strings.factor
@@ -23,11 +23,11 @@ TYPEDEF: int CFStringEncoding
: kCFStringEncodingUTF32LE HEX: 1c000100 ;
FUNCTION: CFStringRef CFStringCreateWithBytes (
- CFAllocatorRef alloc,
- UInt8* bytes,
- CFIndex numBytes,
- CFStringEncoding encoding,
- Boolean isExternalRepresentation
+ CFAllocatorRef alloc,
+ UInt8* bytes,
+ CFIndex numBytes,
+ CFStringEncoding encoding,
+ Boolean isExternalRepresentation
) ;
FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
@@ -35,16 +35,16 @@ FUNCTION: CFIndex CFStringGetLength ( CFStringRef theString ) ;
FUNCTION: void CFStringGetCharacters ( void* theString, CFIndex start, CFIndex length, void* buffer ) ;
FUNCTION: Boolean CFStringGetCString (
- CFStringRef theString,
- char* buffer,
- CFIndex bufferSize,
- CFStringEncoding encoding
+ CFStringRef theString,
+ char* buffer,
+ CFIndex bufferSize,
+ CFStringEncoding encoding
) ;
FUNCTION: CFStringRef CFStringCreateWithCString (
- CFAllocatorRef alloc,
- char* cStr,
- CFStringEncoding encoding
+ CFAllocatorRef alloc,
+ char* cStr,
+ CFStringEncoding encoding
) ;
: ( string -- alien )
diff --git a/basis/core-foundation/time/time.factor b/basis/core-foundation/time/time.factor
new file mode 100644
index 0000000000..15ad7bb1a1
--- /dev/null
+++ b/basis/core-foundation/time/time.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar alien.syntax ;
+IN: core-foundation.time
+
+TYPEDEF: double CFTimeInterval
+TYPEDEF: double CFAbsoluteTime
+
+: >CFTimeInterval ( duration -- interval )
+ duration>seconds ; inline
+
+: >CFAbsoluteTime ( timestamp -- time )
+ T{ timestamp { year 2001 } { month 1 } { day 1 } } time-
+ duration>seconds ; inline
diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor
index 049e80b20f..51ee982592 100644
--- a/basis/core-foundation/timers/timers.factor
+++ b/basis/core-foundation/timers/timers.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax system math kernel core-foundation ;
+USING: alien.syntax system math kernel calendar core-foundation
+core-foundation.time ;
IN: core-foundation.timers
TYPEDEF: void* CFRunLoopTimerRef
@@ -18,12 +19,16 @@ FUNCTION: CFRunLoopTimerRef CFRunLoopTimerCreate (
) ;
: ( callback -- timer )
- [ f millis 1000 /f 60 0 0 ] dip f CFRunLoopTimerCreate ;
+ [ f now >CFAbsoluteTime 60 0 0 ] dip f CFRunLoopTimerCreate ;
FUNCTION: void CFRunLoopTimerInvalidate (
CFRunLoopTimerRef timer
) ;
+FUNCTION: Boolean CFRunLoopTimerIsValid (
+ CFRunLoopTimerRef timer
+) ;
+
FUNCTION: void CFRunLoopTimerSetNextFireDate (
CFRunLoopTimerRef timer,
CFAbsoluteTime fireDate
diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor
index c609b9e98d..5670110f04 100644
--- a/basis/cpu/architecture/architecture.factor
+++ b/basis/cpu/architecture/architecture.factor
@@ -38,7 +38,7 @@ M: object param-reg param-regs nth ;
HOOK: two-operand? cpu ( -- ? )
HOOK: %load-immediate cpu ( reg obj -- )
-HOOK: %load-indirect cpu ( reg obj -- )
+HOOK: %load-reference cpu ( reg obj -- )
HOOK: %peek cpu ( vreg loc -- )
HOOK: %replace cpu ( vreg loc -- )
diff --git a/basis/cpu/ppc/assembler/assembler.factor b/basis/cpu/ppc/assembler/assembler.factor
index f94cc00abc..fbb878a888 100644
--- a/basis/cpu/ppc/assembler/assembler.factor
+++ b/basis/cpu/ppc/assembler/assembler.factor
@@ -97,10 +97,10 @@ X: XOR 0 316 31
X: XOR. 1 316 31
X1: EXTSB 0 954 31
X1: EXTSB. 1 954 31
-: FMR ( a s -- ) 0 -rot 72 0 63 x-insn ;
-: FMR. ( a s -- ) 0 -rot 72 1 63 x-insn ;
-: FCTIWZ ( a s -- ) 0 -rot 0 15 63 x-insn ;
-: FCTIWZ. ( a s -- ) 0 -rot 1 15 63 x-insn ;
+: FMR ( a s -- ) [ 0 ] 2dip 72 0 63 x-insn ;
+: FMR. ( a s -- ) [ 0 ] 2dip 72 1 63 x-insn ;
+: FCTIWZ ( a s -- ) [ 0 ] 2dip 0 15 63 x-insn ;
+: FCTIWZ. ( a s -- ) [ 0 ] 2dip 1 15 63 x-insn ;
! XO-form
XO: ADD 0 0 266 31
@@ -189,21 +189,21 @@ MTSPR: LR 8
MTSPR: CTR 9
! Pseudo-instructions
-: LI 0 rot ADDI ; inline
-: SUBI neg ADDI ; inline
-: LIS 0 rot ADDIS ; inline
-: SUBIC neg ADDIC ; inline
-: SUBIC. neg ADDIC. ; inline
-: NOT dup NOR ; inline
-: NOT. dup NOR. ; inline
-: MR dup OR ; inline
-: MR. dup OR. ; inline
-: (SLWI) 0 31 pick - ; inline
+: LI ( value dst -- ) 0 rot ADDI ; inline
+: SUBI ( dst src1 src2 -- ) neg ADDI ; inline
+: LIS ( value dst -- ) 0 rot ADDIS ; inline
+: SUBIC ( dst src1 src2 -- ) neg ADDIC ; inline
+: SUBIC. ( dst src1 src2 -- ) neg ADDIC. ; inline
+: NOT ( dst src -- ) dup NOR ; inline
+: NOT. ( dst src -- ) dup NOR. ; inline
+: MR ( dst src -- ) dup OR ; inline
+: MR. ( dst src -- ) dup OR. ; inline
+: (SLWI) ( d a b -- d a b x y ) 0 31 pick - ; inline
: SLWI ( d a b -- ) (SLWI) RLWINM ;
: SLWI. ( d a b -- ) (SLWI) RLWINM. ;
-: (SRWI) 32 over - swap 31 ; inline
+: (SRWI) ( d a b -- d a b x y ) 32 over - swap 31 ; inline
: SRWI ( d a b -- ) (SRWI) RLWINM ;
: SRWI. ( d a b -- ) (SRWI) RLWINM. ;
-: LOAD32 ( n r -- ) >r w>h/h r> tuck LIS dup rot ORI ;
+: LOAD32 ( n r -- ) [ w>h/h ] dip tuck LIS dup rot ORI ;
: immediate? ( n -- ? ) HEX: -8000 HEX: 7fff between? ;
: LOAD ( n r -- ) over immediate? [ LI ] [ LOAD32 ] if ;
diff --git a/basis/cpu/ppc/assembler/backend/backend.factor b/basis/cpu/ppc/assembler/backend/backend.factor
index 881b094ca2..c6a3a94194 100644
--- a/basis/cpu/ppc/assembler/backend/backend.factor
+++ b/basis/cpu/ppc/assembler/backend/backend.factor
@@ -74,13 +74,13 @@ IN: cpu.ppc.assembler.backend
GENERIC# (B) 2 ( dest aa lk -- )
M: integer (B) 18 i-insn ;
-M: word (B) 0 -rot (B) rc-relative-ppc-3 rel-word ;
-M: label (B) 0 -rot (B) rc-relative-ppc-3 label-fixup ;
+M: word (B) [ 0 ] 2dip (B) rc-relative-ppc-3 rel-word ;
+M: label (B) [ 0 ] 2dip (B) rc-relative-ppc-3 label-fixup ;
GENERIC: BC ( a b c -- )
M: integer BC 0 0 16 b-insn ;
-M: word BC >r 0 BC r> rc-relative-ppc-2 rel-word ;
-M: label BC >r 0 BC r> rc-relative-ppc-2 label-fixup ;
+M: word BC [ 0 BC ] dip rc-relative-ppc-2 rel-word ;
+M: label BC [ 0 BC ] dip rc-relative-ppc-2 label-fixup ;
: CREATE-B ( -- word ) scan "B" prepend create-in ;
diff --git a/basis/cpu/ppc/bootstrap.factor b/basis/cpu/ppc/bootstrap.factor
index 445c7082bc..b27f3aee72 100644
--- a/basis/cpu/ppc/bootstrap.factor
+++ b/basis/cpu/ppc/bootstrap.factor
@@ -302,9 +302,7 @@ big-endian on
4 ds-reg 0 STW
] f f f \ -rot define-sub-primitive
-[ jit->r ] f f f \ >r define-sub-primitive
-
-[ jit-r> ] f f f \ r> define-sub-primitive
+[ jit->r ] f f f \ load-local define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index c555c4b809..b177c71d77 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -34,7 +34,7 @@ M: ppc two-operand? f ;
M: ppc %load-immediate ( reg n -- ) swap LOAD ;
-M: ppc %load-indirect ( reg obj -- )
+M: ppc %load-reference ( reg obj -- )
[ 0 swap LOAD32 ] [ rc-absolute-ppc-2/2 rel-immediate ] bi* ;
M: ppc %alien-global ( register symbol dll -- )
@@ -261,7 +261,7 @@ M:: ppc %fixnum-mul-tail ( src1 src2 temp1 temp2 -- )
M:: ppc %integer>bignum ( dst src temp -- )
[
"end" define-label
- dst 0 >bignum %load-indirect
+ dst 0 >bignum %load-reference
! Is it zero? Then just go to the end and return this zero
0 src 0 CMPI
"end" get BEQ
@@ -321,7 +321,7 @@ M:: ppc %integer>float ( dst src -- )
scratch-reg dup HEX: 8000 XORIS
scratch-reg 1 4 scratch@ STW
dst 1 0 scratch@ LFD
- scratch-reg 4503601774854144.0 %load-indirect
+ scratch-reg 4503601774854144.0 %load-reference
fp-scratch-reg scratch-reg float-offset LFD
dst dst fp-scratch-reg FSUB ;
@@ -467,26 +467,28 @@ M: ppc %gc
M: ppc %prologue ( n -- )
0 11 LOAD32 rc-absolute-ppc-2/2 rel-this
0 MFLR
- 1 1 pick neg ADDI
- 11 1 pick xt-save STW
- dup 11 LI
- 11 1 pick next-save STW
- 0 1 rot lr-save + STW ;
+ {
+ [ [ 1 1 ] dip neg ADDI ]
+ [ [ 11 1 ] dip xt-save STW ]
+ [ 11 LI ]
+ [ [ 11 1 ] dip next-save STW ]
+ [ [ 0 1 ] dip lr-save + STW ]
+ } cleave ;
M: ppc %epilogue ( n -- )
#! At the end of each word that calls a subroutine, we store
#! the previous link register value in r0 by popping it off
#! the stack, set the link register to the contents of r0,
#! and jump to the link register.
- 0 1 pick lr-save + LWZ
- 1 1 rot ADDI
+ [ [ 0 1 ] dip lr-save + LWZ ]
+ [ [ 1 1 ] dip ADDI ] bi
0 MTLR ;
:: (%boolean) ( dst temp word -- )
"end" define-label
dst \ f tag-number %load-immediate
"end" get word execute
- dst \ t %load-indirect
+ dst \ t %load-reference
"end" get resolve-label ; inline
: %boolean ( dst temp cc -- )
@@ -541,17 +543,17 @@ GENERIC: STF ( src dst off reg-class -- )
M: single-float-regs STF drop STFS ;
M: double-float-regs STF drop STFD ;
-M: float-regs %save-param-reg >r 1 rot local@ r> STF ;
+M: float-regs %save-param-reg [ 1 rot local@ ] dip STF ;
GENERIC: LF ( dst src off reg-class -- )
M: single-float-regs LF drop LFS ;
M: double-float-regs LF drop LFD ;
-M: float-regs %load-param-reg >r 1 rot local@ r> LF ;
+M: float-regs %load-param-reg [ 1 rot local@ ] dip LF ;
M: stack-params %load-param-reg ( stack reg reg-class -- )
- drop >r 0 1 rot local@ LWZ 0 1 r> param@ STW ;
+ drop [ 0 1 rot local@ LWZ 0 1 ] dip param@ STW ;
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
@@ -559,8 +561,8 @@ M: stack-params %save-param-reg ( stack reg reg-class -- )
#! Funky. Read the parameter from the caller's stack frame.
#! This word is used in callbacks
drop
- 0 1 rot next-param@ LWZ
- 0 1 rot local@ STW ;
+ [ 0 1 ] dip next-param@ LWZ
+ [ 0 1 ] dip local@ STW ;
M: ppc %prepare-unbox ( -- )
! First parameter is top of stack
@@ -580,14 +582,14 @@ M: ppc %unbox-long-long ( n func -- )
f %alien-invoke
! Store the return value on the C stack
[
- 3 1 pick local@ STW
- 4 1 rot cell + local@ STW
+ [ [ 3 1 ] dip local@ STW ]
+ [ [ 4 1 ] dip cell + local@ STW ] bi
] when* ;
M: ppc %unbox-large-struct ( n c-type -- )
! Value must be in r3
! Compute destination address and load struct size
- [ 4 1 rot local@ ADDI ] [ heap-size 5 LI ] bi*
+ [ [ 4 1 ] dip local@ ADDI ] [ heap-size 5 LI ] bi*
! Call the function
"to_value_struct" f %alien-invoke ;
@@ -595,15 +597,16 @@ M: ppc %box ( n reg-class func -- )
! If the source is a stack location, load it into freg #0.
! If the source is f, then we assume the value is already in
! freg #0.
- >r
- over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
- r> f %alien-invoke ;
+ [ over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if ] dip
+ f %alien-invoke ;
M: ppc %box-long-long ( n func -- )
- >r [
- 3 1 pick local@ LWZ
- 4 1 rot cell + local@ LWZ
- ] when* r> f %alien-invoke ;
+ [
+ [
+ [ [ 3 1 ] dip local@ LWZ ]
+ [ [ 4 1 ] dip cell + local@ LWZ ] bi
+ ] when*
+ ] dip f %alien-invoke ;
: struct-return@ ( n -- n )
[ stack-frame get params>> ] unless* local@ ;
@@ -616,7 +619,7 @@ M: ppc %prepare-box-struct ( -- )
M: ppc %box-large-struct ( n c-type -- )
! If n = f, then we're boxing a returned struct
! Compute destination address and load struct size
- [ 3 1 rot struct-return@ ADDI ] [ heap-size 4 LI ] bi*
+ [ [ 3 1 ] dip struct-return@ ADDI ] [ heap-size 4 LI ] bi*
! Call the function
"box_value_struct" f %alien-invoke ;
@@ -634,7 +637,7 @@ M: ppc %alien-invoke ( symbol dll -- )
[ 11 ] 2dip %alien-global 11 MTLR BLRL ;
M: ppc %alien-callback ( quot -- )
- 3 swap %load-indirect "c_to_factor" f %alien-invoke ;
+ 3 swap %load-reference "c_to_factor" f %alien-invoke ;
M: ppc %prepare-alien-indirect ( -- )
"unbox_alien" f %alien-invoke
diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor
index 5e06e72118..affd39ffc5 100755
--- a/basis/cpu/x86/32/32.factor
+++ b/basis/cpu/x86/32/32.factor
@@ -237,7 +237,7 @@ M: x86.32 %alien-indirect ( -- )
M: x86.32 %alien-callback ( quot -- )
4 [
- EAX swap %load-indirect
+ EAX swap %load-reference
EAX PUSH
"c_to_factor" f %alien-invoke
] with-aligned-stack ;
diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor
index 2077f51e0a..8cc69958a4 100644
--- a/basis/cpu/x86/64/64.factor
+++ b/basis/cpu/x86/64/64.factor
@@ -37,7 +37,7 @@ M:: x86.64 %dispatch ( src temp offset -- )
M: x86.64 param-reg-1 int-regs param-regs first ;
M: x86.64 param-reg-2 int-regs param-regs second ;
-: param-reg-3 int-regs param-regs third ; inline
+: param-reg-3 ( -- reg ) int-regs param-regs third ; inline
M: int-regs return-reg drop RAX ;
M: float-regs return-reg drop XMM0 ;
@@ -50,8 +50,8 @@ M: x86.64 %prologue ( n -- )
M: stack-params %load-param-reg
drop
- >r R11 swap param@ MOV
- r> param@ R11 MOV ;
+ [ R11 swap param@ MOV ] dip
+ param@ R11 MOV ;
M: stack-params %save-param-reg
drop
@@ -176,7 +176,7 @@ M: x86.64 %alien-indirect ( -- )
RBP CALL ;
M: x86.64 %alien-callback ( quot -- )
- param-reg-1 swap %load-indirect
+ param-reg-1 swap %load-reference
"c_to_factor" f %alien-invoke ;
M: x86.64 %callback-value ( ctype -- )
diff --git a/basis/cpu/x86/assembler/syntax/syntax.factor b/basis/cpu/x86/assembler/syntax/syntax.factor
index 6ddec4af07..343850f9e6 100644
--- a/basis/cpu/x86/assembler/syntax/syntax.factor
+++ b/basis/cpu/x86/assembler/syntax/syntax.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words sequences lexer parser fry ;
+USING: kernel words words.symbol sequences lexer parser fry ;
IN: cpu.x86.assembler.syntax
: define-register ( name num size -- )
diff --git a/basis/cpu/x86/bootstrap.factor b/basis/cpu/x86/bootstrap.factor
index 42fcfaa6a2..5e3405e93a 100644
--- a/basis/cpu/x86/bootstrap.factor
+++ b/basis/cpu/x86/bootstrap.factor
@@ -79,9 +79,10 @@ big-endian off
! compute quotation location
temp0 temp1 ADD
! load quotation
- temp0 temp0 array-start-offset [+] MOV
- ! execute branch
- temp0 quot-xt-offset [+] JMP
+ arg temp0 array-start-offset [+] MOV
+ ! execute branch. the quot must be in arg, since it might
+ ! not be compiled yet
+ arg quot-xt-offset [+] JMP
] rc-absolute-cell rt-immediate 1 rex-length + jit-dispatch jit-define
: jit->r ( -- )
@@ -318,9 +319,7 @@ big-endian off
ds-reg [] temp1 MOV
] f f f \ -rot define-sub-primitive
-[ jit->r ] f f f \ >r define-sub-primitive
-
-[ jit-r> ] f f f \ r> define-sub-primitive
+[ jit->r ] f f f \ load-local define-sub-primitive
! Comparisons
: jit-compare ( insn -- )
diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor
index 44300a75f9..2859e71be2 100644
--- a/basis/cpu/x86/x86.factor
+++ b/basis/cpu/x86/x86.factor
@@ -21,7 +21,7 @@ HOOK: param-reg-2 cpu ( -- reg )
M: x86 %load-immediate MOV ;
-M: x86 %load-indirect swap 0 MOV rc-absolute-cell rel-immediate ;
+M: x86 %load-reference swap 0 MOV rc-absolute-cell rel-immediate ;
HOOK: ds-reg cpu ( -- reg )
HOOK: rs-reg cpu ( -- reg )
@@ -188,7 +188,7 @@ M:: x86 %integer>bignum ( dst src temp -- )
[
"end" define-label
! Load cached zero value
- dst 0 >bignum %load-indirect
+ dst 0 >bignum %load-reference
src 0 CMP
! Is it zero? Then just go to the end and return this zero
"end" get JE
diff --git a/basis/csv/csv.factor b/basis/csv/csv.factor
index 133223b6e4..483a5825a9 100644
--- a/basis/csv/csv.factor
+++ b/basis/csv/csv.factor
@@ -12,7 +12,7 @@ SYMBOL: delimiter
CHAR: , delimiter set-global
-: delimiter> delimiter get ; inline
+: delimiter> ( -- delimiter ) delimiter get ; inline
DEFER: quoted-field ( -- endchar )
diff --git a/basis/db/db-docs.factor b/basis/db/db-docs.factor
index 8173ff6a5b..08544b3367 100644
--- a/basis/db/db-docs.factor
+++ b/basis/db/db-docs.factor
@@ -1,20 +1,20 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: classes kernel help.markup help.syntax sequences
-alien assocs strings math multiline quotations ;
+alien assocs strings math multiline quotations db.private ;
IN: db
-HELP: db
-{ $description "The " { $snippet "db" } " class is the superclass of all other database classes. It stores a " { $snippet "handle" } " to the database as well as insert, update, and delete queries." } ;
+HELP: db-connection
+{ $description "The " { $snippet "db-connection" } " class is the superclass of all other database classes. It stores a " { $snippet "handle" } " to the database as well as insert, update, and delete queries. Stores the current database object as a dynamic variable." } ;
-HELP: new-db
-{ $values { "class" class } { "obj" object } }
+HELP: new-db-connection
+{ $values { "class" class } { "obj" db-connection } }
{ $description "Creates a new database object from a given class with caches for prepared statements. Does not actually connect to the database until " { $link db-open } " or " { $link with-db } " is called." }
{ $notes "User-defined databases must call this constructor word instead of " { $link new } "." } ;
HELP: db-open
-{ $values { "db" db } { "db" db } }
-{ $description "Opens a database using the configuration data stored in a " { $link db } " tuple. The database object now references a database handle that must be cleaned up. Therefore, it is better to use the " { $link with-db } " combinator than calling this word directly." } ;
+{ $values { "db" "a database configuration object" } { "db-connection" db-connection } }
+{ $description "Opens a database using the configuration data stored in a " { $snippet "database configuration object" } "tuple. The database object now references a database handle that must be cleaned up. Therefore, it is better to use the " { $link with-db } " combinator than calling this word directly." } ;
HELP: db-close
{ $values { "handle" alien } }
@@ -141,13 +141,13 @@ HELP: rollback-transaction
HELP: sql-command
{ $values
{ "sql" string } }
-{ $description "Executes a SQL string using the databse in the " { $link db } " symbol." } ;
+{ $description "Executes a SQL string using the databse in the " { $link db-connection } " symbol." } ;
HELP: sql-query
{ $values
{ "sql" string }
{ "rows" "an array of arrays of strings" } }
-{ $description "Runs a SQL query of raw text in the database in the " { $link db } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ;
+{ $description "Runs a SQL query of raw text in the database in the " { $link db-connection } " symbol. Each row is returned as an array of strings; no type-conversions are done on the resulting data." } ;
{ sql-command sql-query } related-words
@@ -167,8 +167,8 @@ HELP: sql-row-typed
HELP: with-db
{ $values
- { "db" db } { "quot" quotation } }
-{ $description "Calls the quotation with a database bound to the " { $link db } " symbol. See " { $link "db-custom-database-combinators" } " for help setting up database access." } ;
+ { "db" "a database configuration object" } { "quot" quotation } }
+{ $description "Calls the quotation with a database bound to the " { $link db-connection } " symbol. See " { $link "db-custom-database-combinators" } " for help setting up database access." } ;
HELP: with-transaction
{ $values
@@ -244,13 +244,13 @@ ARTICLE: "db-protocol" "Low-level database protocol"
! { $subsection bind-tuple }
ARTICLE: "db-lowlevel-tutorial" "Low-level database tutorial"
-"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "."
+"Although Factor makes integrating a database with its object system easy (see " { $vocab-link "db.tuples" } "), sometimes you may want to write SQL directly and get the results back as arrays of strings, for instance, when interfacing with a legacy database that doesn't easily map to " { $snippet "tuples" } "." $nl
"Executing a SQL command:"
{ $subsection sql-command }
"Executing a query directly:"
{ $subsection sql-query }
"Here's an example usage where we'll make a book table, insert some objects, and query them." $nl
-"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
+"First, let's set up a custom combinator for using our database. See " { $link "db-custom-database-combinators" } " for more details."
{ $code <"
USING: db.sqlite db io.files ;
: with-book-db ( quot -- )
diff --git a/basis/db/db.factor b/basis/db/db.factor
index b7bd8218a2..0b18044f2b 100644
--- a/basis/db/db.factor
+++ b/basis/db/db.factor
@@ -5,25 +5,29 @@ namespaces sequences classes.tuple words strings
tools.walker accessors combinators fry ;
IN: db
-TUPLE: db
+>insert-statements
H{ } clone >>update-statements
H{ } clone >>delete-statements ; inline
-GENERIC: db-open ( db -- db )
-HOOK: db-close db ( handle -- )
+PRIVATE>
+
+GENERIC: db-open ( db -- db-connection )
+HOOK: db-close db-connection ( handle -- )
: dispose-statements ( assoc -- ) values dispose-each ;
-M: db dispose ( db -- )
- dup db [
+M: db-connection dispose ( db-connection -- )
+ dup db-connection [
[ dispose-statements H{ } clone ] change-insert-statements
[ dispose-statements H{ } clone ] change-update-statements
[ dispose-statements H{ } clone ] change-delete-statements
@@ -63,8 +67,8 @@ TUPLE: prepared-statement < statement ;
swap >>in-params
swap >>sql ;
-HOOK: db ( string in out -- statement )
-HOOK: db ( string in out -- statement )
+HOOK: db-connection ( string in out -- statement )
+HOOK: db-connection ( string in out -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( statement -- )
GENERIC: low-level-bind ( statement -- )
@@ -107,8 +111,8 @@ M: object execute-statement* ( statement type -- )
accumulator [ query-each ] dip { } like ; inline
: with-db ( db quot -- )
- [ db-open db ] dip
- '[ db get [ drop @ ] with-disposal ] with-variable ; inline
+ [ db-open db-connection ] dip
+ '[ db-connection get [ drop @ ] with-disposal ] with-variable ; inline
! Words for working with raw SQL statements
: default-query ( query -- result-set )
@@ -126,13 +130,13 @@ M: object execute-statement* ( statement type -- )
! Transactions
SYMBOL: in-transaction
-HOOK: begin-transaction db ( -- )
-HOOK: commit-transaction db ( -- )
-HOOK: rollback-transaction db ( -- )
+HOOK: begin-transaction db-connection ( -- )
+HOOK: commit-transaction db-connection ( -- )
+HOOK: rollback-transaction db-connection ( -- )
-M: db begin-transaction ( -- ) "BEGIN" sql-command ;
-M: db commit-transaction ( -- ) "COMMIT" sql-command ;
-M: db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
+M: db-connection begin-transaction ( -- ) "BEGIN" sql-command ;
+M: db-connection commit-transaction ( -- ) "COMMIT" sql-command ;
+M: db-connection rollback-transaction ( -- ) "ROLLBACK" sql-command ;
: in-transaction? ( -- ? ) in-transaction get ;
diff --git a/basis/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor
index 0a68db501b..7ff2a33d92 100644
--- a/basis/db/pools/pools-tests.factor
+++ b/basis/db/pools/pools-tests.factor
@@ -1,6 +1,6 @@
IN: db.pools.tests
-USING: db.pools tools.test continuations io.files namespaces
-accessors kernel math destructors ;
+USING: db.pools tools.test continuations io.files io.files.temp
+io.directories namespaces accessors kernel math destructors ;
\ must-infer
diff --git a/basis/db/pools/pools.factor b/basis/db/pools/pools.factor
index 8bc5e87f0e..55ff3a383b 100644
--- a/basis/db/pools/pools.factor
+++ b/basis/db/pools/pools.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays namespaces sequences continuations
-io.pools db fry ;
+io.pools db fry db.private ;
IN: db.pools
TUPLE: db-pool < pool db ;
@@ -17,4 +17,4 @@ M: db-pool make-connection ( pool -- )
db>> db-open ;
: with-pooled-db ( pool quot -- )
- '[ db _ with-variable ] with-pooled-connection ; inline
+ '[ db-connection _ with-variable ] with-pooled-connection ; inline
diff --git a/basis/db/postgresql/lib/lib.factor b/basis/db/postgresql/lib/lib.factor
index 5149d14f3d..19cf5c5002 100644
--- a/basis/db/postgresql/lib/lib.factor
+++ b/basis/db/postgresql/lib/lib.factor
@@ -6,7 +6,7 @@ db.types tools.walker ascii splitting math.parser combinators
libc shuffle calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary io.encodings.utf8
alien.strings io.streams.byte-array summary present urls
-specialized-arrays.uint specialized-arrays.alien ;
+specialized-arrays.uint specialized-arrays.alien db.private ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
@@ -24,7 +24,7 @@ IN: db.postgresql.lib
"\n" split [ [ blank? ] trim ] map "\n" join ;
: postgresql-error-message ( -- str )
- db get handle>> (postgresql-error-message) ;
+ db-connection get handle>> (postgresql-error-message) ;
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
@@ -44,7 +44,7 @@ M: postgresql-result-null summary ( obj -- str )
dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
: do-postgresql-statement ( statement -- res )
- db get handle>> swap sql>> PQexec dup postgresql-result-ok? [
+ db-connection get handle>> swap sql>> PQexec dup postgresql-result-ok? [
[ postgresql-result-error-message ] [ PQclear ] bi throw
] unless ;
@@ -99,7 +99,7 @@ M: postgresql-result-null summary ( obj -- str )
: do-postgresql-bound-statement ( statement -- res )
[
- [ db get handle>> ] dip
+ [ db-connection get handle>> ] dip
{
[ sql>> ]
[ bind-params>> length ]
diff --git a/basis/db/postgresql/postgresql-tests.factor b/basis/db/postgresql/postgresql-tests.factor
index bc5ec2f0c5..cf6dc903f1 100644
--- a/basis/db/postgresql/postgresql-tests.factor
+++ b/basis/db/postgresql/postgresql-tests.factor
@@ -1,5 +1,5 @@
USING: kernel db.postgresql alien continuations io classes
-prettyprint sequences namespaces tools.test db
+prettyprint sequences namespaces tools.test db db.private
db.tuples db.types unicode.case accessors system ;
IN: db.postgresql.tests
@@ -92,7 +92,3 @@ os windows? cpu x86.64? and [
] with-db
] unit-test
] unless
-
-
-: with-dummy-db ( quot -- )
- [ T{ postgresql-db } db ] dip with-variable ;
diff --git a/basis/db/postgresql/postgresql.factor b/basis/db/postgresql/postgresql.factor
index 90a875b8ff..1f55dcf769 100644
--- a/basis/db/postgresql/postgresql.factor
+++ b/basis/db/postgresql/postgresql.factor
@@ -4,23 +4,31 @@ USING: arrays assocs alien alien.syntax continuations io
kernel math math.parser namespaces make prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
-combinators classes locals words tools.walker
+combinators classes locals words tools.walker db.private
nmake accessors random db.queries destructors db.tuples.private ;
USE: tools.walker
IN: db.postgresql
-TUPLE: postgresql-db < db
- host port pgopts pgtty database username password ;
+TUPLE: postgresql-db host port pgopts pgtty database username password ;
: ( -- postgresql-db )
- postgresql-db new-db ;
+ postgresql-db new ;
+
+ ( handle -- db-connection )
+ postgresql-db-connection new-db-connection
+ swap >>handle ;
+
+PRIVATE>
TUPLE: postgresql-statement < statement ;
TUPLE: postgresql-result-set < result-set ;
-M: postgresql-db db-open ( db -- db )
- dup {
+M: postgresql-db db-open ( db -- db-connection )
+ {
[ host>> ]
[ port>> ]
[ pgopts>> ]
@@ -28,10 +36,9 @@ M: postgresql-db db-open ( db -- db )
[ database>> ]
[ username>> ]
[ password>> ]
- } cleave connect-postgres >>handle ;
+ } cleave connect-postgres ;
-M: postgresql-db db-close ( handle -- )
- PQfinish ;
+M: postgresql-db-connection db-close ( handle -- ) PQfinish ;
M: postgresql-statement bind-statement* ( statement -- ) drop ;
@@ -48,8 +55,10 @@ M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- object )
[ swap slot-name>> rot set-slot-named ] [ ] bi ;
M: postgresql-statement bind-tuple ( tuple statement -- )
- tuck in-params>>
- [ postgresql-bind-conversion ] with map
+ [ nip ] [
+ in-params>>
+ [ postgresql-bind-conversion ] with map
+ ] 2bi
>>bind-params drop ;
M: postgresql-result-set #rows ( result-set -- n )
@@ -98,25 +107,25 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
dup
- [ db get handle>> f ] dip
+ [ db-connection get handle>> f ] dip
[ sql>> ] [ in-params>> ] bi
length f PQprepare postgresql-error
>>handle drop ;
-M: postgresql-db ( sql in out -- statement )
+M: postgresql-db-connection ( sql in out -- statement )
postgresql-statement new-statement ;
-M: postgresql-db ( sql in out -- statement )
+M: postgresql-db-connection ( sql in out -- statement )
dup prepare-statement ;
: bind-name% ( -- )
CHAR: $ 0,
sql-counter [ inc ] [ get 0# ] bi ;
-M: postgresql-db bind% ( spec -- )
+M: postgresql-db-connection bind% ( spec -- )
bind-name% 1, ;
-M: postgresql-db bind# ( spec object -- )
+M: postgresql-db-connection bind# ( spec object -- )
[ bind-name% f swap type>> ] dip
1, ;
@@ -162,7 +171,7 @@ M: postgresql-db bind# ( spec object -- )
"_seq'');' language sql;" 0%
] query-make ;
-M: postgresql-db create-sql-statement ( class -- seq )
+M: postgresql-db-connection create-sql-statement ( class -- seq )
[
[ create-table-sql , ] keep
dup db-assigned? [ create-function-sql , ] [ drop ] if
@@ -182,13 +191,13 @@ M: postgresql-db create-sql-statement ( class -- seq )
"drop table " 0% 0% drop
] query-make ;
-M: postgresql-db drop-sql-statement ( class -- seq )
+M: postgresql-db-connection drop-sql-statement ( class -- seq )
[
[ drop-table-sql , ] keep
dup db-assigned? [ drop-function-sql , ] [ drop ] if
] { } make ;
-M: postgresql-db ( class -- statement )
+M: postgresql-db-connection ( class -- statement )
[
"select add_" 0% 0%
"(" 0%
@@ -198,7 +207,7 @@ M: postgresql-db ( class -- statement )
");" 0%
] query-make ;
-M: postgresql-db ( class -- statement )
+M: postgresql-db-connection ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
@@ -221,10 +230,10 @@ M: postgresql-db ( class -- statement )
");" 0%
] query-make ;
-M: postgresql-db insert-tuple-set-key ( tuple statement -- )
+M: postgresql-db-connection insert-tuple-set-key ( tuple statement -- )
query-modify-tuple ;
-M: postgresql-db persistent-table ( -- hashtable )
+M: postgresql-db-connection persistent-table ( -- hashtable )
H{
{ +db-assigned-id+ { "integer" "serial" f } }
{ +user-assigned-id+ { f f f } }
@@ -264,7 +273,7 @@ M: postgresql-db persistent-table ( -- hashtable )
} ;
ERROR: no-compound-found string object ;
-M: postgresql-db compound ( string object -- string' )
+M: postgresql-db-connection compound ( string object -- string' )
over {
{ "default" [ first number>string " " glue ] }
{ "varchar" [ first number>string "(" ")" surround append ] }
diff --git a/basis/db/queries/queries.factor b/basis/db/queries/queries.factor
index a96398ff2c..2d7ea67107 100644
--- a/basis/db/queries/queries.factor
+++ b/basis/db/queries/queries.factor
@@ -3,7 +3,8 @@
USING: accessors kernel math namespaces make sequences random
strings math.parser math.intervals combinators math.bitwise
nmake db db.tuples db.types classes words shuffle arrays
-destructors continuations db.tuples.private prettyprint ;
+destructors continuations db.tuples.private prettyprint
+db.private ;
IN: db.queries
GENERIC: where ( specs obj -- )
@@ -62,7 +63,7 @@ M: retryable execute-statement* ( statement type -- )
dup column-name>> 0% " = " 0% bind%
] interleave ;
-M: db ( class -- statement )
+M: db-connection ( class -- statement )
[
"update " 0% 0%
" set " 0%
@@ -142,7 +143,7 @@ M: string where ( spec obj -- ) object-where ;
: where-clause ( tuple specs -- )
dupd filter-slots [ drop ] [ many-where ] if-empty ;
-M: db ( tuple table -- sql )
+M: db-connection ( tuple table -- sql )
[
"delete from " 0% 0%
where-clause
@@ -150,7 +151,7 @@ M: db ( tuple table -- sql )
ERROR: all-slots-ignored class ;
-M: db ( tuple class -- statement )
+M: db-connection ( tuple class -- statement )
[
"select " 0%
[ dupd filter-ignores ] dip
@@ -185,13 +186,13 @@ M: db ( tuple class -- statement )
[ offset>> [ do-offset ] [ drop ] if* ]
} 2cleave ;
-M: db query>statement ( query -- tuple )
+M: db-connection query>statement ( query -- tuple )
[ tuple>> dup class ] keep
[ ] dip make-query* ;
! select ID, NAME, SCORE from EXAM limit 1 offset 3
-M: db ( query -- statement )
+M: db-connection ( query -- statement )
[ tuple>> dup class ] keep
[ [ "select count(*) from " 0% 0% where-clause ] query-make ]
dip make-query* ;
diff --git a/basis/db/sqlite/lib/lib.factor b/basis/db/sqlite/lib/lib.factor
index 1ec18260cd..b1bc9aa1a2 100644
--- a/basis/db/sqlite/lib/lib.factor
+++ b/basis/db/sqlite/lib/lib.factor
@@ -5,7 +5,8 @@ namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
io.backend db.errors present urls io.encodings.utf8
-io.encodings.string accessors shuffle ;
+io.encodings.string accessors shuffle io prettyprint
+db.private ;
IN: db.sqlite.lib
ERROR: sqlite-error < db-error n string ;
@@ -16,7 +17,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
: sqlite-statement-error ( -- * )
SQLITE_ERROR
- db get handle>> sqlite3_errmsg sqlite-sql-error ;
+ db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
: sqlite-check-result ( n -- )
{
@@ -42,7 +43,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
sqlite3_bind_parameter_index ;
: parameter-index ( handle name text -- handle name text )
- >r dupd sqlite-bind-parameter-index r> ;
+ [ dupd sqlite-bind-parameter-index ] dip ;
: sqlite-bind-text ( handle index text -- )
utf8 encode dup length SQLITE_TRANSIENT
@@ -124,7 +125,8 @@ ERROR: sqlite-sql-error < sql-error n string ;
] if* (sqlite-bind-type) ;
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
-: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
+: sqlite-reset ( handle -- )
+"resetting: " write dup . sqlite3_reset sqlite-check-result ;
: sqlite-clear-bindings ( handle -- )
sqlite3_clear_bindings sqlite-check-result ;
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
@@ -166,7 +168,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
: sqlite-row ( handle -- seq )
dup sqlite-#columns [ sqlite-column ] with map ;
-: sqlite-step-has-more-rows? ( prepared -- bool )
+: sqlite-step-has-more-rows? ( prepared -- ? )
{
{ SQLITE_ROW [ t ] }
{ SQLITE_DONE [ f ] }
diff --git a/basis/db/sqlite/sqlite-tests.factor b/basis/db/sqlite/sqlite-tests.factor
index fe95980bcf..6fb1cd19ad 100644
--- a/basis/db/sqlite/sqlite-tests.factor
+++ b/basis/db/sqlite/sqlite-tests.factor
@@ -1,10 +1,10 @@
-USING: io io.files io.launcher kernel namespaces
-prettyprint tools.test db.sqlite db sequences
+USING: io io.files io.files.temp io.directories io.launcher
+kernel namespaces prettyprint tools.test db.sqlite db sequences
continuations db.types db.tuples unicode.case ;
IN: db.sqlite.tests
-: db-path "test.db" temp-file ;
-: test.db db-path ;
+: db-path ( -- path ) "test.db" temp-file ;
+: test.db ( -- sqlite-db ) db-path ;
[ ] [ [ db-path delete-file ] ignore-errors ] unit-test
diff --git a/basis/db/sqlite/sqlite.factor b/basis/db/sqlite/sqlite.factor
index 32c5ca0075..0f545030a3 100644
--- a/basis/db/sqlite/sqlite.factor
+++ b/basis/db/sqlite/sqlite.factor
@@ -6,33 +6,43 @@ sequences strings classes.tuple alien.c-types continuations
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
math.intervals io nmake accessors vectors math.ranges random
math.bitwise db.queries destructors db.tuples.private interpolate
-io.streams.string multiline make ;
+io.streams.string multiline make db.private ;
IN: db.sqlite
-TUPLE: sqlite-db < db path ;
+TUPLE: sqlite-db path ;
: ( path -- sqlite-db )
- sqlite-db new-db
+ sqlite-db new
swap >>path ;
-M: sqlite-db db-open ( db -- db )
- dup path>> sqlite-open >>handle ;
+ ( handle -- db-connection )
+ sqlite-db-connection new-db-connection
+ swap >>handle ;
+
+PRIVATE>
+
+M: sqlite-db db-open ( db -- db-connection )
+ path>> sqlite-open ;
+
+M: sqlite-db-connection db-close ( handle -- ) sqlite-close ;
TUPLE: sqlite-statement < statement ;
TUPLE: sqlite-result-set < result-set has-more? ;
-M: sqlite-db ( str in out -- obj )
+M: sqlite-db-connection ( str in out -- obj )
;
-M: sqlite-db ( str in out -- obj )
+M: sqlite-db-connection ( str in out -- obj )
sqlite-statement new-statement ;
: sqlite-maybe-prepare ( statement -- statement )
dup handle>> [
- db get handle>> over sql>> sqlite-prepare
+ db-connection get handle>> over sql>> sqlite-prepare
>>handle
] unless ;
@@ -89,10 +99,10 @@ M: sqlite-statement bind-tuple ( tuple statement -- )
ERROR: sqlite-last-id-fail ;
: last-insert-id ( -- id )
- db get handle>> sqlite3_last_insert_rowid
+ db-connection get handle>> sqlite3_last_insert_rowid
dup zero? [ sqlite-last-id-fail ] when ;
-M: sqlite-db insert-tuple-set-key ( tuple statement -- )
+M: sqlite-db-connection insert-tuple-set-key ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
@@ -116,7 +126,7 @@ M: sqlite-statement query-results ( query -- result-set )
dup handle>> sqlite-result-set new-result-set
dup advance-row ;
-M: sqlite-db create-sql-statement ( class -- statement )
+M: sqlite-db-connection create-sql-statement ( class -- statement )
[
dupd
"create table " 0% 0%
@@ -135,10 +145,10 @@ M: sqlite-db create-sql-statement ( class -- statement )
"));" 0%
] query-make ;
-M: sqlite-db drop-sql-statement ( class -- statement )
+M: sqlite-db-connection drop-sql-statement ( class -- statement )
[ "drop table " 0% 0% ";" 0% drop ] query-make ;
-M: sqlite-db ( tuple -- statement )
+M: sqlite-db-connection ( tuple -- statement )
[
"insert into " 0% 0%
"(" 0%
@@ -159,19 +169,19 @@ M: sqlite-db ( tuple -- statement )
");" 0%
] query-make ;
-M: sqlite-db ( tuple -- statement )
+M: sqlite-db-connection ( tuple -- statement )
;
-M: sqlite-db bind# ( spec obj -- )
+M: sqlite-db-connection bind# ( spec obj -- )
[
[ column-name>> ":" next-sql-counter surround dup 0% ]
[ type>> ] bi
] dip 1, ;
-M: sqlite-db bind% ( spec -- )
+M: sqlite-db-connection bind% ( spec -- )
dup 1, column-name>> ":" prepend 0% ;
-M: sqlite-db persistent-table ( -- assoc )
+M: sqlite-db-connection persistent-table ( -- assoc )
H{
{ +db-assigned-id+ { "integer" "integer" f } }
{ +user-assigned-id+ { f f f } }
@@ -306,7 +316,7 @@ M: sqlite-db persistent-table ( -- assoc )
delete-trigger-restrict sqlite-trigger,
] if ;
-M: sqlite-db compound ( string seq -- new-string )
+M: sqlite-db-connection compound ( string seq -- new-string )
over {
{ "default" [ first number>string " " glue ] }
{ "references" [
diff --git a/basis/db/tester/authors.txt b/basis/db/tester/authors.txt
new file mode 100644
index 0000000000..f372b574ae
--- /dev/null
+++ b/basis/db/tester/authors.txt
@@ -0,0 +1,2 @@
+Slava Pestov
+Doug Coleman
diff --git a/basis/db/tester/tester-tests.factor b/basis/db/tester/tester-tests.factor
new file mode 100644
index 0000000000..6b39a7e218
--- /dev/null
+++ b/basis/db/tester/tester-tests.factor
@@ -0,0 +1,7 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test db.tester ;
+IN: db.tester.tests
+
+[ ] [ sqlite-test-db db-tester ] unit-test
+[ ] [ sqlite-test-db db-tester2 ] unit-test
diff --git a/basis/db/tester/tester.factor b/basis/db/tester/tester.factor
new file mode 100644
index 0000000000..490f6bbef5
--- /dev/null
+++ b/basis/db/tester/tester.factor
@@ -0,0 +1,62 @@
+! Copyright (C) 2008 Slava Pestov, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: concurrency.combinators db.pools db.sqlite db.tuples
+db.types kernel math random threads tools.test db sequences
+io prettyprint ;
+IN: db.tester
+
+TUPLE: test-1 id a b c ;
+
+test-1 "TEST1" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "a" "A" { VARCHAR 256 } +not-null+ }
+ { "b" "B" { VARCHAR 256 } +not-null+ }
+ { "c" "C" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+TUPLE: test-2 id x y z ;
+
+test-2 "TEST2" {
+ { "id" "ID" INTEGER +db-assigned-id+ }
+ { "x" "X" { VARCHAR 256 } +not-null+ }
+ { "y" "Y" { VARCHAR 256 } +not-null+ }
+ { "z" "Z" { VARCHAR 256 } +not-null+ }
+} define-persistent
+
+: sqlite-test-db ( -- db ) "test.db" ;
+: test-db ( -- db ) "test.db" ;
+
+: db-tester ( test-db -- )
+ [
+ [
+ test-1 ensure-table
+ test-2 ensure-table
+ ] with-db
+ ] [
+ 10 [
+ drop
+ 10 [
+ dup [
+ f 100 random 100 random 100 random test-1 boa
+ insert-tuple yield
+ ] with-db
+ ] times
+ ] with parallel-each
+ ] bi ;
+
+: db-tester2 ( test-db -- )
+ [
+ [
+ test-1 ensure-table
+ test-2 ensure-table
+ ] with-db
+ ] [
+ [
+ 10 [
+ 10 [
+ f 100 random 100 random 100 random test-1 boa
+ insert-tuple yield
+ ] times
+ ] parallel-each
+ ] with-pooled-db
+ ] bi ;
diff --git a/basis/db/tuples/tuples-docs.factor b/basis/db/tuples/tuples-docs.factor
index 51830ee610..e853c55ede 100644
--- a/basis/db/tuples/tuples-docs.factor
+++ b/basis/db/tuples/tuples-docs.factor
@@ -199,7 +199,7 @@ ARTICLE: "db-tuples-protocol" "Tuple database protocol"
{ $subsection } ;
ARTICLE: "db-tuples-tutorial" "Tuple database tutorial"
-"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
+"Let's make a tuple and store it in a database. To follow along, click on each code example and run it in the listener. If you forget to run an example, just start at the top and run them all again in order." $nl
"We're going to store books in this tutorial."
{ $code "TUPLE: book id title author date-published edition cover-price condition ;" }
"The title, author, and publisher should be strings; the date-published a timestamp; the edition an integer; the cover-price a float. These are the Factor types for which we will need to look up the corresponding " { $link "db.types" } ". " $nl
@@ -246,7 +246,7 @@ T{ book
{ $code <" [
book get update-tuple
] with-book-tutorial "> }
-"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
+"And select it again. You can query the database by any field -- just set it in the exemplar tuple you pass to " { $link select-tuples } "."
{ $code <" [
T{ book { title "Factor for Sheeple" } } select-tuples
] with-book-tutorial "> }
diff --git a/basis/db/tuples/tuples-tests.factor b/basis/db/tuples/tuples-tests.factor
index 0432f38683..246946c715 100644
--- a/basis/db/tuples/tuples-tests.factor
+++ b/basis/db/tuples/tuples-tests.factor
@@ -1,10 +1,10 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: io.files kernel tools.test db db.tuples classes
+USING: io.files io.files.temp kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitwise system
-math.ranges strings urls fry db.tuples.private ;
+math.ranges strings urls fry db.tuples.private db.private ;
IN: db.tuples.tests
: sqlite-db ( -- sqlite-db )
@@ -33,10 +33,10 @@ IN: db.tuples.tests
! These words leak resources, but are useful for interactivel testing
: sqlite-test-db ( -- )
- sqlite-db db-open db set ;
+ sqlite-db db-open db-connection set ;
: postgresql-test-db ( -- )
- postgresql-db db-open db set ;
+ postgresql-db db-open db-connection set ;
TUPLE: person the-id the-name the-number the-real
ts date time blob factor-blob url ;
diff --git a/basis/db/tuples/tuples.factor b/basis/db/tuples/tuples.factor
index 7a5c9e41e6..219116aefd 100644
--- a/basis/db/tuples/tuples.factor
+++ b/basis/db/tuples/tuples.factor
@@ -3,20 +3,20 @@
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
-destructors mirrors sets db.types ;
+destructors mirrors sets db.types db.private ;
IN: db.tuples
-HOOK: create-sql-statement db ( class -- object )
-HOOK: drop-sql-statement db ( class -- object )
+HOOK: create-sql-statement db-connection ( class -- object )
+HOOK: drop-sql-statement db-connection ( class -- object )
-HOOK: db ( class -- object )
-HOOK: db ( class -- object )
-HOOK: db ( class -- object )
-HOOK: db ( tuple class -- object )
-HOOK: db ( tuple class -- tuple )
-HOOK: db ( query -- statement )
-HOOK: query>statement db ( query -- statement )
-HOOK: insert-tuple-set-key db ( tuple statement -- )
+HOOK: db-connection ( class -- object )
+HOOK: db-connection ( class -- object )
+HOOK: db-connection ( class -- object )
+HOOK: db-connection ( tuple class -- object )
+HOOK: db-connection ( tuple class -- tuple )
+HOOK: db-connection ( query -- statement )
+HOOK: query>statement db-connection ( query -- statement )
+HOOK: insert-tuple-set-key db-connection ( tuple statement -- )
> [ ] cache
+ db-connection get insert-statements>>
+ [ ] cache
[ bind-tuple ] 2keep insert-tuple-set-key ;
: insert-user-assigned-statement ( tuple -- )
dup class
- db get insert-statements>> [ ] cache
+ db-connection get insert-statements>>
+ [ ] cache
[ bind-tuple ] keep execute-statement ;
: do-select ( exemplar-tuple statement -- tuples )
@@ -71,9 +73,10 @@ PRIVATE>
! High level
ERROR: no-slots-named class seq ;
: check-columns ( class columns -- )
- tuck
- [ [ first ] map ]
- [ all-slots [ name>> ] map ] bi* diff
+ [ nip ] [
+ [ [ first ] map ]
+ [ all-slots [ name>> ] map ] bi* diff
+ ] 2bi
[ drop ] [ no-slots-named ] if-empty ;
: define-persistent ( class table columns -- )
@@ -117,7 +120,7 @@ M: tuple >query swap >>tuple ;
: update-tuple ( tuple -- )
dup class
- db get update-statements>> [ ] cache
+ db-connection get update-statements>> [ ] cache
[ bind-tuple ] keep execute-statement ;
: delete-tuples ( tuple -- )
diff --git a/basis/db/types/types-docs.factor b/basis/db/types/types-docs.factor
index bd0b443fbe..d5908740c6 100644
--- a/basis/db/types/types-docs.factor
+++ b/basis/db/types/types-docs.factor
@@ -41,12 +41,15 @@ HELP: +user-assigned-id+
{ $description "The user is responsible for choosing a primary key for tuples inserted with this database type. Keys must be unique or else the database will throw an error. Usually it is better to use a " { $link +db-assigned-id+ } "." } ;
HELP:
+{ $values { "slot-name" object } { "key" object } { "generator-singleton" object } { "type" object } { "generator-bind" generator-bind } }
{ $description "" } ;
HELP:
+{ $values { "key" object } { "type" object } { "value" object } { "literal-bind" literal-bind } }
{ $description "" } ;
HELP:
+{ $values { "value" object } { "low-level-binding" low-level-binding } }
{ $description "" } ;
HELP: BIG-INTEGER
diff --git a/basis/db/types/types.factor b/basis/db/types/types.factor
index da9fe39b80..2d4a6ff5fb 100644
--- a/basis/db/types/types.factor
+++ b/basis/db/types/types.factor
@@ -3,12 +3,12 @@
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep prettyprint
words namespaces slots slots.private classes mirrors
-classes.tuple combinators calendar.format symbols
-classes.singleton accessors quotations random ;
+classes.tuple combinators calendar.format classes.singleton
+accessors quotations random db.private ;
IN: db.types
-HOOK: persistent-table db ( -- hash )
-HOOK: compound db ( string obj -- hash )
+HOOK: persistent-table db-connection ( -- hash )
+HOOK: compound db-connection ( string obj -- hash )
TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
@@ -42,10 +42,10 @@ ERROR: no-slot ;
slot-named dup [ no-slot ] unless offset>> ;
: get-slot-named ( name tuple -- value )
- tuck offset-of-slot slot ;
+ [ nip ] [ offset-of-slot ] 2bi slot ;
: set-slot-named ( value name obj -- )
- tuck offset-of-slot set-slot ;
+ [ nip ] [ offset-of-slot ] 2bi set-slot ;
ERROR: not-persistent class ;
@@ -158,8 +158,8 @@ ERROR: no-sql-type type ;
modifiers>> [ lookup-modifier ] map " " join
[ "" ] [ " " prepend ] if-empty ;
-HOOK: bind% db ( spec -- )
-HOOK: bind# db ( spec obj -- )
+HOOK: bind% db-connection ( spec -- )
+HOOK: bind# db-connection ( spec obj -- )
ERROR: no-column column ;
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 4e0c4e8840..1440e7ca5d 100644
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -2,14 +2,14 @@
! See http://factorcode.org/license.txt for BSD license.
USING: slots arrays definitions generic hashtables summary io
kernel math namespaces make prettyprint prettyprint.config
-sequences assocs sequences.private strings io.styles io.files
-vectors words system splitting math.parser classes.mixin
-classes.tuple continuations continuations.private combinators
-generic.math classes.builtin classes compiler.units
+sequences assocs sequences.private strings io.styles
+io.pathnames vectors words system splitting math.parser
+classes.mixin classes.tuple continuations continuations.private
+combinators generic.math classes.builtin classes compiler.units
generic.standard vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer compiler.errors
-generic.parser strings.parser ;
+generic.parser strings.parser vocabs.parser ;
IN: debugger
GENERIC: error. ( error -- )
diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor
index d1e7d31656..7d297af1ed 100644
--- a/basis/delegate/delegate-tests.factor
+++ b/basis/delegate/delegate-tests.factor
@@ -20,7 +20,7 @@ PROTOCOL: baz foo { bar 0 } { whoa 1 } ;
CONSULT: baz goodbye these>> ;
M: hello foo this>> ;
M: hello bar hello-test ;
-M: hello whoa >r this>> r> + ;
+M: hello whoa [ this>> ] dip + ;
GENERIC: bing ( c -- d )
PROTOCOL: bee bing ;
diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor
index 57f9b35c96..4da2244114 100644
--- a/basis/delegate/delegate.factor
+++ b/basis/delegate/delegate.factor
@@ -2,7 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors parser generic kernel classes classes.tuple
words slots assocs sequences arrays vectors definitions
-math hashtables sets generalizations namespaces make ;
+math hashtables sets generalizations namespaces make
+words.symbol ;
IN: delegate
: protocol-words ( protocol -- words )
diff --git a/basis/delegate/protocols/protocols.factor b/basis/delegate/protocols/protocols.factor
index c21f33ec8e..edbec804c1 100644
--- a/basis/delegate/protocols/protocols.factor
+++ b/basis/delegate/protocols/protocols.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs
-io definitions kernel continuations ;
+io io.styles definitions kernel continuations ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
diff --git a/basis/deques/deques.factor b/basis/deques/deques.factor
index f4e68c214b..73769cc4d2 100644
--- a/basis/deques/deques.factor
+++ b/basis/deques/deques.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel sequences math ;
+USING: kernel sequences math fry ;
IN: deques
GENERIC: push-front* ( obj deque -- node )
@@ -34,7 +34,8 @@ GENERIC: deque-empty? ( deque -- ? )
[ peek-back ] [ pop-back* ] bi ;
: slurp-deque ( deque quot -- )
- [ drop [ deque-empty? not ] curry ]
- [ [ pop-back ] prepose curry ] 2bi [ ] while ; inline
+ [ drop '[ _ deque-empty? not ] ]
+ [ '[ _ pop-back @ ] ]
+ 2bi [ ] while ; inline
MIXIN: deque
diff --git a/basis/disjoint-sets/disjoint-sets.factor b/basis/disjoint-sets/disjoint-sets.factor
index ea246cfa28..a3e5c7ceb7 100644
--- a/basis/disjoint-sets/disjoint-sets.factor
+++ b/basis/disjoint-sets/disjoint-sets.factor
@@ -60,8 +60,8 @@ GENERIC: add-atom ( a disjoint-set -- )
M: disjoint-set add-atom
[ dupd parents>> set-at ]
- [ 0 -rot ranks>> set-at ]
- [ 1 -rot counts>> set-at ]
+ [ [ 0 ] 2dip ranks>> set-at ]
+ [ [ 1 ] 2dip counts>> set-at ]
2tri ;
: add-atoms ( seq disjoint-set -- ) '[ _ add-atom ] each ;
diff --git a/basis/dlists/dlists.factor b/basis/dlists/dlists.factor
index dcff476166..8c575105d1 100644
--- a/basis/dlists/dlists.factor
+++ b/basis/dlists/dlists.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2007, 2008 Mackenzie Straight, Doug Coleman,
+! Copyright (C) 2007, 2009 Mackenzie Straight, Doug Coleman,
! Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators kernel math sequences accessors deques
-search-deques summary hashtables ;
+search-deques summary hashtables fry ;
IN: dlists
> ;
[ front>> ] dip (dlist-find-node) ; inline
: dlist-each-node ( dlist quot -- )
- [ f ] compose dlist-find-node 2drop ; inline
+ '[ @ f ] dlist-find-node 2drop ; inline
: unlink-node ( dlist-node -- )
dup prev>> over next>> set-prev-when
@@ -115,8 +115,7 @@ M: dlist pop-back* ( dlist -- )
normalize-front ;
: dlist-find ( dlist quot -- obj/f ? )
- [ obj>> ] prepose
- dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
+ '[ obj>> @ ] dlist-find-node [ obj>> t ] [ drop f f ] if ; inline
: dlist-contains? ( dlist quot -- ? )
dlist-find nip ; inline
@@ -143,7 +142,7 @@ M: dlist delete-node ( dlist-node dlist -- )
] if ; inline
: delete-node-if ( dlist quot -- obj/f )
- [ obj>> ] prepose delete-node-if* drop ; inline
+ '[ obj>> @ ] delete-node-if* drop ; inline
M: dlist clear-deque ( dlist -- )
f >>front
@@ -151,7 +150,7 @@ M: dlist clear-deque ( dlist -- )
drop ;
: dlist-each ( dlist quot -- )
- [ obj>> ] prepose dlist-each-node ; inline
+ '[ obj>> @ ] dlist-each-node ; inline
: dlist>seq ( dlist -- seq )
[ ] accumulator [ dlist-each ] dip ;
@@ -159,8 +158,6 @@ M: dlist clear-deque ( dlist -- )
: 1dlist ( obj -- dlist ) [ push-front ] keep ;
M: dlist clone
- [
- [ push-back ] curry dlist-each
- ] keep ;
+ [ '[ _ push-back ] dlist-each ] keep ;
INSTANCE: dlist deque
diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor
index 6993bcb65b..29f865cf3c 100644
--- a/basis/documents/documents.factor
+++ b/basis/documents/documents.factor
@@ -153,18 +153,18 @@ GENERIC: next-elt ( loc document elt -- newloc )
TUPLE: char-elt ;
: (prev-char) ( loc document quot -- loc )
- -rot {
- { [ over { 0 0 } = ] [ drop ] }
- { [ over second zero? ] [ [ first 1- ] dip line-end ] }
- [ pick call ]
- } cond nip ; inline
+ {
+ { [ pick { 0 0 } = ] [ 2drop ] }
+ { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
+ [ call ]
+ } cond ; inline
: (next-char) ( loc document quot -- loc )
- -rot {
- { [ 2dup doc-end = ] [ drop ] }
- { [ 2dup line-end? ] [ drop first 1+ 0 2array ] }
- [ pick call ]
- } cond nip ; inline
+ {
+ { [ 2over doc-end = ] [ 2drop ] }
+ { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
+ [ call ]
+ } cond ; inline
M: char-elt prev-elt
drop [ drop -1 +col ] (prev-char) ;
diff --git a/basis/editors/editors.factor b/basis/editors/editors.factor
index 6b49c939c3..53887bd353 100644
--- a/basis/editors/editors.factor
+++ b/basis/editors/editors.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser lexer kernel namespaces sequences definitions
-io.files summary continuations tools.crossref tools.vocabs io
-prettyprint source-files assocs vocabs vocabs.loader io.backend
-splitting accessors ;
+io.files io.backend io.pathnames io summary continuations
+tools.crossref tools.vocabs prettyprint source-files assocs
+vocabs vocabs.loader splitting accessors ;
IN: editors
TUPLE: no-edit-hook ;
diff --git a/basis/editors/editpadlite/editpadlite.factor b/basis/editors/editpadlite/editpadlite.factor
index c002c2fa75..d487ca776f 100644
--- a/basis/editors/editpadlite/editpadlite.factor
+++ b/basis/editors/editpadlite/editpadlite.factor
@@ -1,11 +1,12 @@
USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher windows.shell32 io.files
-io.paths.windows strings unicode.case make ;
+io.directories.search.windows strings unicode.case make ;
IN: editors.editpadlite
: editpadlite-path ( -- path )
\ editpadlite-path get-global [
"JGsoft" t [ >lower "editpadlite.exe" tail? ] find-in-program-files
+ [ "editpadlite.exe" ] unless*
] unless* ;
: editpadlite ( file line -- )
diff --git a/basis/editors/editpadpro/editpadpro.factor b/basis/editors/editpadpro/editpadpro.factor
index 2a7f92f932..09bfd69de8 100644
--- a/basis/editors/editpadpro/editpadpro.factor
+++ b/basis/editors/editpadpro/editpadpro.factor
@@ -1,11 +1,12 @@
USING: definitions kernel parser words sequences math.parser
namespaces editors io.launcher windows.shell32 io.files
-io.paths.windows strings unicode.case make ;
+io.directories.search.windows strings unicode.case make ;
IN: editors.editpadpro
: editpadpro-path ( -- path )
\ editpadpro-path get-global [
"JGsoft" t [ >lower "editpadpro.exe" tail? ] find-in-program-files
+ [ "editpadpro.exe" ] unless*
] unless* ;
: editpadpro ( file line -- )
diff --git a/basis/editors/editplus/editplus.factor b/basis/editors/editplus/editplus.factor
index 9fa477f51a..affbcd4eb6 100644
--- a/basis/editors/editplus/editplus.factor
+++ b/basis/editors/editplus/editplus.factor
@@ -1,10 +1,12 @@
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make io.paths.windows ;
+namespaces sequences windows.shell32 make
+io.directories.search.windows ;
IN: editors.editplus
: editplus-path ( -- path )
\ editplus-path get-global [
"EditPlus 2" t [ "editplus.exe" tail? ] find-in-program-files
+ [ "editplus.exe" ] unless*
] unless* ;
: editplus ( file line -- )
diff --git a/basis/editors/emeditor/emeditor.factor b/basis/editors/emeditor/emeditor.factor
index fc3deae670..52c52bbb8b 100644
--- a/basis/editors/emeditor/emeditor.factor
+++ b/basis/editors/emeditor/emeditor.factor
@@ -1,10 +1,12 @@
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make io.paths.windows ;
+namespaces sequences windows.shell32 make
+io.directories.search.windows ;
IN: editors.emeditor
: emeditor-path ( -- path )
\ emeditor-path get-global [
"EmEditor" t [ "EmEditor.exe" tail? ] find-in-program-files
+ [ "EmEditor.exe" ] unless*
] unless* ;
: emeditor ( file line -- )
diff --git a/basis/editors/etexteditor/etexteditor.factor b/basis/editors/etexteditor/etexteditor.factor
index c4b3ad35c1..37c8d1b572 100755
--- a/basis/editors/etexteditor/etexteditor.factor
+++ b/basis/editors/etexteditor/etexteditor.factor
@@ -1,12 +1,13 @@
! Copyright (C) 2008 Kibleur Christophe.
! See http://factorcode.org/license.txt for BSD license.
-USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 io.paths.windows make ;
+USING: editors io.files io.launcher kernel math.parser make
+namespaces sequences windows.shell32 io.directories.search.windows ;
IN: editors.etexteditor
: etexteditor-path ( -- str )
\ etexteditor-path get-global [
"e" t [ "e.exe" tail? ] find-in-program-files
+ [ "e" ] unless*
] unless* ;
: etexteditor ( file line -- )
diff --git a/basis/editors/gvim/gvim.factor b/basis/editors/gvim/gvim.factor
index ad6fb65cfb..15fd52f5ee 100644
--- a/basis/editors/gvim/gvim.factor
+++ b/basis/editors/gvim/gvim.factor
@@ -3,12 +3,15 @@ namespaces sequences system combinators
editors.vim vocabs.loader make ;
IN: editors.gvim
+! This code builds on the code in editors.vim; see there for
+! more information.
+
SINGLETON: gvim
HOOK: gvim-path io-backend ( -- path )
M: gvim vim-command ( file line -- string )
- [ gvim-path , swap , "+" swap number>string append , ] { } make ;
+ [ gvim-path , "+" swap number>string append , , ] { } make ;
gvim vim-editor set-global
diff --git a/basis/editors/gvim/unix/unix.factor b/basis/editors/gvim/unix/unix.factor
index 82b6bf199d..3e2a42e6e5 100644
--- a/basis/editors/gvim/unix/unix.factor
+++ b/basis/editors/gvim/unix/unix.factor
@@ -1,5 +1,4 @@
-USING: io.unix.backend kernel namespaces editors.gvim
-system ;
+USING: kernel namespaces editors.gvim system ;
IN: editors.gvim.unix
M: unix gvim-path
diff --git a/basis/editors/gvim/windows/windows.factor b/basis/editors/gvim/windows/windows.factor
index 2f733f3c2f..4edc13b90c 100644
--- a/basis/editors/gvim/windows/windows.factor
+++ b/basis/editors/gvim/windows/windows.factor
@@ -1,8 +1,10 @@
-USING: editors.gvim io.files io.windows kernel namespaces
-sequences windows.shell32 io.paths.windows system ;
+USING: editors.gvim io.files kernel namespaces sequences
+windows.shell32 io.directories.search.windows system
+io.pathnames ;
IN: editors.gvim.windows
M: windows gvim-path
\ gvim-path get-global [
"vim" t [ "gvim.exe" tail? ] find-in-program-files
+ [ "gvim.exe" ] unless*
] unless* ;
diff --git a/basis/editors/jedit/jedit.factor b/basis/editors/jedit/jedit.factor
index fe9abc0e76..e34f0ce175 100644
--- a/basis/editors/jedit/jedit.factor
+++ b/basis/editors/jedit/jedit.factor
@@ -4,7 +4,7 @@ USING: arrays definitions io kernel math
namespaces parser prettyprint sequences strings words
editors io.files io.sockets io.streams.byte-array io.binary
math.parser io.encodings.ascii io.encodings.binary
-io.encodings.utf8 io.files.private ;
+io.encodings.utf8 io.files.private io.pathnames ;
IN: editors.jedit
: jedit-server-info ( -- port auth )
diff --git a/basis/editors/notepad/authors.txt b/basis/editors/notepad/authors.txt
new file mode 100755
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/editors/notepad/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/editors/notepad/notepad.factor b/basis/editors/notepad/notepad.factor
new file mode 100755
index 0000000000..6094bf46b8
--- /dev/null
+++ b/basis/editors/notepad/notepad.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: editors io.launcher kernel io.directories.search.windows
+math.parser namespaces sequences io.files arrays windows.shell32
+io.directories.search ;
+IN: editors.notepad
+
+: notepad-path ( -- path )
+ \ notepad-path get [
+ windows-directory t
+ [ "notepad.exe" tail? ] find-file
+ ] unless* ;
+
+: notepad ( file line -- )
+ drop notepad-path swap 2array run-detached drop ;
+
+[ notepad ] edit-hook set-global
+
diff --git a/basis/editors/notepad2/notepad2.factor b/basis/editors/notepad2/notepad2.factor
index e22de4f68d..dc1a8a7991 100644
--- a/basis/editors/notepad2/notepad2.factor
+++ b/basis/editors/notepad2/notepad2.factor
@@ -1,10 +1,11 @@
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences windows.shell32 make ;
+namespaces sequences windows.shell32 make io.pathnames ;
IN: editors.notepad2
: notepad2-path ( -- path )
\ notepad2-path get-global [
- "C:\\Windows\\system32\\notepad.exe"
+ windows-directory "system32\\notepad.exe" append-path
+ [ "notepad.exe" ] unless*
] unless* ;
: notepad2 ( file line -- )
diff --git a/basis/editors/notepadpp/notepadpp.factor b/basis/editors/notepadpp/notepadpp.factor
index d68008c2ca..1c856bd761 100644
--- a/basis/editors/notepadpp/notepadpp.factor
+++ b/basis/editors/notepadpp/notepadpp.factor
@@ -1,10 +1,11 @@
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences io.paths.windows make ;
+namespaces sequences io.directories.search.windows make ;
IN: editors.notepadpp
: notepadpp-path ( -- path )
\ notepadpp-path get-global [
"notepad++" t [ "notepad++.exe" tail? ] find-in-program-files
+ [ "notepad++.exe" ] unless*
] unless* ;
: notepadpp ( file line -- )
diff --git a/basis/editors/scite/scite.factor b/basis/editors/scite/scite.factor
index e0b48a3e72..fc7e9e319e 100644
--- a/basis/editors/scite/scite.factor
+++ b/basis/editors/scite/scite.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2007 Clemens F. Hofreither.
! See http://factorcode.org/license.txt for BSD license.
! clemens.hofreither@gmx.net
-USING: io.files io.launcher kernel namespaces io.paths.windows
+USING: io.files io.launcher kernel namespaces io.directories.search.windows
math math.parser editors sequences make unicode.case ;
IN: editors.scite
@@ -9,6 +9,12 @@ IN: editors.scite
\ scite-path get-global [
"Scintilla Text Editor" t
[ >lower "scite.exe" tail? ] find-in-program-files
+
+ [
+ "SciTE Source Code Editor" t
+ [ >lower "scite.exe" tail? ] find-in-program-files
+ ] unless*
+ [ "scite.exe" ] unless*
] unless* ;
: scite-command ( file line -- cmd )
diff --git a/basis/editors/ted-notepad/ted-notepad.factor b/basis/editors/ted-notepad/ted-notepad.factor
index 994dc60ba3..301e82225c 100644
--- a/basis/editors/ted-notepad/ted-notepad.factor
+++ b/basis/editors/ted-notepad/ted-notepad.factor
@@ -1,10 +1,11 @@
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences io.paths.windows make ;
+namespaces sequences io.directories.search.windows make ;
IN: editors.ted-notepad
: ted-notepad-path ( -- path )
\ ted-notepad-path get-global [
"TED Notepad" t [ "TedNPad.exe" tail? ] find-in-program-files
+ [ "TedNPad.exe" ] unless*
] unless* ;
: ted-notepad ( file line -- )
diff --git a/basis/editors/textpad/authors.txt b/basis/editors/textpad/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/editors/textpad/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/editors/textpad/summary.txt b/basis/editors/textpad/summary.txt
new file mode 100644
index 0000000000..c8820501ae
--- /dev/null
+++ b/basis/editors/textpad/summary.txt
@@ -0,0 +1 @@
+TextPad editor integration
diff --git a/basis/editors/textpad/tags.txt b/basis/editors/textpad/tags.txt
new file mode 100644
index 0000000000..6bf68304bb
--- /dev/null
+++ b/basis/editors/textpad/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/editors/textpad/textpad.factor b/basis/editors/textpad/textpad.factor
new file mode 100644
index 0000000000..ca9d5c486a
--- /dev/null
+++ b/basis/editors/textpad/textpad.factor
@@ -0,0 +1,17 @@
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences make io.directories.search
+io.directories.search.windows ;
+IN: editors.textpad
+
+: textpad-path ( -- path )
+ \ textpad-path get-global [
+ "TextPad 5" t [ "TextPad.exe" tail? ] find-in-program-files
+ [ "TextPad.exe" ] unless*
+ ] unless* ;
+
+: textpad ( file line -- )
+ [
+ textpad-path , [ , ] [ number>string "(" ",0)" surround , ] bi*
+ ] { } make run-detached drop ;
+
+[ textpad ] edit-hook set-global
diff --git a/basis/editors/ultraedit/ultraedit.factor b/basis/editors/ultraedit/ultraedit.factor
index f1929ebf64..b5bc229743 100644
--- a/basis/editors/ultraedit/ultraedit.factor
+++ b/basis/editors/ultraedit/ultraedit.factor
@@ -1,10 +1,11 @@
USING: editors io.files io.launcher kernel math.parser
-namespaces sequences io.paths.windows make ;
+namespaces sequences io.directories.search.windows make ;
IN: editors.ultraedit
: ultraedit-path ( -- path )
\ ultraedit-path get-global [
"IDM Computer Solutions" t [ "uedit32.exe" tail? ] find-in-program-files
+ [ "uedit32.exe" ] unless*
] unless* ;
: ultraedit ( file line -- )
diff --git a/basis/editors/vim/generate-syntax/generate-syntax.factor b/basis/editors/vim/generate-syntax/generate-syntax.factor
index 325a451a0b..061e938dcf 100644
--- a/basis/editors/vim/generate-syntax/generate-syntax.factor
+++ b/basis/editors/vim/generate-syntax/generate-syntax.factor
@@ -1,11 +1,10 @@
! Generate a new factor.vim file for syntax highlighting
-USING: http.server.templating http.server.templating.fhtml
-io.files ;
+USING: html.templates html.templates.fhtml io.files io.pathnames ;
IN: editors.vim.generate-syntax
: generate-vim-syntax ( -- )
"misc/factor.vim.fgen" resource-path
- "misc/factor.vim" resource-path
+ "misc/vim/syntax/factor.vim" resource-path
template-convert ;
MAIN: generate-vim-syntax
diff --git a/basis/editors/vim/vim-docs.factor b/basis/editors/vim/vim-docs.factor
index cf42884084..7f527bf18f 100644
--- a/basis/editors/vim/vim-docs.factor
+++ b/basis/editors/vim/vim-docs.factor
@@ -1,4 +1,5 @@
-USING: definitions help help.markup help.syntax io io.files editors words ;
+USING: definitions editors help help.markup help.syntax io io.files
+ io.pathnames words ;
IN: editors.vim
ARTICLE: { "vim" "vim" } "Vim support"
@@ -11,5 +12,6 @@ $nl
"USE: vim"
"\"c:\\\\program files\\\\vim\\\\vim70\\\\gvim\" vim-path set-global"
}
-"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "." ;
-
+"On Unix, you may omit the last line if " { $snippet "\"vim\"" } " is in your " { $snippet "$PATH" } "."
+$nl
+"You may also wish to install Vim support files to enable syntax hilighting and other features. These are in the " { $link resource-path } " in " { $snippet "misc/vim" } "." ;
diff --git a/basis/editors/wordpad/wordpad.factor b/basis/editors/wordpad/wordpad.factor
index fa0f6852dd..ef670d5d28 100644
--- a/basis/editors/wordpad/wordpad.factor
+++ b/basis/editors/wordpad/wordpad.factor
@@ -1,4 +1,4 @@
-USING: editors io.launcher kernel io.paths.windows
+USING: editors io.launcher kernel io.directories.search.windows
math.parser namespaces sequences io.files arrays ;
IN: editors.wordpad
diff --git a/basis/eval/eval-docs.factor b/basis/eval/eval-docs.factor
index 057d291b7f..b53c3bae6b 100644
--- a/basis/eval/eval-docs.factor
+++ b/basis/eval/eval-docs.factor
@@ -11,7 +11,7 @@ HELP: eval>string
{ $description "Evaluates the Factor code in " { $snippet "str" } " with " { $link output-stream } " rebound to a string output stream, then outputs the resulting string." } ;
ARTICLE: "eval" "Evaluating strings at runtime"
-"Evaluating strings at runtime:"
+"The " { $vocab-link "eval" } " vocabulary implements support for evaluating strings at runtime."
{ $subsection eval }
{ $subsection eval>string } ;
diff --git a/basis/eval/eval-tests.factor b/basis/eval/eval-tests.factor
new file mode 100644
index 0000000000..675921944a
--- /dev/null
+++ b/basis/eval/eval-tests.factor
@@ -0,0 +1,4 @@
+IN: eval.tests
+USING: eval tools.test ;
+
+[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test
diff --git a/basis/eval/eval.factor b/basis/eval/eval.factor
index 5b22fec159..dfa9baf418 100644
--- a/basis/eval/eval.factor
+++ b/basis/eval/eval.factor
@@ -1,14 +1,24 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: splitting parser compiler.units kernel namespaces
-debugger io.streams.string ;
+debugger io.streams.string fry ;
IN: eval
+: parse-string ( str -- )
+ [ string-lines parse-lines ] with-compilation-unit ;
+
+: (eval) ( str -- )
+ parse-string call ;
+
: eval ( str -- )
- [ string-lines parse-fresh ] with-compilation-unit call ;
+ [ (eval) ] with-file-vocabs ;
-: eval>string ( str -- output )
+: (eval>string) ( str -- output )
[
+ "quiet" on
parser-notes off
- [ [ eval ] keep ] try drop
+ '[ _ (eval) ] try
] with-string-writer ;
+
+: eval>string ( str -- output )
+ [ (eval>string) ] with-file-vocabs ;
\ No newline at end of file
diff --git a/basis/farkup/farkup-docs.factor b/basis/farkup/farkup-docs.factor
index 8e7270cc01..8c6b07a01c 100644
--- a/basis/farkup/farkup-docs.factor
+++ b/basis/farkup/farkup-docs.factor
@@ -14,8 +14,8 @@ HELP: parse-farkup ( string -- farkup )
{ $description "Parses Farkup and outputs a tree of " { $link "farkup-ast" } "." } ;
HELP: (write-farkup)
-{ $values { "farkup" "a Farkup syntax tree node" } }
-{ $description "Writes a Farkup syntax tree as HTML on " { $link output-stream } "." } ;
+{ $values { "farkup" "a Farkup syntax tree node" } { "xml" "an XML chunk" } }
+{ $description "Converts a Farkup syntax tree node to XML." } ;
ARTICLE: "farkup-ast" "Farkup syntax tree nodes"
"The " { $link parse-farkup } " word outputs a tree of nodes corresponding to the Farkup syntax of the input string. This tree can be programatically traversed and mutated before being passed on to " { $link write-farkup } "."
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index 27911a8d13..49c4dab0db 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -1,6 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: farkup kernel peg peg.ebnf tools.test namespaces ;
+USING: farkup kernel peg peg.ebnf tools.test namespaces xml
+urls.encoding assocs xml.utilities xml.data ;
IN: farkup.tests
relative-link-prefix off
@@ -91,22 +92,22 @@ link-no-follow? off
[ "=
foo
" ] [ "===foo==" convert-farkup ] unit-test
[ "foo
=
" ] [ "=foo==" convert-farkup ] unit-test
-[ "int main()\n
" ]
+[ "int main()
" ]
[ "[c{int main()}]" convert-farkup ] unit-test
-[ "" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
-[ "" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
-[ "http://lol.com
" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
-[ "haha
" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
-[ "Bar
" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
+[ "" ] [ "[[image:lol.jpg]]" convert-farkup ] unit-test
+[ "" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
+[ "http://lol.com
" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
+[ "haha
" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
+[ "Bar
" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
"/wiki/view/" relative-link-prefix [
- [ "Bar
" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
+ [ "Bar
" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
] with-variable
[ ] [ "[{}]" convert-farkup drop ] unit-test
-[ "hello\n
" ] [ "[{hello}]" convert-farkup ] unit-test
+[ "hello
" ] [ "[{hello}]" convert-farkup ] unit-test
[
"Feature comparison:\n
a | Factor | Java | Lisp |
Coolness | Yes | No | No |
Badass | Yes | No | No |
Enterprise | Yes | Yes | No |
Kosher | Yes | No | Yes |
"
@@ -117,15 +118,15 @@ link-no-follow? off
] [ "Feature comparison:\n\n|a|Factor|Java|Lisp|\n|Coolness|Yes|No|No|\n|Badass|Yes|No|No|\n|Enterprise|Yes|Yes|No|\n|Kosher|Yes|No|Yes|\n" convert-farkup ] unit-test
[
- "This wiki is written in Factor and is hosted on a http://linode.com virtual server.
"
+ "This wiki is written in Factor and is hosted on a http://linode.com virtual server.
"
] [
"This wiki is written in [[Factor]] and is hosted on a [[http://linode.com|http://linode.com]] virtual server."
convert-farkup
] unit-test
-[ "a c
" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
+[ "a c
" ] [ "[[a]] [[b|c]]" convert-farkup ] unit-test
-[ "C++
" ] [ "[[C++]]" convert-farkup ] unit-test
+[ "C++
" ] [ "[[C++]]" convert-farkup ] unit-test
[ "<foo>
" ] [ "" convert-farkup ] unit-test
@@ -137,10 +138,10 @@ link-no-follow? off
[ "
" ] [ "___" convert-farkup ] unit-test
[ "
\n" ] [ "___\n" convert-farkup ] unit-test
-[ "before:\n
{ 1 2 3 } 1 tail\n
" ]
+[ "before:\n
{ 1 2 3 } 1 tail
" ]
[ "before:\n[factor{{ 1 2 3 } 1 tail}]" convert-farkup ] unit-test
-[ "Factor-rific!
" ]
+[ "Factor-rific!
" ]
[ "[[Factor]]-rific!" convert-farkup ] unit-test
[ "[ factor { 1 2 3 }]
" ]
@@ -157,3 +158,12 @@ link-no-follow? off
[ "hello_world how are you today?\n
- hello_world how are you today?
" ]
[ "hello_world how are you today?\n- hello_world how are you today?" convert-farkup ] unit-test
+
+: check-link-escaping ( string -- link )
+ convert-farkup string>xml-chunk
+ "a" deep-tag-named "href" attr url-decode ;
+
+[ "Trader Joe\"s" ] [ "[[Trader Joe\"s]]" check-link-escaping ] unit-test
+[ "" ] [ "[[]]" check-link-escaping ] unit-test
+[ "&blah;" ] [ "[[&blah;]]" check-link-escaping ] unit-test
+[ "C++" ] [ "[[C++]]" check-link-escaping ] unit-test
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index 284d5758a3..b9e62717eb 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -2,8 +2,9 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators html.elements io
io.streams.string kernel math namespaces peg peg.ebnf
-sequences sequences.deep strings xml.entities
-vectors splitting xmode.code2html urls.encoding ;
+sequences sequences.deep strings xml.entities xml.interpolate
+vectors splitting xmode.code2html urls.encoding xml.data
+xml.writer ;
IN: farkup
SYMBOL: relative-link-prefix
@@ -74,6 +75,7 @@ inline-code = "%" (!("%" | nl).)+ "%"
=> [[ second >string inline-code boa ]]
link-content = (!("|"|"]").)+
+ => [[ >string ]]
image-link = "[[image:" link-content "|" link-content "]]"
=> [[ [ second >string ] [ fourth >string ] bi image boa ]]
@@ -146,7 +148,7 @@ named-code
simple-code
= "[{" (!("}]").)+ "}]"
- => [[ second f swap code boa ]]
+ => [[ second >string f swap code boa ]]
code = named-code | simple-code
@@ -163,66 +165,78 @@ stand-alone
{ [ dup [ 127 > ] contains? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
- [ relative-link-prefix get prepend ]
- } cond ;
+ [ relative-link-prefix get prepend "" like ]
+ } cond url-encode ;
-: escape-link ( href text -- href-esc text-esc )
- [ check-url escape-quoted-string ] dip escape-string ;
+: write-link ( href text -- xml )
+ [ check-url link-no-follow? get "true" and ] dip
+ [XML nofollow=<->><-> XML] ;
-: write-link ( href text -- )
- escape-link
- [ ]
- [ write ]
- bi* ;
-
-: write-image-link ( href text -- )
+: write-image-link ( href text -- xml )
disable-images? get [
2drop
- "Images are not allowed" write
+ [XML Images are not allowed XML]
] [
- escape-link
- [ ] bi*
+ [ check-url ] [ f like ] bi*
+ [XML alt=<->/> XML]
] if ;
-: render-code ( string mode -- string' )
- [ string-lines ] dip
- [
-
- htmlize-lines
-
- ] with-string-writer write ;
-
-GENERIC: (write-farkup) ( farkup -- )
-: ( string -- ) write ;
-: ( string -- ) write ;
-: in-tag. ( obj quot string -- ) [ call ] keep ; inline
-M: heading1 (write-farkup) [ child>> (write-farkup) ] "h1" in-tag. ;
-M: heading2 (write-farkup) [ child>> (write-farkup) ] "h2" in-tag. ;
-M: heading3 (write-farkup) [ child>> (write-farkup) ] "h3" in-tag. ;
-M: heading4 (write-farkup) [ child>> (write-farkup) ] "h4" in-tag. ;
-M: strong (write-farkup) [ child>> (write-farkup) ] "strong" in-tag. ;
-M: emphasis (write-farkup) [ child>> (write-farkup) ] "em" in-tag. ;
-M: superscript (write-farkup) [ child>> (write-farkup) ] "sup" in-tag. ;
-M: subscript (write-farkup) [ child>> (write-farkup) ] "sub" in-tag. ;
-M: inline-code (write-farkup) [ child>> (write-farkup) ] "code" in-tag. ;
-M: list-item (write-farkup) [ child>> (write-farkup) ] "li" in-tag. ;
-M: unordered-list (write-farkup) [ child>> (write-farkup) ] "ul" in-tag. ;
-M: ordered-list (write-farkup) [ child>> (write-farkup) ] "ol" in-tag. ;
-M: paragraph (write-farkup) [ child>> (write-farkup) ] "p" in-tag. ;
-M: link (write-farkup) [ href>> ] [ text>> ] bi write-link ;
-M: image (write-farkup) [ href>> ] [ text>> ] bi write-image-link ;
-M: code (write-farkup) [ string>> ] [ mode>> ] bi render-code ;
-M: line (write-farkup) drop
;
-M: line-break (write-farkup) drop
nl ;
-M: table-row (write-farkup) ( obj -- )
- child>> [ [ [ (write-farkup) ] "td" in-tag. ] each ] "tr" in-tag. ;
-M: table (write-farkup) [ child>> (write-farkup) ] "table" in-tag. ;
-M: string (write-farkup) escape-string write ;
-M: vector (write-farkup) [ (write-farkup) ] each ;
-M: f (write-farkup) drop ;
+: render-code ( string mode -- xml )
+ [ string-lines ] dip htmlize-lines
+ [XML <->
XML] ;
-: write-farkup ( string -- )
+GENERIC: (write-farkup) ( farkup -- xml )
+
+: farkup-inside ( farkup name -- xml )
+ swap T{ attrs } swap
+ child>> (write-farkup) 1array ;
+
+M: heading1 (write-farkup) "h1" farkup-inside ;
+M: heading2 (write-farkup) "h2" farkup-inside ;
+M: heading3 (write-farkup) "h3" farkup-inside ;
+M: heading4 (write-farkup) "h4" farkup-inside ;
+M: strong (write-farkup) "strong" farkup-inside ;
+M: emphasis (write-farkup) "em" farkup-inside ;
+M: superscript (write-farkup) "sup" farkup-inside ;
+M: subscript (write-farkup) "sub" farkup-inside ;
+M: inline-code (write-farkup) "code" farkup-inside ;
+M: list-item (write-farkup) "li" farkup-inside ;
+M: unordered-list (write-farkup) "ul" farkup-inside ;
+M: ordered-list (write-farkup) "ol" farkup-inside ;
+M: paragraph (write-farkup) "p" farkup-inside ;
+M: table (write-farkup) "table" farkup-inside ;
+
+M: link (write-farkup)
+ [ href>> ] [ text>> ] bi write-link ;
+
+M: image (write-farkup)
+ [ href>> ] [ text>> ] bi write-image-link ;
+
+M: code (write-farkup)
+ [ string>> ] [ mode>> ] bi render-code ;
+
+M: line (write-farkup)
+ drop [XML
XML] ;
+
+M: line-break (write-farkup)
+ drop [XML
XML] ;
+
+M: table-row (write-farkup)
+ child>>
+ [ (write-farkup) [XML <-> | XML] ] map
+ [XML <->
XML] ;
+
+M: string (write-farkup) ;
+
+M: vector (write-farkup) [ (write-farkup) ] map ;
+
+M: f (write-farkup) ;
+
+: farkup>xml ( string -- xml )
parse-farkup (write-farkup) ;
+: write-farkup ( string -- )
+ farkup>xml write-xml ;
+
: convert-farkup ( string -- string' )
- parse-farkup [ (write-farkup) ] with-string-writer ;
+ [ write-farkup ] with-string-writer ;
diff --git a/basis/formatting/authors.txt b/basis/formatting/authors.txt
new file mode 100644
index 0000000000..e091bb8164
--- /dev/null
+++ b/basis/formatting/authors.txt
@@ -0,0 +1 @@
+John Benediktsson
diff --git a/basis/formatting/formatting-docs.factor b/basis/formatting/formatting-docs.factor
new file mode 100644
index 0000000000..196302f203
--- /dev/null
+++ b/basis/formatting/formatting-docs.factor
@@ -0,0 +1,129 @@
+
+USING: help.syntax help.markup kernel prettyprint sequences strings ;
+
+IN: formatting
+
+HELP: printf
+{ $values { "format-string" string } }
+{ $description
+ "Writes the arguments (specified on the stack) formatted according to the format string.\n"
+ $nl
+ "Several format specifications exist for handling arguments of different types, and "
+ "specifying attributes for the result string, including such things as maximum width, "
+ "padding, and decimals.\n"
+ { $table
+ { "%%" "Single %" "" }
+ { "%P.Ds" "String format" "string" }
+ { "%P.DS" "String format uppercase" "string" }
+ { "%c" "Character format" "char" }
+ { "%C" "Character format uppercase" "char" }
+ { "%+Pd" "Integer format" "fixnum" }
+ { "%+P.De" "Scientific notation" "fixnum, float" }
+ { "%+P.DE" "Scientific notation" "fixnum, float" }
+ { "%+P.Df" "Fixed format" "fixnum, float" }
+ { "%+Px" "Hexadecimal" "hex" }
+ { "%+PX" "Hexadecimal uppercase" "hex" }
+ }
+ $nl
+ "A plus sign ('+') is used to optionally specify that the number should be "
+ "formatted with a '+' preceeding it if positive.\n"
+ $nl
+ "Padding ('P') is used to optionally specify the minimum width of the result "
+ "string, the padding character, and the alignment. By default, the padding "
+ "character defaults to a space and the alignment defaults to right-aligned. "
+ "For example:\n"
+ { $list
+ "\"%5s\" formats a string padding with spaces up to 5 characters wide."
+ "\"%08d\" formats an integer padding with zeros up to 3 characters wide."
+ "\"%'#5f\" formats a float padding with '#' up to 3 characters wide."
+ "\"%-10d\" formats an integer to 10 characters wide and left-aligns."
+ }
+ $nl
+ "Digits ('D') is used to optionally specify the maximum digits in the result "
+ "string. For example:\n"
+ { $list
+ "\"%.3s\" formats a string to truncate at 3 characters (from the left)."
+ "\"%.10f\" formats a float to pad-right with zeros up to 10 digits beyond the decimal point."
+ "\"%.5E\" formats a float into scientific notation with zeros up to 5 digits beyond the decimal point, but before the exponent."
+ }
+}
+{ $examples
+ { $example
+ "USING: formatting ;"
+ "123 \"%05d\" printf"
+ "00123" }
+ { $example
+ "USING: formatting ;"
+ "HEX: ff \"%04X\" printf"
+ "00FF" }
+ { $example
+ "USING: formatting ;"
+ "1.23456789 \"%.3f\" printf"
+ "1.235" }
+ { $example
+ "USING: formatting ;"
+ "1234567890 \"%.5e\" printf"
+ "1.23457e+09" }
+ { $example
+ "USING: formatting ;"
+ "12 \"%'#4d\" printf"
+ "##12" }
+ { $example
+ "USING: formatting ;"
+ "1234 \"%+d\" printf"
+ "+1234" }
+} ;
+
+HELP: sprintf
+{ $values { "format-string" string } { "result" string } }
+{ $description "Returns the arguments (specified on the stack) formatted according to the format string as a result string." }
+{ $see-also printf } ;
+
+HELP: strftime
+{ $values { "format-string" string } }
+{ $description
+ "Writes the timestamp (specified on the stack) formatted according to the format string.\n"
+ $nl
+ "Different attributes of the timestamp can be retrieved using format specifications.\n"
+ { $table
+ { "%a" "Abbreviated weekday name." }
+ { "%A" "Full weekday name." }
+ { "%b" "Abbreviated month name." }
+ { "%B" "Full month name." }
+ { "%c" "Date and time representation." }
+ { "%d" "Day of the month as a decimal number [01,31]." }
+ { "%H" "Hour (24-hour clock) as a decimal number [00,23]." }
+ { "%I" "Hour (12-hour clock) as a decimal number [01,12]." }
+ { "%j" "Day of the year as a decimal number [001,366]." }
+ { "%m" "Month as a decimal number [01,12]." }
+ { "%M" "Minute as a decimal number [00,59]." }
+ { "%p" "Either AM or PM." }
+ { "%S" "Second as a decimal number [00,59]." }
+ { "%U" "Week number of the year (Sunday as the first day of the week) as a decimal number [00,53]." }
+ { "%w" "Weekday as a decimal number [0(Sunday),6]." }
+ { "%W" "Week number of the year (Monday as the first day of the week) as a decimal number [00,53]." }
+ { "%x" "Date representation." }
+ { "%X" "Time representation." }
+ { "%y" "Year without century as a decimal number [00,99]." }
+ { "%Y" "Year with century as a decimal number." }
+ { "%Z" "Time zone name (no characters if no time zone exists)." }
+ { "%%" "A literal '%' character." }
+ }
+}
+{ $examples
+ { $unchecked-example
+ "USING: calendar formatting io ;"
+ "now \"%c\" strftime print"
+ "Mon Dec 15 14:40:43 2008" }
+} ;
+
+ARTICLE: "formatting" "Formatted printing"
+"The " { $vocab-link "formatting" } " vocabulary is used for formatted printing."
+{ $subsection printf }
+{ $subsection sprintf }
+{ $subsection strftime }
+;
+
+ABOUT: "formatting"
+
+
diff --git a/basis/formatting/formatting-tests.factor b/basis/formatting/formatting-tests.factor
new file mode 100644
index 0000000000..c7e9fb985e
--- /dev/null
+++ b/basis/formatting/formatting-tests.factor
@@ -0,0 +1,97 @@
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: calendar kernel formatting tools.test ;
+
+IN: formatting.tests
+
+[ "%s" printf ] must-infer
+[ "%s" sprintf ] must-infer
+
+[ t ] [ "" "" sprintf = ] unit-test
+[ t ] [ "asdf" "asdf" sprintf = ] unit-test
+[ t ] [ "10" 10 "%d" sprintf = ] unit-test
+[ t ] [ "+10" 10 "%+d" sprintf = ] unit-test
+[ t ] [ "-10" -10 "%d" sprintf = ] unit-test
+[ t ] [ " -10" -10 "%5d" sprintf = ] unit-test
+[ t ] [ "-0010" -10 "%05d" sprintf = ] unit-test
+[ t ] [ "+0010" 10 "%+05d" sprintf = ] unit-test
+[ t ] [ "123.456000" 123.456 "%f" sprintf = ] unit-test
+[ t ] [ "2.44" 2.436 "%.2f" sprintf = ] unit-test
+[ t ] [ "123.10" 123.1 "%01.2f" sprintf = ] unit-test
+[ t ] [ "1.2346" 1.23456789 "%.4f" sprintf = ] unit-test
+[ t ] [ " 1.23" 1.23456789 "%6.2f" sprintf = ] unit-test
+[ t ] [ "1.234000e+08" 123400000 "%e" sprintf = ] unit-test
+[ t ] [ "-1.234000e+08" -123400000 "%e" sprintf = ] unit-test
+[ t ] [ "1.234567e+08" 123456700 "%e" sprintf = ] unit-test
+[ t ] [ "3.625e+08" 362525200 "%.3e" sprintf = ] unit-test
+[ t ] [ "2.500000e-03" 0.0025 "%e" sprintf = ] unit-test
+[ t ] [ "2.500000E-03" 0.0025 "%E" sprintf = ] unit-test
+[ t ] [ " 1.0E+01" 10 "%10.1E" sprintf = ] unit-test
+[ t ] [ " -1.0E+01" -10 "%10.1E" sprintf = ] unit-test
+[ t ] [ " -1.0E+01" -10 "%+10.1E" sprintf = ] unit-test
+[ t ] [ " +1.0E+01" 10 "%+10.1E" sprintf = ] unit-test
+[ t ] [ "-001.0E+01" -10 "%+010.1E" sprintf = ] unit-test
+[ t ] [ "+001.0E+01" 10 "%+010.1E" sprintf = ] unit-test
+[ t ] [ "ff" HEX: ff "%x" sprintf = ] unit-test
+[ t ] [ "FF" HEX: ff "%X" sprintf = ] unit-test
+[ t ] [ "0f" HEX: f "%02x" sprintf = ] unit-test
+[ t ] [ "0F" HEX: f "%02X" sprintf = ] unit-test
+[ t ] [ "2008-09-10"
+ 2008 9 10 "%04d-%02d-%02d" sprintf = ] unit-test
+[ t ] [ "Hello, World!"
+ "Hello, World!" "%s" sprintf = ] unit-test
+[ t ] [ "printf test"
+ "printf test" sprintf = ] unit-test
+[ t ] [ "char a = 'a'"
+ CHAR: a "char %c = 'a'" sprintf = ] unit-test
+[ t ] [ "00" HEX: 0 "%02x" sprintf = ] unit-test
+[ t ] [ "ff" HEX: ff "%02x" sprintf = ] unit-test
+[ t ] [ "0 message(s)"
+ 0 "message" "%d %s(s)" sprintf = ] unit-test
+[ t ] [ "0 message(s) with %"
+ 0 "message" "%d %s(s) with %%" sprintf = ] unit-test
+[ t ] [ "justif: \"left \""
+ "left" "justif: \"%-10s\"" sprintf = ] unit-test
+[ t ] [ "justif: \" right\""
+ "right" "justif: \"%10s\"" sprintf = ] unit-test
+[ t ] [ " 3: 0003 zero padded"
+ 3 " 3: %04d zero padded" sprintf = ] unit-test
+[ t ] [ " 3: 3 left justif"
+ 3 " 3: %-4d left justif" sprintf = ] unit-test
+[ t ] [ " 3: 3 right justif"
+ 3 " 3: %4d right justif" sprintf = ] unit-test
+[ t ] [ " -3: -003 zero padded"
+ -3 " -3: %04d zero padded" sprintf = ] unit-test
+[ t ] [ " -3: -3 left justif"
+ -3 " -3: %-4d left justif" sprintf = ] unit-test
+[ t ] [ " -3: -3 right justif"
+ -3 " -3: %4d right justif" sprintf = ] unit-test
+[ t ] [ "There are 10 monkeys in the kitchen"
+ 10 "kitchen" "There are %d monkeys in the %s" sprintf = ] unit-test
+[ f ] [ "%d" 10 "%d" sprintf = ] unit-test
+[ t ] [ "[monkey]" "monkey" "[%s]" sprintf = ] unit-test
+[ t ] [ "[ monkey]" "monkey" "[%10s]" sprintf = ] unit-test
+[ t ] [ "[monkey ]" "monkey" "[%-10s]" sprintf = ] unit-test
+[ t ] [ "[0000monkey]" "monkey" "[%010s]" sprintf = ] unit-test
+[ t ] [ "[####monkey]" "monkey" "[%'#10s]" sprintf = ] unit-test
+[ t ] [ "[many monke]" "many monkeys" "[%10.10s]" sprintf = ] unit-test
+
+
+[ "%H:%M:%S" strftime ] must-infer
+
+: testtime ( -- timestamp )
+ 2008 10 9 12 3 15 instant ;
+
+[ t ] [ "12:03:15" testtime "%H:%M:%S" strftime = ] unit-test
+[ t ] [ "12:03:15" testtime "%X" strftime = ] unit-test
+[ t ] [ "10/09/2008" testtime "%m/%d/%Y" strftime = ] unit-test
+[ t ] [ "10/09/2008" testtime "%x" strftime = ] unit-test
+[ t ] [ "10/09/08" testtime "%m/%d/%y" strftime = ] unit-test
+[ t ] [ "Thu" testtime "%a" strftime = ] unit-test
+[ t ] [ "Thursday" testtime "%A" strftime = ] unit-test
+[ t ] [ "Oct" testtime "%b" strftime = ] unit-test
+[ t ] [ "October" testtime "%B" strftime = ] unit-test
+[ t ] [ "Thu Oct 09 12:03:15 2008" testtime "%c" strftime = ] unit-test
+[ t ] [ "PM" testtime "%p" strftime = ] unit-test
+
diff --git a/basis/formatting/formatting.factor b/basis/formatting/formatting.factor
new file mode 100644
index 0000000000..3f12c36bbd
--- /dev/null
+++ b/basis/formatting/formatting.factor
@@ -0,0 +1,185 @@
+! Copyright (C) 2008 John Benediktsson
+! See http://factorcode.org/license.txt for BSD license
+
+USING: accessors arrays ascii calendar combinators fry kernel
+generalizations io io.encodings.ascii io.files io.streams.string
+macros math math.functions math.parser peg.ebnf quotations
+sequences splitting strings unicode.case vectors ;
+
+IN: formatting
+
+digits ( string -- digits )
+ [ 0 ] [ string>number ] if-empty ;
+
+: pad-digits ( string digits -- string' )
+ [ "." split1 ] dip [ CHAR: 0 pad-right ] [ head-slice ] bi "." glue ;
+
+: max-digits ( n digits -- n' )
+ 10 swap ^ [ * round ] keep / ; inline
+
+: >exp ( x -- exp base )
+ [
+ abs 0 swap
+ [ dup [ 10.0 >= ] [ 1.0 < ] bi or ]
+ [ dup 10.0 >=
+ [ 10.0 / [ 1+ ] dip ]
+ [ 10.0 * [ 1- ] dip ] if
+ ] [ ] while
+ ] keep 0 < [ neg ] when ;
+
+: exp>string ( exp base digits -- string )
+ [ max-digits ] keep -rot
+ [
+ [ 0 < "-" "+" ? ]
+ [ abs number>string 2 CHAR: 0 pad-left ] bi
+ "e" -rot 3append
+ ]
+ [ number>string ] bi*
+ rot pad-digits prepend ;
+
+EBNF: parse-printf
+
+zero = "0" => [[ CHAR: 0 ]]
+char = "'" (.) => [[ second ]]
+
+pad-char = (zero|char)? => [[ CHAR: \s or ]]
+pad-align = ("-")? => [[ \ pad-right \ pad-left ? ]]
+pad-width = ([0-9])* => [[ >digits ]]
+pad = pad-align pad-char pad-width => [[ reverse >quotation dup first 0 = [ drop [ ] ] when ]]
+
+sign = ("+")? => [[ [ dup CHAR: - swap index [ "+" prepend ] unless ] [ ] ? ]]
+
+width_ = "." ([0-9])* => [[ second >digits '[ _ short head ] ]]
+width = (width_)? => [[ [ ] or ]]
+
+digits_ = "." ([0-9])* => [[ second >digits ]]
+digits = (digits_)? => [[ 6 or ]]
+
+fmt-% = "%" => [[ [ "%" ] ]]
+fmt-c = "c" => [[ [ 1string ] ]]
+fmt-C = "C" => [[ [ 1string >upper ] ]]
+fmt-s = "s" => [[ [ ] ]]
+fmt-S = "S" => [[ [ >upper ] ]]
+fmt-d = "d" => [[ [ >fixnum number>string ] ]]
+fmt-e = digits "e" => [[ first '[ >exp _ exp>string ] ]]
+fmt-E = digits "E" => [[ first '[ >exp _ exp>string >upper ] ]]
+fmt-f = digits "f" => [[ first dup '[ >float _ max-digits number>string _ pad-digits ] ]]
+fmt-x = "x" => [[ [ >hex ] ]]
+fmt-X = "X" => [[ [ >hex >upper ] ]]
+unknown = (.)* => [[ "Unknown directive" throw ]]
+
+strings_ = fmt-c|fmt-C|fmt-s|fmt-S
+strings = pad width strings_ => [[ reverse compose-all ]]
+
+numbers_ = fmt-d|fmt-e|fmt-E|fmt-f|fmt-x|fmt-X
+numbers = sign pad numbers_ => [[ unclip-last prefix compose-all [ fix-sign ] append ]]
+
+formats = "%" (strings|numbers|fmt-%|unknown) => [[ second '[ _ dip ] ]]
+
+plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
+
+text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: printf ( format-string -- )
+ parse-printf [ length ] keep compose-all '[ _ @ reverse [ write ] each ] ;
+
+: sprintf ( format-string -- result )
+ [ printf ] with-string-writer ; inline
+
+
+string 2 CHAR: 0 pad-left ; inline
+
+: pad-000 ( n -- string ) number>string 3 CHAR: 0 pad-left ; inline
+
+: >time ( timestamp -- string )
+ [ hour>> ] [ minute>> ] [ second>> floor ] tri 3array
+ [ pad-00 ] map ":" join ; inline
+
+: >date ( timestamp -- string )
+ [ month>> ] [ day>> ] [ year>> ] tri 3array
+ [ pad-00 ] map "/" join ; inline
+
+: >datetime ( timestamp -- string )
+ { [ day-of-week day-abbreviation3 ]
+ [ month>> month-abbreviation ]
+ [ day>> pad-00 ]
+ [ >time ]
+ [ year>> number>string ]
+ } cleave 5 narray " " join ; inline
+
+: (week-of-year) ( timestamp day -- n )
+ [ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
+ [ day-of-year ] dip 2dup < [ 0 2nip ] [ - 7 / 1+ >fixnum ] if ;
+
+: week-of-year-sunday ( timestamp -- n ) 0 (week-of-year) ; inline
+
+: week-of-year-monday ( timestamp -- n ) 1 (week-of-year) ; inline
+
+EBNF: parse-strftime
+
+fmt-% = "%" => [[ [ "%" ] ]]
+fmt-a = "a" => [[ [ dup day-of-week day-abbreviation3 ] ]]
+fmt-A = "A" => [[ [ dup day-of-week day-name ] ]]
+fmt-b = "b" => [[ [ dup month>> month-abbreviation ] ]]
+fmt-B = "B" => [[ [ dup month>> month-name ] ]]
+fmt-c = "c" => [[ [ dup >datetime ] ]]
+fmt-d = "d" => [[ [ dup day>> pad-00 ] ]]
+fmt-H = "H" => [[ [ dup hour>> pad-00 ] ]]
+fmt-I = "I" => [[ [ dup hour>> dup 12 > [ 12 - ] when pad-00 ] ]]
+fmt-j = "j" => [[ [ dup day-of-year pad-000 ] ]]
+fmt-m = "m" => [[ [ dup month>> pad-00 ] ]]
+fmt-M = "M" => [[ [ dup minute>> pad-00 ] ]]
+fmt-p = "p" => [[ [ dup hour>> 12 < "AM" "PM" ? ] ]]
+fmt-S = "S" => [[ [ dup second>> floor pad-00 ] ]]
+fmt-U = "U" => [[ [ dup week-of-year-sunday pad-00 ] ]]
+fmt-w = "w" => [[ [ dup day-of-week number>string ] ]]
+fmt-W = "W" => [[ [ dup week-of-year-monday pad-00 ] ]]
+fmt-x = "x" => [[ [ dup >date ] ]]
+fmt-X = "X" => [[ [ dup >time ] ]]
+fmt-y = "y" => [[ [ dup year>> 100 mod pad-00 ] ]]
+fmt-Y = "Y" => [[ [ dup year>> number>string ] ]]
+fmt-Z = "Z" => [[ [ "Not yet implemented" throw ] ]]
+unknown = (.)* => [[ "Unknown directive" throw ]]
+
+formats_ = fmt-%|fmt-a|fmt-A|fmt-b|fmt-B|fmt-c|fmt-d|fmt-H|fmt-I|
+ fmt-j|fmt-m|fmt-M|fmt-p|fmt-S|fmt-U|fmt-w|fmt-W|fmt-x|
+ fmt-X|fmt-y|fmt-Y|fmt-Z|unknown
+
+formats = "%" (formats_) => [[ second '[ _ dip ] ]]
+
+plain-text = (!("%").)+ => [[ >string '[ _ swap ] ]]
+
+text = (formats|plain-text)* => [[ reverse [ [ [ push ] keep ] append ] map ]]
+
+;EBNF
+
+PRIVATE>
+
+MACRO: strftime ( format-string -- )
+ parse-strftime [ length ] keep [ ] join
+ '[ _ @ reverse concat nip ] ;
+
+
diff --git a/basis/formatting/summary.txt b/basis/formatting/summary.txt
new file mode 100644
index 0000000000..da1aa31abb
--- /dev/null
+++ b/basis/formatting/summary.txt
@@ -0,0 +1 @@
+Format data according to a specified format string, and writes (or returns) the result string.
diff --git a/basis/fry/fry-docs.factor b/basis/fry/fry-docs.factor
index 1dff0942bd..5d750775e5 100644
--- a/basis/fry/fry-docs.factor
+++ b/basis/fry/fry-docs.factor
@@ -20,7 +20,7 @@ HELP: '[
{ $examples "See " { $link "fry.examples" } "." } ;
HELP: >r/r>-in-fry-error
-{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to " { $link >r } " or " { $link r> } ". Explicit retain stack manipulation of this form does not work with fry; use " { $link dip } " instead." } ;
+{ $error-description "Thrown by " { $link POSTPONE: '[ } " if the fried quotation contains calls to retain stack manipulation primitives." } ;
ARTICLE: "fry.examples" "Examples of fried quotations"
"The easiest way to understand fried quotations is to look at some examples."
@@ -69,18 +69,18 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
"'[ [ _ key? ] all? ] filter"
"[ [ key? ] curry all? ] curry filter"
}
-"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a ``let'' form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
+"There is a mapping from fried quotations to lexical closures as defined in the " { $vocab-link "locals" } " vocabulary. Namely, a fried quotation is equivalent to a âletâ form where each local binding is only used once, and bindings are used in the same order in which they are defined. The following two lines are equivalent:"
{ $code
"'[ 3 _ + 4 _ / ]"
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
} ;
ARTICLE: "fry" "Fried quotations"
-"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
+"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with âholesâ (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
$nl
"Fried quotations are started by a special parsing word:"
{ $subsection POSTPONE: '[ }
-"There are two types of fry specifiers; the first can hold a value, and the second ``splices'' a quotation, as if it were inserted without surrounding brackets:"
+"There are two types of fry specifiers; the first can hold a value, and the second âsplicesâ a quotation, as if it were inserted without surrounding brackets:"
{ $subsection _ }
{ $subsection @ }
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
diff --git a/basis/fry/fry-tests.factor b/basis/fry/fry-tests.factor
index 0137e8be22..7189450394 100644
--- a/basis/fry/fry-tests.factor
+++ b/basis/fry/fry-tests.factor
@@ -56,7 +56,7 @@ sequences eval accessors ;
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
-[ "USING: fry kernel ; f '[ >r _ r> ]" eval ]
+[ "USING: fry locals.backend ; f '[ load-local _ ]" eval ]
[ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [
diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor
index f84ad233cd..e62a42749f 100644
--- a/basis/fry/fry.factor
+++ b/basis/fry/fry.factor
@@ -25,7 +25,7 @@ M: >r/r>-in-fry-error summary
"Explicit retain stack manipulation is not permitted in fried quotations" ;
: check-fry ( quot -- quot )
- dup { >r r> load-locals get-local drop-locals } intersect
+ dup { load-local load-locals get-local drop-locals } intersect
empty? [ >r/r>-in-fry-error ] unless ;
PREDICATE: fry-specifier < word { _ @ } memq? ;
diff --git a/basis/ftp/client/client.factor b/basis/ftp/client/client.factor
index 9c82cdbb50..ac21bb8f78 100644
--- a/basis/ftp/client/client.factor
+++ b/basis/ftp/client/client.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays classes.singleton combinators
continuations io io.encodings.binary io.encodings.utf8
-io.files io.sockets kernel io.streams.duplex math
+io.files io.pathnames io.sockets kernel io.streams.duplex math
math.parser sequences splitting namespaces strings fry ftp
ftp.client.listing-parser urls ;
IN: ftp.client
@@ -104,7 +104,3 @@ ERROR: ftp-error got expected ;
[ nip parent-directory ftp-cwd drop ]
[ file-name (ftp-get) ] 2bi
] with-ftp-client ;
-
-
-
-
diff --git a/basis/ftp/client/listing-parser/listing-parser.factor b/basis/ftp/client/listing-parser/listing-parser.factor
index 04e96ed77a..6183165b3a 100644
--- a/basis/ftp/client/listing-parser/listing-parser.factor
+++ b/basis/ftp/client/listing-parser/listing-parser.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors combinators io.files kernel math.parser
+USING: accessors combinators io.files.types kernel math.parser
sequences splitting ;
IN: ftp.client.listing-parser
diff --git a/basis/ftp/server/server.factor b/basis/ftp/server/server.factor
index b0ec340202..20a753785c 100644
--- a/basis/ftp/server/server.factor
+++ b/basis/ftp/server/server.factor
@@ -2,12 +2,13 @@
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit accessors combinators io
io.encodings.8-bit io.encodings io.encodings.binary
-io.encodings.utf8 io.files io.sockets kernel math.parser
-namespaces make sequences ftp io.unix.launcher.parser
-unicode.case splitting assocs classes io.servers.connection
-destructors calendar io.timeouts io.streams.duplex threads
-continuations math concurrency.promises byte-arrays
-io.backend tools.hexdump tools.files io.streams.string ;
+io.encodings.utf8 io.files io.files.info io.directories
+io.sockets kernel math.parser namespaces make sequences
+ftp io.launcher.unix.parser unicode.case splitting
+assocs classes io.servers.connection destructors calendar
+io.timeouts io.streams.duplex threads continuations math
+concurrency.promises byte-arrays io.backend tools.hexdump
+io.streams.string math.bitwise tools.files io.pathnames ;
IN: ftp.server
TUPLE: ftp-client url mode state command-promise user password ;
@@ -48,7 +49,7 @@ C: ftp-list
[ >>raw ] [ tokenize-command >>tokenized ] bi ;
: (send-response) ( n string separator -- )
- rot number>string write write ftp-send ;
+ [ number>string write ] 2dip write ftp-send ;
: send-response ( ftp-response -- )
[ n>> ] [ strings>> ] bi
@@ -101,7 +102,7 @@ ERROR: type-error type ;
: handle-TYPE ( obj -- )
[
tokenized>> second parse-type
- 200 "Switching to " rot " mode" 3append server-response
+ [ 200 ] dip "Switching to " " mode" surround server-response
] [
2drop "TYPE is binary only" ftp-error
] recover ;
@@ -110,11 +111,11 @@ ERROR: type-error type ;
remote-address get class new 0 >>port binary ;
: port>bytes ( port -- hi lo )
- [ -8 shift ] keep [ HEX: ff bitand ] bi@ ;
+ [ -8 shift ] keep [ 8 bits ] bi@ ;
: handle-PWD ( obj -- )
drop
- 257 current-directory get "\"" "\"" surround server-response ;
+ 257 current-directory get "\"" dup surround server-response ;
: handle-SYST ( obj -- )
drop
@@ -154,15 +155,19 @@ M: ftp-list service-command ( stream obj -- )
finish-directory ;
: transfer-outgoing-file ( path -- )
- 150 "Opening BINARY mode data connection for "
- rot
- [ file-name ] [
- " " swap file-info size>> number>string
- "(" " bytes)." surround append
- ] bi 3append server-response ;
+ [
+ 150
+ "Opening BINARY mode data connection for "
+ ] dip
+ [
+ file-name
+ ] [
+ file-info size>> number>string
+ "(" " bytes)." surround
+ ] bi " " glue append server-response ;
: transfer-incoming-file ( path -- )
- 150 "Opening BINARY mode data connection for " rot append
+ [ 150 ] dip "Opening BINARY mode data connection for " prepend
server-response ;
: finish-file-transfer ( -- )
@@ -208,8 +213,9 @@ M: ftp-put service-command ( stream obj -- )
: handle-SIZE ( obj -- )
[
+ [ 213 ] dip
tokenized>> second file-info size>>
- 213 swap number>string server-response
+ number>string server-response
] [
2drop
550 "Could not get file size" server-response
@@ -227,21 +233,20 @@ M: ftp-put service-command ( stream obj -- )
: handle-PASV ( obj -- )
drop client get passive >>mode drop
- expect-connection
- [
- "Entering Passive Mode (127,0,0,1," %
- port>bytes [ number>string ] bi@ "," glue %
- ")" %
- ] "" make 227 swap server-response ;
+ 221
+ expect-connection port>bytes [ number>string ] bi@ "," glue
+ "Entering Passive Mode (127,0,0,1," ")" surround
+ server-response ;
: handle-EPSV ( obj -- )
drop
client get command-promise>> [
"You already have a passive stream" ftp-error
] [
- 229 "Entering Extended Passive Mode (|||"
+ 229
expect-connection number>string
- "|)" 3append server-response
+ "Entering Extended Passive Mode (|||" "|)" surround
+ server-response
] if ;
! LPRT 6,16,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,1,2,242,186
diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor
index 39923afee7..a5f3042b38 100644
--- a/basis/functors/functors-tests.factor
+++ b/basis/functors/functors-tests.factor
@@ -34,7 +34,7 @@ WW DEFINES ${W}${W}
WHERE
-: WW W twice ; inline
+: WW ( a -- b ) \ W twice ; inline
;FUNCTOR
@@ -45,3 +45,21 @@ WHERE
\ sqsq must-infer
[ 16 ] [ 2 sqsq ] unit-test
+
+<<
+
+FUNCTOR: wrapper-test-2 ( W -- )
+
+W DEFINES ${W}
+
+WHERE
+
+: W ( a b -- c ) \ + execute ;
+
+;FUNCTOR
+
+"blah" wrapper-test-2
+
+>>
+
+[ 4 ] [ 1 3 blah ] unit-test
\ No newline at end of file
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index 2029c0cf25..f4d35b6932 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -1,16 +1,43 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel quotations classes.tuple make combinators generic
words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser
-effects.parser locals.types locals.parser locals.rewrite.closures ;
+effects.parser locals.types locals.parser
+locals.rewrite.closures vocabs.parser arrays accessors ;
IN: functors
-: scan-param ( -- obj )
- scan-object dup special? [ literalize ] unless ;
+! This is a hack
+
+fake-quotations ( quot -- fake )
+
+M: callable >fake-quotations
+ >array >fake-quotations fake-quotation boa ;
+
+M: array >fake-quotations [ >fake-quotations ] { } map-as ;
+
+M: object >fake-quotations ;
+
+GENERIC: fake-quotations> ( fake -- quot )
+
+M: fake-quotation fake-quotations>
+ seq>> [ fake-quotations> ] map >quotation ;
+
+M: array fake-quotations> [ fake-quotations> ] map ;
+
+M: object fake-quotations> ;
+
+: parse-definition* ( -- )
+ parse-definition >fake-quotations parsed \ fake-quotations> parsed ;
+
: DEFINE* ( accum -- accum ) effect get parsed \ define* parsed ;
: `TUPLE:
@@ -31,7 +58,7 @@ IN: functors
scan-param parsed
scan-param parsed
\ create-method parsed
- parse-definition parsed
+ parse-definition*
DEFINE* ; parsing
: `C:
@@ -44,7 +71,7 @@ IN: functors
: `:
effect off
scan-param parsed
- parse-definition parsed
+ parse-definition*
DEFINE* ; parsing
: `INSTANCE:
@@ -63,12 +90,16 @@ IN: functors
[ scan interpolate-locals ] dip
'[ _ with-string-writer @ ] parsed ;
+PRIVATE>
+
: IS [ dup search [ ] [ no-word ] ?if ] (INTERPOLATE) ; parsing
: DEFINES [ create-in ] (INTERPOLATE) ; parsing
DEFER: ;FUNCTOR delimiter
+
rewrite-closures first ;
+PRIVATE>
+
: FUNCTOR: (FUNCTOR:) define ; parsing
diff --git a/basis/furnace/alloy/alloy-docs.factor b/basis/furnace/alloy/alloy-docs.factor
index f108428c90..f21fc237a8 100644
--- a/basis/furnace/alloy/alloy-docs.factor
+++ b/basis/furnace/alloy/alloy-docs.factor
@@ -5,7 +5,7 @@ HELP: init-furnace-tables
{ $description "Initializes database tables used by asides, conversations and session management. This word must be invoked inside a " { $link with-db } " scope." } ;
HELP:
-{ $values { "responder" "a responder" } { "db" db } { "responder'" "an alloy responder" } }
+{ $values { "responder" "a responder" } { "db" "a database descriptor" } { "responder'" "an alloy responder" } }
{ $description "Wraps the responder with support for asides, conversations, sessions and database persistence." }
{ $examples
"The " { $vocab-link "webapps.counter" } " vocabulary uses an alloy to configure the counter:"
@@ -21,7 +21,7 @@ HELP:
} ;
HELP: start-expiring
-{ $values { "db" db } }
+{ $values { "db" "a database descriptor" } }
{ $description "Starts a timer which expires old session state from the given database." } ;
ARTICLE: "furnace.alloy" "Furnace alloy responder"
diff --git a/basis/furnace/auth/auth-docs.factor b/basis/furnace/auth/auth-docs.factor
index e7e722344a..f1f68c975d 100644
--- a/basis/furnace/auth/auth-docs.factor
+++ b/basis/furnace/auth/auth-docs.factor
@@ -1,5 +1,5 @@
USING: assocs classes help.markup help.syntax kernel
-quotations strings words furnace.auth.providers.db
+quotations strings words words.symbol furnace.auth.providers.db
checksums.sha2 furnace.auth.providers math byte-arrays
http multiline ;
IN: furnace.auth
@@ -121,7 +121,7 @@ $nl
{ $subsection "furnace.auth.providers.db" } ;
ARTICLE: "furnace.auth.features" "Optional authentication features"
-"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm."
+"Vocabularies having names prefixed by " { $code "furnace.auth.features" } " implement optional features which can be enabled by calling special words. These words define new actions on an authentication realm."
{ $subsection "furnace.auth.features.deactivate-user" }
{ $subsection "furnace.auth.features.edit-profile" }
{ $subsection "furnace.auth.features.recover-password" }
@@ -148,7 +148,7 @@ ARTICLE: "furnace.auth.users" "User profiles"
"User profile variables have the same restrictions on their values as session variables; see " { $link "furnace.sessions.serialize" } " for a discussion." ;
ARTICLE: "furnace.auth.example" "Furnace authentication example"
-"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message ``You must log in to view your todo list'':"
+"The " { $vocab-link "webapps.todo" } " vocabulary wraps all of its responders in a protected responder. The " { $slot "description" } " slot is set so that the login page contains the message âYou must log in to view your todo listâ:"
{ $code
<"
"view your todo list" >>description">
diff --git a/basis/furnace/auth/features/recover-password/recover-password.factor b/basis/furnace/auth/features/recover-password/recover-password.factor
index 77be30a2d1..aeaf9e9471 100644
--- a/basis/furnace/auth/features/recover-password/recover-password.factor
+++ b/basis/furnace/auth/features/recover-password/recover-password.factor
@@ -27,7 +27,7 @@ SYMBOL: lost-password-from
over email>> 1array >>to
[
"This e-mail was sent by the application server on " % current-host % "\n" %
- "because somebody, maybe you, clicked on a ``recover password'' link in the\n" %
+ "because somebody, maybe you, clicked on a ârecover passwordâ link in the\n" %
"login form, and requested a new password for the user named ``" %
over username>> % "''.\n" %
"\n" %
diff --git a/basis/furnace/auth/providers/db/db-tests.factor b/basis/furnace/auth/providers/db/db-tests.factor
index 3bcd82a15d..de7650d9ef 100644
--- a/basis/furnace/auth/providers/db/db-tests.factor
+++ b/basis/furnace/auth/providers/db/db-tests.factor
@@ -5,7 +5,7 @@ furnace.auth.login
furnace.auth.providers
furnace.auth.providers.db tools.test
namespaces db db.sqlite db.tuples continuations
-io.files accessors kernel ;
+io.files io.files.temp io.directories accessors kernel ;
"test" realm set
diff --git a/basis/furnace/chloe-tags/chloe-tags.factor b/basis/furnace/chloe-tags/chloe-tags.factor
index 8ab70ded7b..1c320182bf 100644
--- a/basis/furnace/chloe-tags/chloe-tags.factor
+++ b/basis/furnace/chloe-tags/chloe-tags.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel combinators assocs
namespaces sequences splitting words
-fry urls multiline present qualified
+fry urls multiline present
xml
xml.data
xml.entities
@@ -32,7 +32,7 @@ IN: furnace.chloe-tags
[ [ "/" ?tail drop "/" ] dip present 3append ] when* ;
: a-url ( href rest query value-name -- url )
- dup [ >r 3drop r> value ] [
+ dup [ [ 3drop ] dip value ] [
drop
swap parse-query-attr >>query
diff --git a/basis/furnace/conversations/conversations-docs.factor b/basis/furnace/conversations/conversations-docs.factor
index 4ad2c8a249..2b644ef422 100644
--- a/basis/furnace/conversations/conversations-docs.factor
+++ b/basis/furnace/conversations/conversations-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax urls http words kernel
-furnace.sessions furnace.db ;
+furnace.sessions furnace.db words.symbol ;
IN: furnace.conversations
HELP:
diff --git a/basis/furnace/db/db-docs.factor b/basis/furnace/db/db-docs.factor
index a7ef02b77f..c64356c812 100644
--- a/basis/furnace/db/db-docs.factor
+++ b/basis/furnace/db/db-docs.factor
@@ -3,7 +3,7 @@ IN: furnace.db
HELP:
{ $values
- { "responder" "a responder" } { "db" db }
+ { "responder" "a responder" } { "db" "a database descriptor" }
{ "responder'" db-persistence }
}
{ $description "Wraps a responder with database persistence support. The responder's " { $link call-responder* } " method will run in a " { $link with-db } " scope." } ;
diff --git a/basis/furnace/db/db.factor b/basis/furnace/db/db.factor
index ed18e42a4f..d771d1d2d7 100644
--- a/basis/furnace/db/db.factor
+++ b/basis/furnace/db/db.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors continuations namespaces destructors
-db db.pools io.pools http.server http.server.filters ;
+db db.private db.pools io.pools http.server http.server.filters ;
IN: furnace.db
TUPLE: db-persistence < filter-responder pool ;
@@ -12,6 +12,6 @@ TUPLE: db-persistence < filter-responder pool ;
M: db-persistence call-responder*
[
pool>> [ acquire-connection ] keep
- [ return-connection-later ] [ drop db set ] 2bi
+ [ return-connection-later ] [ drop db-connection set ] 2bi
]
[ call-next-method ] bi ;
diff --git a/basis/furnace/redirection/redirection-docs.factor b/basis/furnace/redirection/redirection-docs.factor
index fd3671fa1c..b70ec0ae57 100644
--- a/basis/furnace/redirection/redirection-docs.factor
+++ b/basis/furnace/redirection/redirection-docs.factor
@@ -10,8 +10,8 @@ HELP:
{ $values { "url" url } { "response" response } }
{ $description "Creates a response which redirects the client to the given URL." } ;
-HELP: ( responder -- responder' )
-{ $values { "responder" "a responder" } { "responder'" "a responder" } }
+HELP:
+{ $values { "responder" "a responder" } { "secure-only" "a responder" } }
{ $description "Creates a new responder which ensures that the client is connecting via HTTPS before delegating to the underlying responder. If the client is connecting via HTTP, a redirect is sent instead." } ;
HELP:
diff --git a/basis/furnace/sessions/sessions-docs.factor b/basis/furnace/sessions/sessions-docs.factor
index 959d6b69b8..7a4de18eaf 100644
--- a/basis/furnace/sessions/sessions-docs.factor
+++ b/basis/furnace/sessions/sessions-docs.factor
@@ -1,4 +1,6 @@
-USING: help.markup help.syntax io.streams.string quotations strings calendar serialize kernel furnace.db words kernel ;
+USING: help.markup help.syntax io.streams.string quotations
+strings calendar serialize kernel furnace.db words words.symbol
+kernel ;
IN: furnace.sessions
HELP:
diff --git a/basis/furnace/sessions/sessions-tests.factor b/basis/furnace/sessions/sessions-tests.factor
index 907e657125..14cdce3811 100644
--- a/basis/furnace/sessions/sessions-tests.factor
+++ b/basis/furnace/sessions/sessions-tests.factor
@@ -2,9 +2,9 @@ IN: furnace.sessions.tests
USING: tools.test http furnace.sessions furnace.actions
http.server http.server.responses math namespaces make kernel
accessors io.sockets io.servers.connection prettyprint
-io.streams.string io.files splitting destructors sequences db
-db.tuples db.sqlite continuations urls math.parser furnace
-furnace.utilities ;
+io.streams.string io.files io.files.temp io.directories
+splitting destructors sequences db db.tuples db.sqlite
+continuations urls math.parser furnace furnace.utilities ;
: with-session
[
diff --git a/basis/furnace/syndication/syndication-docs.factor b/basis/furnace/syndication/syndication-docs.factor
index 94a69ccd0e..1ce1cd7da1 100644
--- a/basis/furnace/syndication/syndication-docs.factor
+++ b/basis/furnace/syndication/syndication-docs.factor
@@ -29,7 +29,7 @@ HELP: feed-entry-date
HELP: feed-entry-description
{ $values
{ "object" object }
- { "description" null }
+ { "description" string }
}
{ $contract "Outputs a feed entry description." } ;
diff --git a/basis/furnace/utilities/utilities.factor b/basis/furnace/utilities/utilities.factor
index 7f71a131ed..f84519b9c1 100644
--- a/basis/furnace/utilities/utilities.factor
+++ b/basis/furnace/utilities/utilities.factor
@@ -96,11 +96,7 @@ M: object modify-form drop ;
dup method>> {
{ "GET" [ url>> query>> ] }
{ "HEAD" [ url>> query>> ] }
- { "POST" [
- post-data>>
- dup content-type>> "application/x-www-form-urlencoded" =
- [ content>> ] [ drop f ] if
- ] }
+ { "POST" [ post-data>> params>> ] }
} case ;
: referrer ( -- referrer/f )
diff --git a/basis/generalizations/generalizations-docs.factor b/basis/generalizations/generalizations-docs.factor
index 3979e0518a..a676be3be8 100644
--- a/basis/generalizations/generalizations-docs.factor
+++ b/basis/generalizations/generalizations-docs.factor
@@ -229,8 +229,9 @@ HELP: napply
{ $examples
"Some core words expressed in terms of " { $link napply } ":"
{ $table
- { { $link bi@ } { $snippet "1 napply" } }
- { { $link tri@ } { $snippet "2 napply" } }
+ { { $link call } { $snippet "1 napply" } }
+ { { $link bi@ } { $snippet "2 napply" } }
+ { { $link tri@ } { $snippet "3 napply" } }
}
} ;
@@ -258,6 +259,55 @@ HELP: mnswap
}
} ;
+HELP: n*quot
+{ $values
+ { "n" integer } { "seq" sequence }
+ { "seq'" sequence }
+}
+{ $examples
+ { $example "USING: generalizations prettyprint math ;"
+ "3 [ + ] n*quot ."
+ "[ + + + ]"
+ }
+}
+{ $description "Construct a quotation containing the contents of " { $snippet "seq" } " repeated " { $snippet "n"} " times." } ;
+
+HELP: nappend
+{ $values
+ { "n" integer }
+ { "seq" sequence }
+}
+{ $description "Outputs a new sequence consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }
+{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }
+{ $examples
+ { $example "USING: generalizations prettyprint math ;"
+ "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 nappend ."
+ "{ 1 2 3 4 5 6 7 8 }"
+ }
+} ;
+
+HELP: nappend-as
+{ $values
+ { "n" integer } { "exemplar" sequence }
+ { "seq" sequence }
+}
+{ $description "Outputs a new sequence of type " { $snippet "exemplar" } " consisting of the elements of the top " { $snippet "n" } " sequences from the datastack in turn." }
+{ $errors "Throws an error if any of the sequences contain elements that are not permitted in the sequence type of the first sequence." }
+{ $examples
+ { $example "USING: generalizations prettyprint math ;"
+ "{ 1 2 } { 3 4 } { 5 6 } { 7 8 } 4 V{ } nappend-as ."
+ "V{ 1 2 3 4 5 6 7 8 }"
+ }
+} ;
+
+{ nappend nappend-as } related-words
+
+HELP: ntuck
+{ $values
+ { "n" integer }
+}
+{ $description "A generalization of " { $link tuck } " that can work for any stack depth. The top item will be copied and placed " { $snippet "n" } " items down on the stack." } ;
+
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
"macros where the arity of the input quotations depends on an "
@@ -267,6 +317,8 @@ $nl
{ $subsection narray }
{ $subsection nsequence }
{ $subsection firstn }
+{ $subsection nappend }
+{ $subsection nappend-as }
"Generated stack shuffle operations:"
{ $subsection ndup }
{ $subsection npick }
@@ -274,6 +326,7 @@ $nl
{ $subsection -nrot }
{ $subsection nnip }
{ $subsection ndrop }
+{ $subsection ntuck }
{ $subsection nrev }
{ $subsection mnswap }
"Generalized combinators:"
diff --git a/basis/generalizations/generalizations-tests.factor b/basis/generalizations/generalizations-tests.factor
index 1291012700..35e02f08b4 100644
--- a/basis/generalizations/generalizations-tests.factor
+++ b/basis/generalizations/generalizations-tests.factor
@@ -1,10 +1,11 @@
-USING: tools.test generalizations kernel math arrays sequences ;
+USING: tools.test generalizations kernel math arrays sequences ascii ;
IN: generalizations.tests
{ 1 2 3 4 1 } [ 1 2 3 4 4 npick ] unit-test
{ 1 2 3 4 2 } [ 1 2 3 4 3 npick ] unit-test
{ 1 2 3 4 3 } [ 1 2 3 4 2 npick ] unit-test
{ 1 2 3 4 4 } [ 1 2 3 4 1 npick ] unit-test
+
[ 1 1 ndup ] must-infer
{ 1 1 } [ 1 1 ndup ] unit-test
{ 1 2 1 2 } [ 1 2 2 ndup ] unit-test
@@ -22,12 +23,16 @@ IN: generalizations.tests
{ 4 } [ 1 2 3 4 3 nnip ] unit-test
[ 1 2 3 4 4 ndrop ] must-infer
{ 0 } [ 0 1 2 3 4 4 ndrop ] unit-test
+[ [ 1 ] 5 ndip ] must-infer
+[ 1 2 3 4 ] [ 2 3 4 [ 1 ] 3 ndip ] unit-test
[ [ 99 ] 1 2 3 4 5 5 nslip ] must-infer
{ 99 1 2 3 4 5 } [ [ 99 ] 1 2 3 4 5 5 nslip ] unit-test
[ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] must-infer
{ 2 1 2 3 4 5 } [ 1 2 3 4 5 [ drop drop drop drop drop 2 ] 5 nkeep ] unit-test
[ [ 1 2 3 + ] ] [ 1 2 3 [ + ] 3 ncurry ] unit-test
+
+[ "HELLO" ] [ "hello" [ >upper ] 1 napply ] unit-test
[ { 1 2 } { 2 4 } { 3 8 } { 4 16 } { 5 32 } ] [ 1 2 3 4 5 [ dup 2^ 2array ] 5 napply ] unit-test
[ [ dup 2^ 2array ] 5 napply ] must-infer
@@ -42,3 +47,9 @@ IN: generalizations.tests
[ 4 5 1 2 3 ] [ 1 2 3 4 5 2 3 mnswap ] unit-test
[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 2 4 mnswap 4 2 mnswap ] unit-test
+
+[ { 1 2 3 4 } ] [ { 1 } { 2 } { 3 } { 4 } 4 nappend ] unit-test
+[ V{ 1 2 3 4 } ] [ { 1 } { 2 } { 3 } { 4 } 4 V{ } nappend-as ] unit-test
+
+[ 4 nappend ] must-infer
+[ 4 { } nappend-as ] must-infer
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index ae7437b346..c6a17df099 100644
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -2,7 +2,7 @@
! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private math math.ranges
-combinators macros quotations fry ;
+combinators macros quotations fry macros locals ;
IN: generalizations
<<
@@ -73,10 +73,13 @@ MACRO: ncleave ( quots n -- )
[ '[ _ '[ _ _ nkeep ] ] map [ ] join ] [ '[ _ ndrop ] ] bi
compose ;
-MACRO: napply ( n -- )
- 2 [a,b]
- [ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
- map concat >quotation [ call ] append ;
+MACRO: napply ( quot n -- )
+ swap spread>quot ;
MACRO: mnswap ( m n -- )
1+ '[ _ -nrot ] spread>quot ;
+
+: nappend-as ( n exemplar -- seq )
+ [ narray concat ] dip like ; inline
+
+: nappend ( n -- seq ) narray concat ; inline
diff --git a/basis/grouping/grouping-docs.factor b/basis/grouping/grouping-docs.factor
index 3b3a98eabd..e4ad97abd0 100644
--- a/basis/grouping/grouping-docs.factor
+++ b/basis/grouping/grouping-docs.factor
@@ -20,17 +20,21 @@ ARTICLE: "grouping" "Groups and clumps"
{ $unchecked-example "dup n groups concat sequence= ." "t" }
}
{ "With clumps, collecting the first element of each subsequence but the last one, together with the last subseqence, yields the original sequence:"
- { $unchecked-example "dup n clumps unclip-last >r [ first ] map r> append sequence= ." "t" }
+ { $unchecked-example "dup n clumps unclip-last [ [ first ] map ] dip append sequence= ." "t" }
}
-} ;
+}
+"A combinator built using clumps:"
+{ $subsection monotonic? }
+"Testing how elements are related:"
+{ $subsection all-eq? }
+{ $subsection all-equal? } ;
ABOUT: "grouping"
HELP: groups
{ $class-description "Instances are virtual sequences whose elements are disjoint fixed-length subsequences of an underlying sequence. Groups are mutable and resizable if the underlying sequence is mutable and resizable, respectively."
$nl
-"New groups are created by calling " { $link } " and " { $link } "." }
-{ $see-also group } ;
+"New groups are created by calling " { $link } " and " { $link } "." } ;
HELP: group
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "array" "a sequence of sequences" } }
@@ -48,11 +52,16 @@ HELP:
"USING: arrays kernel prettyprint sequences grouping ;"
"9 >array 3 dup reverse-here concat >array ." "{ 6 7 8 3 4 5 0 1 2 }"
}
+ { $example
+ "USING: kernel prettyprint sequences grouping ;"
+ "{ 1 2 3 4 5 6 } 3 first ."
+ "{ 1 2 3 }"
+ }
} ;
HELP:
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "groups" groups } }
-{ $description "Outputs a virtual sequence whose elements are overlapping subsequences of " { $snippet "n" } " elements from the underlying sequence." }
+{ $description "Outputs a virtual sequence whose elements are slices of disjoint subsequences of " { $snippet "n" } " elements from the underlying sequence." }
{ $examples
{ $example
"USING: arrays kernel prettyprint sequences grouping ;"
@@ -60,6 +69,11 @@ HELP:
"dup [ reverse-here ] each concat >array ."
"{ 2 1 0 5 4 3 8 7 6 }"
}
+ { $example
+ "USING: kernel prettyprint sequences grouping ;"
+ "{ 1 2 3 4 5 6 } 3 second ."
+ "T{ slice { from 3 } { to 6 } { seq { 1 2 3 4 5 6 } } }"
+ }
} ;
HELP: clumps
@@ -89,11 +103,23 @@ HELP:
"share-price 4 [ [ sum ] [ length ] bi / ] map ."
"{ 113/400 167/400 201/400 241/400 243/400 91/200 1/4 }"
}
+ { $example
+ "USING: kernel sequences grouping prettyprint ;"
+ "{ 1 2 3 4 5 6 } 3 second ."
+ "{ 2 3 4 }"
+ }
} ;
HELP:
{ $values { "seq" "a sequence" } { "n" "a non-negative integer" } { "clumps" clumps } }
-{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." } ;
+{ $description "Outputs a virtual sequence whose elements are overlapping slices of " { $snippet "n" } " elements from the underlying sequence." }
+{ $examples
+ { $example
+ "USING: kernel sequences grouping prettyprint ;"
+ "{ 1 2 3 4 5 6 } 3 second ."
+ "T{ slice { from 1 } { to 4 } { seq { 1 2 3 4 5 6 } } }"
+ }
+} ;
{ clumps groups } related-words
@@ -102,3 +128,23 @@ HELP:
{ } related-words
{ } related-words
+
+HELP: monotonic?
+{ $values { "seq" sequence } { "quot" { $quotation "( elt elt -- ? )" } } { "?" "a boolean" } }
+{ $description "Applies the relation to successive pairs of elements in the sequence, testing for a truth value. The relation should be a transitive relation, such as a total order or an equality relation." }
+{ $examples
+ "Testing if a sequence is non-decreasing:"
+ { $example "USING: grouping math prettyprint ;" "{ 1 1 2 } [ <= ] monotonic? ." "t" }
+ "Testing if a sequence is decreasing:"
+ { $example "USING: grouping math prettyprint ;" "{ 9 8 6 7 } [ < ] monotonic? ." "f" }
+} ;
+
+HELP: all-equal?
+{ $values { "seq" sequence } { "?" "a boolean" } }
+{ $description "Tests if all elements in the sequence are equal. Yields true with an empty sequence." } ;
+
+HELP: all-eq?
+{ $values { "seq" sequence } { "?" "a boolean" } }
+{ $description "Tests if all elements in the sequence are the same identical object. Yields true with an empty sequence." } ;
+
+{ monotonic? all-eq? all-equal? } related-words
diff --git a/basis/grouping/grouping-tests.factor b/basis/grouping/grouping-tests.factor
index cfcc653776..c91e5a56d6 100644
--- a/basis/grouping/grouping-tests.factor
+++ b/basis/grouping/grouping-tests.factor
@@ -1,4 +1,5 @@
-USING: grouping tools.test kernel sequences arrays ;
+USING: grouping tools.test kernel sequences arrays
+math ;
IN: grouping.tests
[ { 1 2 3 } 0 group ] must-fail
@@ -12,3 +13,11 @@ IN: grouping.tests
] unit-test
[ { { 1 2 } { 2 3 } } ] [ { 1 2 3 } 2 [ >array ] map ] unit-test
+
+[ f ] [ [ { } { } "Hello" ] all-equal? ] unit-test
+[ f ] [ [ { 2 } { } { } ] all-equal? ] unit-test
+[ t ] [ [ ] all-equal? ] unit-test
+[ t ] [ [ 1234 ] all-equal? ] unit-test
+[ f ] [ [ 1.0 1 1 ] all-equal? ] unit-test
+[ t ] [ { 1 2 3 4 } [ < ] monotonic? ] unit-test
+[ f ] [ { 1 2 3 4 } [ > ] monotonic? ] unit-test
diff --git a/basis/grouping/grouping.factor b/basis/grouping/grouping.factor
index 0fa20b41fc..ec13e3a750 100644
--- a/basis/grouping/grouping.factor
+++ b/basis/grouping/grouping.factor
@@ -1,14 +1,15 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math math.order strings arrays vectors sequences
-sequences.private accessors ;
+sequences.private accessors fry ;
IN: grouping
{ } like ;
: clump ( seq n -- array ) { } like ;
+
+: monotonic? ( seq quot -- ? )
+ over length 2 < [ 2drop t ] [
+ over length 2 = [
+ [ first2-unsafe ] dip call
+ ] [
+ [ 2 ] dip
+ '[ first2-unsafe @ ] all?
+ ] if
+ ] if ; inline
+
+: all-equal? ( seq -- ? ) [ = ] monotonic? ;
+
+: all-eq? ( seq -- ? ) [ eq? ] monotonic? ;
\ No newline at end of file
diff --git a/basis/heaps/heaps-tests.factor b/basis/heaps/heaps-tests.factor
index e28eb3007a..7e780cbe5e 100644
--- a/basis/heaps/heaps-tests.factor
+++ b/basis/heaps/heaps-tests.factor
@@ -32,10 +32,8 @@ IN: heaps.tests
: random-alist ( n -- alist )
[
- [
- 32 random-bits dup number>string swap set
- ] times
- ] H{ } make-assoc ;
+ drop 32 random-bits dup number>string
+ ] H{ } map>assoc ;
: test-heap-sort ( n -- ? )
random-alist dup >alist sort-keys swap heap-sort = ;
@@ -61,7 +59,7 @@ IN: heaps.tests
random-alist
[ heap-push-all ] keep
dup data>> clone swap
- ] keep 3 /i [ 2dup >r delete-random r> heap-delete ] times
+ ] keep 3 /i [ 2dup [ delete-random ] dip heap-delete ] times
data>>
[ [ key>> ] map ] bi@
[ natural-sort ] bi@ ;
diff --git a/basis/heaps/heaps.factor b/basis/heaps/heaps.factor
index ba95a9f249..aa1ebf7786 100644
--- a/basis/heaps/heaps.factor
+++ b/basis/heaps/heaps.factor
@@ -87,7 +87,8 @@ M: heap heap-size ( heap -- n )
GENERIC: heap-compare ( pair1 pair2 heap -- ? )
-: (heap-compare) drop [ key>> ] compare ; inline
+: (heap-compare) ( pair1 pair2 heap -- <=> )
+ drop [ key>> ] compare ; inline
M: min-heap heap-compare (heap-compare) +gt+ eq? ;
diff --git a/basis/help/cookbook/cookbook.factor b/basis/help/cookbook/cookbook.factor
index e72fbb439c..ebc711d527 100644
--- a/basis/help/cookbook/cookbook.factor
+++ b/basis/help/cookbook/cookbook.factor
@@ -100,14 +100,12 @@ $nl
{ $code "10 [ \"Factor rocks!\" print ] times" }
"Now we can look at a new data type, the array:"
{ $code "{ 1 2 3 }" }
-"An array looks like a quotation except it cannot be evaluated; it simply stores data."
+"An array differs from a quotation in that it cannot be evaluated; it simply stores data."
$nl
"You can perform an operation on each element of an array:"
{ $example
"{ 1 2 3 } [ \"The number is \" write . ] each"
- "The number is 1"
- "The number is 2"
- "The number is 3"
+ "The number is 1\nThe number is 2\nThe number is 3"
}
"You can transform each element, collecting the results in a new array:"
{ $example "{ 5 12 0 -12 -5 } [ sq ] map ." "{ 25 144 0 144 25 }" }
@@ -269,8 +267,8 @@ $nl
{ $heading "Example: ls" }
"Here is an example implementing a simplified version of the Unix " { $snippet "ls" } " command in Factor:"
{ $code
- <" USING: command-line namespaces io io.files tools.files
-sequences kernel ;
+ <" USING: command-line namespaces io io.files
+io.pathnames tools.files sequences kernel ;
command-line get [
current-directory get directory.
@@ -360,7 +358,7 @@ ARTICLE: "cookbook-pitfalls" "Pitfalls to avoid"
{ $list
"Factor only makes use of one native thread, and Factor threads are scheduled co-operatively. C library calls block the entire VM."
"Factor does not hide anything from the programmer, all internals are exposed. It is your responsibility to avoid writing fragile code which depends too much on implementation detail."
- { "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The parser prints warnings when vocabularies shadow words from other vocabularies; see " { $link "vocabulary-search-shadow" } ". The " { $vocab-link "qualified" } " vocabulary implements qualified naming, which can be used to resolve ambiguities." }
+ { "When a source file uses two vocabularies which define words with the same name, the order of the vocabularies in the " { $link POSTPONE: USE: } " or " { $link POSTPONE: USING: } " forms is important. The " { $link POSTPONE: QUALIFIED: } " word implements qualified naming, which can be used to resolve ambiguities." }
{ "If a literal object appears in a word definition, the object itself is pushed on the stack when the word executes, not a copy. If you intend to mutate this object, you must " { $link clone } " it first. See " { $link "syntax-literals" } "." }
{ "For a discussion of potential issues surrounding the " { $link f } " object, see " { $link "booleans" } "." }
{ "Factor's object system is quite flexible. Careless usage of union, mixin and predicate classes can lead to similar problems to those caused by ``multiple inheritance'' in other languages. In particular, it is possible to have two classes such that they have a non-empty intersection and yet neither is a subclass of the other. If a generic word defines methods on two such classes, various disambiguation rules are applied to ensure method dispatch remains deterministic, however they may not be what you expect. See " { $link "method-order" } " for details." }
diff --git a/basis/help/handbook/handbook.factor b/basis/help/handbook/handbook.factor
index cc36e9faab..39b5a13e30 100644
--- a/basis/help/handbook/handbook.factor
+++ b/basis/help/handbook/handbook.factor
@@ -162,12 +162,18 @@ ARTICLE: "encodings-introduction" "An introduction to encodings"
{ $code "\"file.txt\" utf16 file-contents" }
"Encoding descriptors are also used by " { $link "io.streams.byte-array" } " and taken by combinators like " { $link with-file-writer } " and " { $link with-byte-reader } " which deal with streams. It is " { $emphasis "not" } " used with " { $link "io.streams.string" } " because these deal with abstract text."
$nl
-"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text." ;
+"When the " { $link binary } " encoding is used, a " { $link byte-array } " is expected for writing and returned for reading, since the stream deals with bytes. All other encodings deal with strings, since they are used to represent text."
+{ $see-also "stream-elements" } ;
ARTICLE: "io" "Input and output"
{ $heading "Streams" }
{ $subsection "streams" }
{ $subsection "io.files" }
+{ $heading "The file system" }
+{ $subsection "io.pathnames" }
+{ $subsection "io.files.info" }
+{ $subsection "io.files.links" }
+{ $subsection "io.directories" }
{ $heading "Encodings" }
{ $subsection "encodings-introduction" }
{ $subsection "io.encodings" }
@@ -178,7 +184,7 @@ ARTICLE: "io" "Input and output"
{ $subsection "io.streams.byte-array" }
{ $heading "Utilities" }
{ $subsection "stream-binary" }
-{ $subsection "styles" }
+{ $subsection "io.styles" }
{ $subsection "checksums" }
{ $heading "Implementation" }
{ $subsection "io.streams.c" }
@@ -204,7 +210,8 @@ ARTICLE: "tools" "Developer tools"
{ $subsection "timing" }
{ $subsection "tools.disassembler" }
"Deployment tools:"
-{ $subsection "tools.deploy" } ;
+{ $subsection "tools.deploy" }
+{ $see-also "ui-tools" } ;
ARTICLE: "article-index" "Article index"
{ $index [ articles get keys ] } ;
diff --git a/basis/help/help-docs.factor b/basis/help/help-docs.factor
index 4a06235c69..6b77f656c0 100644
--- a/basis/help/help-docs.factor
+++ b/basis/help/help-docs.factor
@@ -36,6 +36,7 @@ ARTICLE: "block-elements" "Block elements"
"Elements used in " { $link $values } " forms:"
{ $subsection $instance }
{ $subsection $maybe }
+{ $subsection $or }
{ $subsection $quotation }
"Boilerplate paragraphs:"
{ $subsection $low-level-note }
@@ -88,6 +89,12 @@ $nl
{ "an array of markup elements," }
{ "or an array of the form " { $snippet "{ $directive content... }" } ", where " { $snippet "$directive" } " is a markup word whose name starts with " { $snippet "$" } ", and " { $snippet "content..." } " is a series of markup elements" }
}
+"Here is a more formal schema for the help markup language:"
+{ $code
+" ::== | | "
+" ::== { * }"
+" ::== { }"
+}
{ $subsection "element-types" }
{ $subsection "printing-elements" }
"Related words can be cross-referenced:"
@@ -119,7 +126,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" }
-{ $vocab-subsection "Help lint tool" "help.lint" }
+{ $subsection "help.lint" }
{ $subsection "help-impl" } ;
IN: help
@@ -327,7 +334,7 @@ HELP: $table
HELP: $values
{ $values { "element" "an array of pairs of markup elements" } }
-{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is intereted as if it were shorthand for " { $snippet "{ $instance class }" } "." }
+{ $description "Prints the description of arguments and values found on every word help page. The first element of a pair is the argument name and is output with " { $link $snippet } ". The remainder is either a single class word, or an element. If it is a class word " { $snippet "class" } ", it is inserted as if it were shorthand for " { $snippet "{ $instance class }" } "." }
{ $see-also $maybe $instance $quotation } ;
HELP: $instance
diff --git a/basis/help/help-tests.factor b/basis/help/help-tests.factor
index e38f2fc15d..e091278359 100644
--- a/basis/help/help-tests.factor
+++ b/basis/help/help-tests.factor
@@ -3,3 +3,4 @@ USING: tools.test help kernel ;
[ 3 throw ] must-fail
[ ] [ :help ] unit-test
+[ ] [ f print-topic ] unit-test
\ No newline at end of file
diff --git a/basis/help/help.factor b/basis/help/help.factor
index 5d12438e0d..272bdc1db3 100644
--- a/basis/help/help.factor
+++ b/basis/help/help.factor
@@ -1,10 +1,11 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io io.styles kernel namespaces make
-parser prettyprint sequences words assocs definitions generic
-quotations effects slots continuations classes.tuple debugger
-combinators vocabs help.stylesheet help.topics help.crossref
-help.markup sorting classes vocabs.loader ;
+parser prettyprint sequences words words.symbol assocs
+definitions generic quotations effects slots continuations
+classes.tuple debugger combinators vocabs help.stylesheet
+help.topics help.crossref help.markup sorting classes
+vocabs.loader ;
IN: help
GENERIC: word-help* ( word -- content )
@@ -111,6 +112,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
] with-style nl ;
: print-topic ( topic -- )
+ >link
last-element off dup $title
article-content print-content nl ;
diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor
index a9df0bea81..ec52264643 100644
--- a/basis/help/html/html.factor
+++ b/basis/help/html/html.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
-io.files html.streams html.elements help kernel
+io.files io.files.temp io.directories html.streams html.elements help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs tools.vocabs.browser namespaces prettyprint io
vocabs.loader serialize fry memoize unicode.case math.order
diff --git a/basis/help/lint/lint.factor b/basis/help/lint/lint.factor
index fbebc7f0f6..30d5ef49df 100644
--- a/basis/help/lint/lint.factor
+++ b/basis/help/lint/lint.factor
@@ -1,25 +1,29 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors sequences parser kernel help help.markup
help.topics words strings classes tools.vocabs namespaces make
io io.streams.string prettyprint definitions arrays vectors
combinators combinators.short-circuit splitting debugger
hashtables sorting effects vocabs vocabs.loader assocs editors
-continuations classes.predicate macros math sets eval ;
+continuations classes.predicate macros math sets eval
+vocabs.parser words.symbol values grouping unicode.categories
+sequences.deep ;
IN: help.lint
+SYMBOL: vocabs-quot
+
: check-example ( element -- )
- rest [
- but-last "\n" join 1vector
- [
- use [ clone ] change
- [ eval>string ] with-datastack
- ] with-scope peek "\n" ?tail drop
- ] keep
- peek assert= ;
+ [
+ rest [
+ but-last "\n" join 1vector
+ [ (eval>string) ] with-datastack
+ peek "\n" ?tail drop
+ ] keep
+ peek assert=
+ ] vocabs-quot get call ;
-: check-examples ( word element -- )
- nip \ $example swap elements [ check-example ] each ;
+: check-examples ( element -- )
+ \ $example swap elements [ check-example ] each ;
: extract-values ( element -- seq )
\ $values swap elements dup empty? [
@@ -41,25 +45,40 @@ IN: help.lint
$error-description
} swap '[ _ elements empty? not ] contains? ;
+: don't-check-word? ( word -- ? )
+ {
+ [ macro? ]
+ [ symbol? ]
+ [ value-word? ]
+ [ parsing-word? ]
+ [ "declared-effect" word-prop not ]
+ } 1|| ;
+
: check-values ( word element -- )
{
- [ drop "declared-effect" word-prop not ]
- [ nip contains-funky-elements? ]
- [ drop macro? ]
[
- [ effect-values >array ]
- [ extract-values >array ]
- bi* =
+ [ don't-check-word? ]
+ [ contains-funky-elements? ]
+ bi* or
+ ] [
+ [ effect-values ]
+ [ extract-values ]
+ bi* sequence=
]
} 2|| [ "$values don't match stack effect" throw ] unless ;
-: check-see-also ( word element -- )
- nip \ $see-also swap elements [
+: check-nulls ( element -- )
+ \ $values swap elements
+ null swap deep-member?
+ [ "$values should not contain null" throw ] when ;
+
+: check-see-also ( element -- )
+ \ $see-also swap elements [
rest dup prune [ length ] bi@ assert=
] each ;
: vocab-exists? ( name -- ? )
- dup vocab swap "all-vocabs" get member? or ;
+ [ vocab ] [ "all-vocabs" get member? ] bi or ;
: check-modules ( element -- )
\ $vocab-link swap elements [
@@ -68,43 +87,78 @@ IN: help.lint
] each ;
: check-rendering ( element -- )
- [ print-topic ] with-string-writer drop ;
+ [ print-content ] with-string-writer drop ;
+
+: check-strings ( str -- )
+ [
+ "\n\t" intersects?
+ [ "Paragraph text should not contain \\n or \\t" throw ] when
+ ] [
+ " " swap subseq?
+ [ "Paragraph text should not contain double spaces" throw ] when
+ ] bi ;
+
+: check-whitespace ( str1 str2 -- )
+ [ " " tail? ] [ " " head? ] bi* or
+ [ "Missing whitespace between strings" throw ] unless ;
+
+: check-bogus-nl ( element -- )
+ { { $nl } { { $nl } } } [ head? ] with contains?
+ [ "Simple element should not begin with a paragraph break" throw ] when ;
+
+: check-elements ( element -- )
+ {
+ [ check-bogus-nl ]
+ [ [ string? ] filter [ check-strings ] each ]
+ [ [ simple-element? ] filter [ check-elements ] each ]
+ [ 2 [ [ string? ] all? ] filter [ first2 check-whitespace ] each ]
+ } cleave ;
+
+: check-markup ( element -- )
+ {
+ [ check-elements ]
+ [ check-rendering ]
+ [ check-examples ]
+ [ check-modules ]
+ } cleave ;
: all-word-help ( words -- seq )
[ word-help ] filter ;
-TUPLE: help-error topic error ;
+TUPLE: help-error error topic ;
C: help-error
M: help-error error.
- "In " write dup topic>> pprint nl
- error>> error. ;
+ [ "In " write topic>> pprint nl ]
+ [ error>> error. ]
+ bi ;
: check-something ( obj quot -- )
- flush [ , ] recover ; inline
+ flush '[ _ assert-depth ] swap '[ _ , ] recover ; inline
: check-word ( word -- )
+ [ with-file-vocabs ] vocabs-quot set
dup word-help [
- [
- dup word-help '[
- _ _ {
- [ check-examples ]
- [ check-values ]
- [ check-see-also ]
- [ [ check-rendering ] [ check-modules ] bi* ]
- } 2cleave
- ] assert-depth
+ dup '[
+ _ dup word-help
+ [ check-values ]
+ [ nip [ check-nulls ] [ check-see-also ] [ check-markup ] tri ] 2bi
] check-something
] [ drop ] if ;
: check-words ( words -- ) [ check-word ] each ;
+: check-article-title ( article -- )
+ article-title first LETTER?
+ [ "Article title must begin with a capital letter" throw ] unless ;
+
: check-article ( article -- )
- [
- dup article-content
- '[ _ check-rendering _ check-modules ]
- assert-depth
+ [ with-interactive-vocabs ] vocabs-quot set
+ dup '[
+ _
+ [ check-article-title ]
+ [ article-content check-markup ] bi
] check-something ;
: files>vocabs ( -- assoc )
@@ -124,7 +178,7 @@ M: help-error error.
] keep ;
: check-about ( vocab -- )
- [ vocab-help [ article drop ] when* ] check-something ;
+ dup '[ _ vocab-help [ article drop ] when* ] check-something ;
: check-vocab ( vocab -- seq )
"Checking " write dup write "..." print
diff --git a/basis/help/markup/markup-tests.factor b/basis/help/markup/markup-tests.factor
index b9ec34a831..0d8aa53d44 100644
--- a/basis/help/markup/markup-tests.factor
+++ b/basis/help/markup/markup-tests.factor
@@ -1,5 +1,6 @@
USING: definitions help help.markup kernel sequences tools.test
-words parser namespaces assocs generic io.streams.string accessors ;
+words parser namespaces assocs generic io.streams.string accessors
+strings math ;
IN: help.markup.tests
TUPLE: blahblah quux ;
@@ -15,3 +16,12 @@ TUPLE: blahblah quux ;
[ ] [ \ fooey print-topic ] unit-test
[ ] [ gensym print-topic ] unit-test
+
+[ "a string" ]
+[ [ { $or string } print-element ] with-string-writer ] unit-test
+
+[ "a string or an integer" ]
+[ [ { $or string integer } print-element ] with-string-writer ] unit-test
+
+[ "a string, a fixnum, or an integer" ]
+[ [ { $or string fixnum integer } print-element ] with-string-writer ] unit-test
diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor
index a7501dc242..2fd8d55d10 100644
--- a/basis/help/markup/markup.factor
+++ b/basis/help/markup/markup.factor
@@ -1,20 +1,12 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays definitions generic io kernel assocs
hashtables namespaces make parser prettyprint sequences strings
io.styles vectors words math sorting splitting classes slots
-vocabs help.stylesheet help.topics vocabs.loader alias
-quotations ;
+vocabs help.stylesheet help.topics vocabs.loader quotations
+combinators ;
IN: help.markup
-! Simple markup language.
-
-! ::== | |
-! ::== { * }
-! ::== { }
-
-! Element types are words whose name begins with $.
-
PREDICATE: simple-element < array
[ t ] [ first word? not ] if-empty ;
@@ -251,8 +243,21 @@ M: f ($instance)
: $instance ( element -- ) first ($instance) ;
+: $or ( element -- )
+ dup length {
+ { 1 [ first ($instance) ] }
+ { 2 [ first2 [ ($instance) " or " print-element ] [ ($instance) ] bi* ] }
+ [
+ drop
+ unclip-last
+ [ [ ($instance) ", " print-element ] each ]
+ [ "or " print-element ($instance) ]
+ bi*
+ ]
+ } case ;
+
: $maybe ( element -- )
- $instance " or " print-element { f } $instance ;
+ f suffix $or ;
: $quotation ( element -- )
{ "a " { $link quotation } " with stack effect " } print-element
diff --git a/basis/help/syntax/syntax.factor b/basis/help/syntax/syntax.factor
index 9a372174ba..9f98ba6d8d 100644
--- a/basis/help/syntax/syntax.factor
+++ b/basis/help/syntax/syntax.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays kernel parser sequences words help
-help.topics namespaces vocabs definitions compiler.units ;
+help.topics namespaces vocabs definitions compiler.units
+vocabs.parser ;
IN: help.syntax
: HELP:
diff --git a/basis/help/tutorial/tutorial.factor b/basis/help/tutorial/tutorial.factor
index 9ed36ac77c..efb1e0a0f7 100644
--- a/basis/help/tutorial/tutorial.factor
+++ b/basis/help/tutorial/tutorial.factor
@@ -30,7 +30,7 @@ ARTICLE: "first-program-logic" "Writing some logic in your first program"
"! See http://factorcode.org/license.txt for BSD license."
"IN: palindrome"
}
-"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
+"We will now write our first word using " { $link POSTPONE: : } ". This word will test if a string is a palindrome; it will take a string as input, and give back a boolean as output. We will call this word " { $snippet "palindrome?" } ", following a naming convention that words returning booleans have names ending with " { $snippet "?" } "."
$nl
"Recall that a string is a palindrome if it is spelled the same forwards or backwards; that is, if the string is equal to its reverse. We can express this in Factor as follows:"
{ $code ": palindrome? ( string -- ? ) dup reverse = ;" }
@@ -94,7 +94,7 @@ $nl
"For example, we'd like it to identify the following as a palindrome:"
{ $code "\"A man, a plan, a canal: Panama.\"" }
"However, right now, the simplistic algorithm we use says this is not a palindrome:"
-{ $example "\"A man, a plan, a canal: Panama.\" palindrome?" "f" }
+{ $unchecked-example "\"A man, a plan, a canal: Panama.\" palindrome?" "f" }
"We would like it to output " { $link t } " there. We can encode this requirement with a unit test that we add to " { $snippet "palindrome-tests.factor" } ":"
{ $code "[ t ] [ \"A man, a plan, a canal: Panama.\" palindrome? ] unit-test" }
"If you now run unit tests, you will see a unit test failure:"
@@ -106,12 +106,12 @@ $nl
"Start by pushing a character on the stack; notice that characters are really just integers:"
{ $code "CHAR: a" }
"Now, use the " { $link Letter? } " word to test if it is an alphabetical character, upper or lower case:"
-{ $example "Letter? ." "t" }
+{ $unchecked-example "Letter? ." "t" }
"This gives the expected result."
$nl
"Now try with a non-alphabetical character:"
{ $code "CHAR: #" }
-{ $example "Letter? ." "f" }
+{ $unchecked-example "Letter? ." "f" }
"What we want to do is given a string, remove all characters which do not match the " { $link Letter? } " predicate. Let's push a string on the stack:"
{ $code "\"A man, a plan, a canal: Panama.\"" }
"Now, place a quotation containing " { $link Letter? } " on the stack; quoting code places it on the stack instead of executing it immediately:"
diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index 240acf74b1..b6af773ce5 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -3,7 +3,8 @@
USING: parser words definitions kernel sequences assocs arrays
kernel.private fry combinators accessors vectors strings sbufs
byte-arrays byte-vectors io.binary io.streams.string splitting
-math generic generic.standard generic.standard.engines classes ;
+math generic generic.standard generic.standard.engines classes
+hashtables ;
IN: hints
GENERIC: specializer-predicate ( spec -- quot )
@@ -50,14 +51,10 @@ M: object specializer-declaration class ;
] [ drop f ] if ;
: specialized-def ( word -- quot )
- dup def>> swap {
- {
- [ dup "specializer" word-prop ]
- [ "specializer" word-prop specialize-quot ]
- }
- { [ dup standard-method? ] [ specialize-method ] }
- [ drop ]
- } cond ;
+ [ def>> ] keep
+ [ dup standard-method? [ specialize-method ] [ drop ] if ]
+ [ "specializer" word-prop [ specialize-quot ] when* ]
+ bi ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;
@@ -120,3 +117,7 @@ M: object specializer-declaration class ;
\ >le { { fixnum fixnum } { bignum fixnum } } "specializer" set-word-prop
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
+
+\ hashtable \ at* method { { fixnum hashtable } { word hashtable } } "specializer" set-word-prop
+
+\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop
diff --git a/basis/html/components/components-docs.factor b/basis/html/components/components-docs.factor
index d131cc3e03..39c17a4708 100644
--- a/basis/html/components/components-docs.factor
+++ b/basis/html/components/components-docs.factor
@@ -70,8 +70,8 @@ HELP: render
{ $description "Renders an HTML component to the " { $link output-stream } "." } ;
HELP: render*
-{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } }
-{ $contract "Renders an HTML component to the " { $link output-stream } "." } ;
+{ $values { "value" "a value" } { "name" "a value name" } { "renderer" "a component renderer" } { "xml" "an XML chunk" } }
+{ $contract "Renders an HTML component, outputting an XHTML snippet." } ;
ARTICLE: "html.components" "HTML components"
"The " { $vocab-link "html.components" } " vocabulary provides various HTML form components."
diff --git a/basis/html/components/components-tests.factor b/basis/html/components/components-tests.factor
index b4247e6e30..09bb5860ad 100644
--- a/basis/html/components/components-tests.factor
+++ b/basis/html/components/components-tests.factor
@@ -31,7 +31,7 @@ TUPLE: color red green blue ;
] with-string-writer
] unit-test
-[ "" ] [
+[ "\" name=\"red\" type=\"hidden\"/>" ] [
[
"red" hidden render
] with-string-writer
@@ -39,13 +39,13 @@ TUPLE: color red green blue ;
[ ] [ "'jimmy'" "red" set-value ] unit-test
-[ "" ] [
+[ "" ] [
[
"red" 5 >>size render
] with-string-writer
] unit-test
-[ "" ] [
+[ "" ] [
[
"red" 5 >>size render
] with-string-writer
@@ -105,7 +105,7 @@ TUPLE: color red green blue ;
[ ] [ t "delivery" set-value ] unit-test
-[ "Delivery" ] [
+[ "Delivery" ] [
[
"delivery"
@@ -116,7 +116,7 @@ TUPLE: color red green blue ;
[ ] [ f "delivery" set-value ] unit-test
-[ "Delivery" ] [
+[ "Delivery" ] [
[
"delivery"
@@ -133,7 +133,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ link-test "link" set-value ] unit-test
-[ "<Link Title>" ] [
+[ "<Link Title>" ] [
[ "link" link new render ] with-string-writer
] unit-test
@@ -149,7 +149,7 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ ] [ "java" "mode" set-value ] unit-test
-[ "int x = 4;\n" ] [
+[ "int x = 4;" ] [
[ "code" "mode" >>mode render ] with-string-writer
] unit-test
@@ -163,6 +163,8 @@ M: link-test link-href drop "http://www.apple.com/foo&bar" ;
[ t ] [
[ "object" inspector render ] with-string-writer
+ USING: splitting sequences ;
+ "\"" split "'" join ! replace " with ' for now
[ "object" value [ describe ] with-html-writer ] with-string-writer
=
] unit-test
diff --git a/basis/html/components/components.factor b/basis/html/components/components.factor
index 6f35ba5d97..462c9b3c78 100644
--- a/basis/html/components/components.factor
+++ b/basis/html/components/components.factor
@@ -3,13 +3,13 @@
USING: accessors kernel namespaces io math.parser assocs classes
classes.tuple words arrays sequences splitting mirrors
hashtables combinators continuations math strings inspector
-fry locals calendar calendar.format xml.entities
-validators urls present
-xmode.code2html lcs.diff2html farkup
+fry locals calendar calendar.format xml.entities xml.data
+validators urls present xml.writer xml.interpolate xml
+xmode.code2html lcs.diff2html farkup io.streams.string
html.elements html.streams html.forms ;
IN: html.components
-GENERIC: render* ( value name renderer -- )
+GENERIC: render* ( value name renderer -- xml )
: render ( name renderer -- )
prepare-value
@@ -19,38 +19,36 @@ GENERIC: render* ( value name renderer -- )
[ f swap ]
if
] 2dip
- render*
+ render* write-xml
[ render-error ] when* ;
;
+: render-input ( value name type -- xml )
+ [XML name=<-> type=<->/> XML] ;
PRIVATE>
SINGLETON: label
-M: label render* 2drop present escape-string write ;
+M: label render*
+ 2drop present ;
SINGLETON: hidden
-M: hidden render* drop "hidden" render-input ;
+M: hidden render*
+ drop "hidden" render-input ;
-: render-field ( value name size type -- )
- ;
+: render-field ( value name size type -- xml )
+ [XML name=<-> size=<-> type=<->/> XML] ;
TUPLE: field size ;
: ( -- field )
field new ;
-M: field render* size>> "text" render-field ;
+M: field render*
+ size>> "text" render-field ;
TUPLE: password size ;
@@ -67,14 +65,15 @@ TUPLE: textarea rows cols ;
: