diff --git a/Factor.app/Contents/Frameworks/libfreetype.6.dylib b/Factor.app/Contents/Frameworks/libfreetype.6.dylib
deleted file mode 100755
index 381e74bf18..0000000000
Binary files a/Factor.app/Contents/Frameworks/libfreetype.6.dylib and /dev/null differ
diff --git a/Makefile b/Makefile
index bfaaa3eee4..5e63017218 100644
--- a/Makefile
+++ b/Makefile
@@ -11,6 +11,7 @@ IMAGE = factor.image
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall
+FFI_TEST_CFLAGS = -fPIC
ifdef DEBUG
CFLAGS += -g
@@ -140,9 +141,10 @@ wince-arm:
macosx.app: factor
mkdir -p $(BUNDLE)/Contents/MacOS
+ mkdir -p $(BUNDLE)/Contents/Frameworks
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
ln -s Factor.app/Contents/MacOS/factor ./factor
- cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
+ cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
install_name_tool \
-change libfactor.dylib \
@@ -159,16 +161,19 @@ factor-console: $(DLL_OBJS) $(EXE_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
-factor-ffi-test: $(TEST_OBJS)
- $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(DLL_EXTENSION) $(TEST_OBJS)
+factor-ffi-test: vm/ffi_test.o
+ $(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
clean:
rm -f vm/*.o
- rm -f factor*.dll libfactor.{a,so,dylib}
+ rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib}
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
+vm/ffi_test.o: vm/ffi_test.c
+ $(CC) -c $(CFLAGS) $(FFI_TEST_CFLAGS) -o $@ $<
+
.c.o:
$(CC) -c $(CFLAGS) -o $@ $<
diff --git a/basis/alien/libraries/libraries.factor b/basis/alien/libraries/libraries.factor
index adb9eeb1bb..3fcc15974c 100644
--- a/basis/alien/libraries/libraries.factor
+++ b/basis/alien/libraries/libraries.factor
@@ -18,5 +18,4 @@ TUPLE: library path abi dll ;
library dup [ dll>> ] when ;
: add-library ( name path abi -- )
- [ dup [ normalize-path ] when ] dip
<library> swap libraries get set-at ;
diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
index 9437051dad..8b33986fc2 100644
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
core-foundation.strings cocoa.messages cocoa cocoa.classes
-cocoa.runtime sequences threads init summary kernel.private
+cocoa.runtime sequences init summary kernel.private
assocs ;
IN: cocoa.application
diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor
index 7df80c6b6e..65e70bd042 100755
--- a/basis/compiler/codegen/codegen.factor
+++ b/basis/compiler/codegen/codegen.factor
@@ -53,7 +53,7 @@ SYMBOL: labels
V{ } clone literal-table set
V{ } clone calls set
compiling-word set
- compiled-stack-traces? compiling-word get f ? add-literal ;
+ compiled-stack-traces? [ compiling-word get add-literal ] when ;
: generate ( mr -- asm )
[
diff --git a/basis/compiler/tests/alien.factor b/basis/compiler/tests/alien.factor
old mode 100644
new mode 100755
index aa9346f788..4d7882ad08
--- a/basis/compiler/tests/alien.factor
+++ b/basis/compiler/tests/alien.factor
@@ -1,18 +1,20 @@
-IN: compiler.tests
USING: alien alien.c-types alien.syntax compiler kernel
namespaces namespaces tools.test sequences stack-checker
stack-checker.errors words arrays parser quotations
continuations effects namespaces.private io io.streams.string
memory system threads tools.test math accessors combinators
-specialized-arrays.float alien.libraries ;
+specialized-arrays.float alien.libraries io.pathnames
+io.backend ;
+IN: compiler.tests
<<
: libfactor-ffi-tests-path ( -- string )
+ "resource:" (normalize-path)
{
- { [ os winnt? ] [ "resource:libfactor-ffi-test.dll" ] }
- { [ os macosx? ] [ "resource:libfactor-ffi-test.dylib" ] }
- { [ os unix? ] [ "resource:libfactor-ffi-test.so" ] }
- } cond ;
+ { [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
+ { [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
+ { [ os unix? ] [ "libfactor-ffi-test.so" ] }
+ } cond append-path ;
"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
@@ -122,8 +124,6 @@ unit-test
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
gc ;
-LIBRARY: f-stdcall
-
[ f ] [ "f-stdcall" load-library f = ] unit-test
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
@@ -164,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
"int"
- "f-stdcall" "ffi_test_31"
+ "f-cdecl" "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke gc 3 ;
@@ -172,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
"float"
- "f-stdcall" "ffi_test_31_point_5"
+ "f-cdecl" "ffi_test_31_point_5"
{ "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
alien-invoke ;
diff --git a/basis/compiler/tree/propagation/known-words/known-words.factor b/basis/compiler/tree/propagation/known-words/known-words.factor
index ecfd415579..1b5d383353 100644
--- a/basis/compiler/tree/propagation/known-words/known-words.factor
+++ b/basis/compiler/tree/propagation/known-words/known-words.factor
@@ -312,7 +312,7 @@ generic-comparison-ops [
\ clone [
in-d>> first value-info literal>> {
{ V{ } [ [ drop { } 0 vector boa ] ] }
- { H{ } [ [ drop hashtable new ] ] }
+ { H{ } [ [ drop 0 <hashtable> ] ] }
[ drop f ]
} case
] "custom-inlining" set-word-prop
diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor
index 21f3d7efd4..413709d142 100644
--- a/basis/core-foundation/strings/strings.factor
+++ b/basis/core-foundation/strings/strings.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: alien.syntax alien.strings io.encodings.string kernel
sequences byte-arrays io.encodings.utf8 math core-foundation
-core-foundation.arrays destructors unicode.data ;
+core-foundation.arrays destructors ;
IN: core-foundation.strings
TYPEDEF: void* CFStringRef
@@ -62,7 +62,7 @@ FUNCTION: CFStringRef CFStringCreateWithCString (
: prepare-CFString ( string -- byte-array )
[
dup HEX: 10ffff >
- [ drop CHAR: replacement-character ] when
+ [ drop HEX: fffd ] when
] map utf8 encode ;
: <CFString> ( string -- alien )
diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor
index 8b6b4fbb11..85bf188bb8 100644
--- a/basis/cpu/ppc/ppc.factor
+++ b/basis/cpu/ppc/ppc.factor
@@ -659,13 +659,40 @@ M: ppc %callback-value ( ctype -- )
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
-M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
+M: ppc return-struct-in-registers? ( c-type -- ? )
+ c-type return-in-registers?>> ;
-M: ppc %box-small-struct
- drop "No small structs" throw ;
+M: ppc %box-small-struct ( c-type -- )
+ #! Box a <= 16-byte struct returned in r3:r4:r5:r6
+ heap-size 7 LI
+ "box_medium_struct" f %alien-invoke ;
-M: ppc %unbox-small-struct
- drop "No small structs" throw ;
+: %unbox-struct-1 ( -- )
+ ! Alien must be in r3.
+ "alien_offset" f %alien-invoke
+ 3 3 0 LWZ ;
+
+: %unbox-struct-2 ( -- )
+ ! Alien must be in r3.
+ "alien_offset" f %alien-invoke
+ 4 3 4 LWZ
+ 3 3 0 LWZ ;
+
+: %unbox-struct-4 ( -- )
+ ! Alien must be in r3.
+ "alien_offset" f %alien-invoke
+ 6 3 12 LWZ
+ 5 3 8 LWZ
+ 4 3 4 LWZ
+ 3 3 0 LWZ ;
+
+M: ppc %unbox-small-struct ( size -- )
+ #! Alien must be in EAX.
+ heap-size cell align cell /i {
+ { 1 [ %unbox-struct-1 ] }
+ { 2 [ %unbox-struct-2 ] }
+ { 4 [ %unbox-struct-4 ] }
+ } case ;
USE: vocabs.loader
@@ -673,3 +700,5 @@ USE: vocabs.loader
{ [ os macosx? ] [ "cpu.ppc.macosx" require ] }
{ [ os linux? ] [ "cpu.ppc.linux" require ] }
} cond
+
+"complex-double" c-type t >>return-in-registers? drop
diff --git a/basis/documents/elements/elements-tests.factor b/basis/documents/elements/elements-tests.factor
index a3f05d7a71..9b323ae8e9 100644
--- a/basis/documents/elements/elements-tests.factor
+++ b/basis/documents/elements/elements-tests.factor
@@ -3,68 +3,72 @@
USING: tools.test namespaces documents documents.elements multiline ;
IN: document.elements.tests
-<document> "doc" set
-"123\nabc" "doc" get set-doc-string
+SYMBOL: doc
+<document> doc set
+"123\nabcé" doc get set-doc-string
! char-elt
-[ { 0 0 } ] [ { 0 0 } "doc" get char-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 1 } "doc" get char-elt prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 0 } "doc" get char-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get char-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 1 } doc get char-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 0 } doc get char-elt prev-elt ] unit-test
+[ { 1 3 } ] [ { 1 5 } doc get char-elt prev-elt ] unit-test
-[ { 1 3 } ] [ { 1 3 } "doc" get char-elt next-elt ] unit-test
-[ { 0 2 } ] [ { 0 1 } "doc" get char-elt next-elt ] unit-test
-[ { 1 0 } ] [ { 0 3 } "doc" get char-elt next-elt ] unit-test
+[ { 1 5 } ] [ { 1 5 } doc get char-elt next-elt ] unit-test
+[ { 0 2 } ] [ { 0 1 } doc get char-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 0 3 } doc get char-elt next-elt ] unit-test
+[ { 1 5 } ] [ { 1 3 } doc get char-elt next-elt ] unit-test
! word-elt
-<document> "doc" set
-"Hello world\nanother line" "doc" get set-doc-string
+<document> doc set
+"Hello world\nanother line" doc get set-doc-string
-[ { 0 0 } ] [ { 0 0 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 6 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 6 } ] [ { 0 8 } "doc" get word-elt prev-elt ] unit-test
-[ { 0 11 } ] [ { 1 0 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } doc get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } doc get word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 6 } doc get word-elt prev-elt ] unit-test
+[ { 0 6 } ] [ { 0 8 } doc get word-elt prev-elt ] unit-test
+[ { 0 11 } ] [ { 1 0 } doc get word-elt prev-elt ] unit-test
+
+[ { 0 5 } ] [ { 0 0 } doc get word-elt next-elt ] unit-test
+[ { 0 6 } ] [ { 0 5 } doc get word-elt next-elt ] unit-test
+[ { 0 11 } ] [ { 0 6 } doc get word-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 0 11 } doc get word-elt next-elt ] unit-test
-[ { 0 5 } ] [ { 0 0 } "doc" get word-elt next-elt ] unit-test
-[ { 0 6 } ] [ { 0 5 } "doc" get word-elt next-elt ] unit-test
-[ { 0 11 } ] [ { 0 6 } "doc" get word-elt next-elt ] unit-test
-[ { 1 0 } ] [ { 0 11 } "doc" get word-elt next-elt ] unit-test
! one-word-elt
-[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
-[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
+[ { 0 0 } ] [ { 0 0 } doc get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } doc get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } doc get one-word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 2 } doc get one-word-elt next-elt ] unit-test
+[ { 0 5 } ] [ { 0 5 } doc get one-word-elt next-elt ] unit-test
! line-elt
-<document> "doc" set
-"Hello\nworld, how are\nyou?" "doc" get set-doc-string
+<document> doc set
+"Hello\nworld, how are\nyou?" doc get set-doc-string
-[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
-[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
+[ { 0 0 } ] [ { 0 3 } doc get line-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 3 } doc get line-elt prev-elt ] unit-test
+[ { 2 4 } ] [ { 2 1 } doc get line-elt next-elt ] unit-test
! one-line-elt
-[ { 1 0 } ] [ { 1 3 } "doc" get one-line-elt prev-elt ] unit-test
-[ { 1 14 } ] [ { 1 3 } "doc" get one-line-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 1 3 } doc get one-line-elt prev-elt ] unit-test
+[ { 1 14 } ] [ { 1 3 } doc get one-line-elt next-elt ] unit-test
! page-elt
-<document> "doc" set
+<document> doc set
<" First line
Second line
Third line
Fourth line
Fifth line
-Sixth line"> "doc" get set-doc-string
+Sixth line"> doc get set-doc-string
-[ { 0 0 } ] [ { 3 3 } "doc" get 4 <page-elt> prev-elt ] unit-test
-[ { 1 2 } ] [ { 5 2 } "doc" get 4 <page-elt> prev-elt ] unit-test
+[ { 0 0 } ] [ { 3 3 } doc get 4 <page-elt> prev-elt ] unit-test
+[ { 1 2 } ] [ { 5 2 } doc get 4 <page-elt> prev-elt ] unit-test
-[ { 4 3 } ] [ { 0 3 } "doc" get 4 <page-elt> next-elt ] unit-test
-[ { 5 10 } ] [ { 4 2 } "doc" get 4 <page-elt> next-elt ] unit-test
+[ { 4 3 } ] [ { 0 3 } doc get 4 <page-elt> next-elt ] unit-test
+[ { 5 10 } ] [ { 4 2 } doc get 4 <page-elt> next-elt ] unit-test
! doc-elt
-[ { 0 0 } ] [ { 3 4 } "doc" get doc-elt prev-elt ] unit-test
-[ { 5 10 } ] [ { 3 4 } "doc" get doc-elt next-elt ] unit-test
\ No newline at end of file
+[ { 0 0 } ] [ { 3 4 } doc get doc-elt prev-elt ] unit-test
+[ { 5 10 } ] [ { 3 4 } doc get doc-elt next-elt ] unit-test
diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor
index adb498df13..f485f1bec1 100644
--- a/basis/documents/elements/elements.factor
+++ b/basis/documents/elements/elements.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays combinators documents fry kernel math sequences
-unicode.categories accessors ;
+accessors unicode.categories unicode.breaks combinators.short-circuit ;
IN: documents.elements
GENERIC: prev-elt ( loc document elt -- newloc )
@@ -20,27 +20,32 @@ SINGLETON: char-elt
<PRIVATE
-: (prev-char) ( loc document quot -- loc )
+: prev ( loc document quot: ( loc document -- loc ) -- loc )
{
{ [ pick { 0 0 } = ] [ 2drop ] }
{ [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
[ call ]
} cond ; inline
-: (next-char) ( loc document quot -- loc )
+: next ( loc document quot: ( loc document -- loc ) -- loc )
{
{ [ 2over doc-end = ] [ 2drop ] }
{ [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
[ call ]
} cond ; inline
+: modify-col ( loc document quot: ( col str -- col' ) -- loc )
+ pick [
+ [ [ first2 swap ] dip doc-line ] dip call
+ ] dip =col ; inline
+
PRIVATE>
M: char-elt prev-elt
- drop [ drop -1 +col ] (prev-char) ;
+ drop [ [ last-grapheme-from ] modify-col ] prev ;
M: char-elt next-elt
- drop [ drop 1 +col ] (next-char) ;
+ drop [ [ first-grapheme-from ] modify-col ] next ;
SINGLETON: one-char-elt
@@ -50,21 +55,16 @@ M: one-char-elt next-elt 2drop ;
<PRIVATE
-: (word-elt) ( loc document quot -- loc )
- pick [
- [ [ first2 swap ] dip doc-line ] dip call
- ] dip =col ; inline
-
-: ((word-elt)) ( n seq -- n seq ? )
+: blank-at? ( n seq -- n seq ? )
2dup ?nth blank? ;
: break-detector ( ? -- quot )
'[ blank? _ xor ] ; inline
-: (prev-word) ( col str ? -- col )
+: prev-word ( col str ? -- col )
break-detector find-last-from drop ?1+ ;
-: (next-word) ( col str ? -- col )
+: next-word ( col str ? -- col )
[ break-detector find-from drop ] [ drop length ] 2bi or ;
PRIVATE>
@@ -73,23 +73,23 @@ SINGLETON: one-word-elt
M: one-word-elt prev-elt
drop
- [ [ 1- ] dip f (prev-word) ] (word-elt) ;
+ [ [ 1- ] dip f prev-word ] modify-col ;
M: one-word-elt next-elt
drop
- [ f (next-word) ] (word-elt) ;
+ [ f next-word ] modify-col ;
SINGLETON: word-elt
M: word-elt prev-elt
drop
- [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
- (prev-char) ;
+ [ [ [ 1- ] dip blank-at? prev-word ] modify-col ]
+ prev ;
M: word-elt next-elt
drop
- [ [ ((word-elt)) (next-word) ] (word-elt) ]
- (next-char) ;
+ [ [ blank-at? next-word ] modify-col ]
+ next ;
SINGLETON: one-line-elt
@@ -118,4 +118,4 @@ SINGLETON: doc-elt
M: doc-elt prev-elt 3drop { 0 0 } ;
-M: doc-elt next-elt drop nip doc-end ;
\ No newline at end of file
+M: doc-elt next-elt drop nip doc-end ;
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index cc379810ac..abee7194a2 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: farkup kernel peg peg.ebnf tools.test namespaces xml
-urls.encoding assocs xml.traversal xml.data ;
+urls.encoding assocs xml.traversal xml.data sequences random
+io continuations math ;
IN: farkup.tests
relative-link-prefix off
@@ -180,3 +181,29 @@ link-no-follow? off
[ "<p><em>italics<strong>both</strong></em>after<strong></strong></p>" ] [ "_italics*both_after*" convert-farkup ] unit-test
[ "<table><tr><td>foo|bar</td></tr></table>" ] [ "|foo\\|bar|" convert-farkup ] unit-test
[ "<p></p>" ] [ "\\" convert-farkup ] unit-test
+
+[ "<p>[abc]</p>" ] [ "[abc]" convert-farkup ] unit-test
+
+: random-markup ( -- string )
+ 10 [
+ 2 random 1 = [
+ {
+ "[["
+ "*"
+ "_"
+ "|"
+ "-"
+ "[{"
+ "\n"
+ } random
+ ] [
+ "abc"
+ ] if
+ ] replicate concat ;
+
+[ t ] [
+ 100 [
+ drop random-markup
+ [ convert-farkup drop t ] [ drop print f ] recover
+ ] all?
+] unit-test
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index 23a9023835..c400457c0b 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -75,7 +75,7 @@ DEFER: (parse-paragraph)
"|" split1
[ "" like dup simple-link-title ] unless*
[ "image:" ?head ] dip swap [ image boa ] [ parse-paragraph link boa ] if
- ] dip [ (parse-paragraph) cons ] when* ;
+ ] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
: ?first ( seq -- elt ) 0 swap ?nth ;
@@ -121,7 +121,7 @@ DEFER: (parse-paragraph)
] if
] if ;
-: take-until ( state delimiter -- string/f state' )
+: take-until ( state delimiter -- string state'/f )
V{ } clone (take-until) ;
: count= ( string -- n )
@@ -186,10 +186,12 @@ DEFER: (parse-paragraph)
: parse-code ( state -- state' item )
dup 1 look CHAR: [ =
- [ unclip-slice make-paragraph ] [
- "{" take-until [ rest ] dip
- "}]" take-until
- [ code boa ] dip swap
+ [ take-line make-paragraph ] [
+ dup "{" take-until [
+ [ nip rest ] dip
+ "}]" take-until
+ [ code boa ] dip swap
+ ] [ drop take-line make-paragraph ] if*
] if ;
: parse-item ( state -- state' item )
diff --git a/basis/help/tips/tips-docs.factor b/basis/help/tips/tips-docs.factor
index 8d732c5568..750eff7a52 100644
--- a/basis/help/tips/tips-docs.factor
+++ b/basis/help/tips/tips-docs.factor
@@ -17,7 +17,14 @@ TIP: "You can write documentation for your own code using the " { $link "help" }
TIP: "You can write graphical applications using the " { $link "ui" } "." ;
TIP: "Power tools: " { $links see edit help about apropos time infer. } ;
-
+
+TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ;
+
+HELP: TIP:
+{ $syntax "TIP: content ;" }
+{ $values { "content" "a markup element" } }
+{ $description "Defines a new tip of the day." } ;
+
ARTICLE: "all-tips-of-the-day" "All tips of the day"
{ $tips-of-the-day } ;
diff --git a/basis/help/tips/tips.factor b/basis/help/tips/tips.factor
index 8d173ce533..4685b6c517 100644
--- a/basis/help/tips/tips.factor
+++ b/basis/help/tips/tips.factor
@@ -1,14 +1,28 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser arrays namespaces sequences random help.markup kernel io
-io.styles colors.constants ;
+USING: parser arrays namespaces sequences random help.markup help.stylesheet
+kernel io io.styles colors.constants definitions accessors ;
IN: help.tips
SYMBOL: tips
tips [ V{ } clone ] initialize
-SYNTAX: TIP: parse-definition >array tips get push ;
+TUPLE: tip < identity-tuple content loc ;
+
+M: tip forget* tips get delq ;
+
+M: tip where loc>> ;
+
+M: tip set-where (>>loc) ;
+
+: <tip> ( content -- tip ) f tip boa ;
+
+: add-tip ( tip -- ) tips get push ;
+
+SYNTAX: TIP:
+ parse-definition >array <tip>
+ [ save-location ] [ add-tip ] bi ;
: a-tip ( -- tip ) tips get random ;
@@ -20,13 +34,20 @@ H{
{ wrap-margin 500 }
} tip-of-the-day-style set-global
+: $tip-title ( tip -- )
+ [
+ heading-style get [
+ [ "Tip of the day" ] dip write-object
+ ] with-style
+ ] ($block) ;
+
: $tip-of-the-day ( element -- )
drop
[
tip-of-the-day-style get
[
last-element off
- "Tip of the day" $heading a-tip print-element nl
+ a-tip [ $tip-title ] [ content>> print-element nl ] bi
"— " print-element "all-tips-of-the-day" ($link)
]
with-nesting
@@ -35,4 +56,6 @@ H{
: tip-of-the-day. ( -- ) { $tip-of-the-day } print-content nl ;
: $tips-of-the-day ( element -- )
- drop tips get [ nl nl ] [ print-element ] interleave ;
\ No newline at end of file
+ drop tips get [ nl nl ] [ content>> print-element ] interleave ;
+
+INSTANCE: tip definition
\ No newline at end of file
diff --git a/basis/help/topics/topics.factor b/basis/help/topics/topics.factor
index 864b030126..a251849e8f 100644
--- a/basis/help/topics/topics.factor
+++ b/basis/help/topics/topics.factor
@@ -7,8 +7,12 @@ IN: help.topics
TUPLE: link name ;
+INSTANCE: link definition
+
MIXIN: topic
+
INSTANCE: link topic
+
INSTANCE: word topic
GENERIC: >link ( obj -- obj )
diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor
index 52684e55f5..804ef035f4 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -34,16 +34,18 @@ M: object specializer-declaration class ;
[ specializer-declaration ] map '[ _ declare ] pick append
] { } map>assoc ;
+: specialize-quot ( quot specializer -- quot' )
+ specializer-cases alist>quot ;
+
: method-declaration ( method -- quot )
[ "method-generic" word-prop dispatch# object <array> ]
[ "method-class" word-prop ]
bi prefix ;
: specialize-method ( quot method -- quot' )
- method-declaration '[ _ declare ] prepend ;
-
-: specialize-quot ( quot specializer -- quot' )
- specializer-cases alist>quot ;
+ [ method-declaration '[ _ declare ] prepend ]
+ [ "method-generic" word-prop "specializer" word-prop ] bi
+ [ specialize-quot ] when* ;
: standard-method? ( method -- ? )
dup method-body? [
@@ -52,9 +54,11 @@ M: object specializer-declaration class ;
: specialized-def ( word -- quot )
[ def>> ] keep
- [ dup standard-method? [ specialize-method ] [ drop ] if ]
- [ "specializer" word-prop [ specialize-quot ] when* ]
- bi ;
+ dup generic? [ drop ] [
+ [ dup standard-method? [ specialize-method ] [ drop ] if ]
+ [ "specializer" word-prop [ specialize-quot ] when* ]
+ bi
+ ] if ;
: specialized-length ( specializer -- n )
dup [ array? ] all? [ first ] when length ;
@@ -115,6 +119,6 @@ SYNTAX: HINTS:
\ >be { { bignum fixnum } { fixnum fixnum } } "specializer" set-word-prop
-\ hashtable \ at* method { { fixnum hashtable } { word hashtable } } "specializer" set-word-prop
+\ hashtable \ at* method { { fixnum object } { word object } } "specializer" set-word-prop
\ hashtable \ set-at method { { object fixnum object } { object word object } } "specializer" set-word-prop
diff --git a/basis/images/images.factor b/basis/images/images.factor
index a426c33ddc..08fbdd4e7e 100644
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -1,16 +1,14 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors grouping sequences combinators
-math specialized-arrays.direct.uint byte-arrays fry
-specialized-arrays.direct.ushort specialized-arrays.uint
-specialized-arrays.ushort specialized-arrays.float ;
+USING: combinators kernel ;
IN: images
-SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
+SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
: bytes-per-pixel ( component-order -- n )
{
+ { L [ 1 ] }
{ BGR [ 3 ] }
{ RGB [ 3 ] }
{ BGRA [ 4 ] }
@@ -31,71 +29,4 @@ TUPLE: image dim component-order upside-down? bitmap ;
: <image> ( -- image ) image new ; inline
-GENERIC: load-image* ( path tuple -- image )
-
-: add-dummy-alpha ( seq -- seq' )
- 3 <groups> [ 255 suffix ] map concat ;
-
-: normalize-floats ( byte-array -- byte-array )
- byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
-
-GENERIC: normalize-component-order* ( image component-order -- image )
-
-: normalize-component-order ( image -- image )
- dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
-
-M: RGBA normalize-component-order* drop ;
-
-M: R32G32B32A32 normalize-component-order*
- drop normalize-floats ;
-
-M: R32G32B32 normalize-component-order*
- drop normalize-floats add-dummy-alpha ;
-
-: RGB16>8 ( bitmap -- bitmap' )
- byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
-
-M: R16G16B16A16 normalize-component-order*
- drop RGB16>8 ;
-
-M: R16G16B16 normalize-component-order*
- drop RGB16>8 add-dummy-alpha ;
-
-: BGR>RGB ( bitmap -- pixels )
- 3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
-
-: BGRA>RGBA ( bitmap -- pixels )
- 4 <sliced-groups>
- [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
-
-M: BGRA normalize-component-order*
- drop BGRA>RGBA ;
-
-M: RGB normalize-component-order*
- drop add-dummy-alpha ;
-
-M: BGR normalize-component-order*
- drop BGR>RGB add-dummy-alpha ;
-
-: ARGB>RGBA ( bitmap -- bitmap' )
- 4 <groups> [ unclip suffix ] map B{ } join ; inline
-
-M: ARGB normalize-component-order*
- drop ARGB>RGBA ;
-
-M: ABGR normalize-component-order*
- drop ARGB>RGBA BGRA>RGBA ;
-
-: normalize-scan-line-order ( image -- image )
- dup upside-down?>> [
- dup dim>> first 4 * '[
- _ <groups> reverse concat
- ] change-bitmap
- f >>upside-down?
- ] when ;
-
-: normalize-image ( image -- image )
- [ >byte-array ] change-bitmap
- normalize-component-order
- normalize-scan-line-order
- RGBA >>component-order ;
+GENERIC: load-image* ( path tuple -- image )
\ No newline at end of file
diff --git a/basis/images/loader/loader.factor b/basis/images/loader/loader.factor
index 6f2ae47c61..b8bafc021f 100644
--- a/basis/images/loader/loader.factor
+++ b/basis/images/loader/loader.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators
-accessors images.bitmap images.tiff images io.backend
+accessors images.bitmap images.tiff images images.normalization
io.pathnames ;
IN: images.loader
diff --git a/basis/images/normalization/authors.txt b/basis/images/normalization/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/basis/images/normalization/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/basis/images/normalization/normalization.factor b/basis/images/normalization/normalization.factor
new file mode 100644
index 0000000000..bcdf841b42
--- /dev/null
+++ b/basis/images/normalization/normalization.factor
@@ -0,0 +1,78 @@
+! Copyright (C) 2009 Doug Coleman
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel accessors grouping sequences combinators
+math specialized-arrays.direct.uint byte-arrays fry
+specialized-arrays.direct.ushort specialized-arrays.uint
+specialized-arrays.ushort specialized-arrays.float images ;
+IN: images.normalization
+
+<PRIVATE
+
+: add-dummy-alpha ( seq -- seq' )
+ 3 <groups> [ 255 suffix ] map concat ;
+
+: normalize-floats ( byte-array -- byte-array )
+ byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
+
+GENERIC: normalize-component-order* ( image component-order -- image )
+
+: normalize-component-order ( image -- image )
+ dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
+
+M: RGBA normalize-component-order* drop ;
+
+M: R32G32B32A32 normalize-component-order*
+ drop normalize-floats ;
+
+M: R32G32B32 normalize-component-order*
+ drop normalize-floats add-dummy-alpha ;
+
+: RGB16>8 ( bitmap -- bitmap' )
+ byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
+
+M: R16G16B16A16 normalize-component-order*
+ drop RGB16>8 ;
+
+M: R16G16B16 normalize-component-order*
+ drop RGB16>8 add-dummy-alpha ;
+
+: BGR>RGB ( bitmap -- pixels )
+ 3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
+
+: BGRA>RGBA ( bitmap -- pixels )
+ 4 <sliced-groups>
+ [ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
+
+M: BGRA normalize-component-order*
+ drop BGRA>RGBA ;
+
+M: RGB normalize-component-order*
+ drop add-dummy-alpha ;
+
+M: BGR normalize-component-order*
+ drop BGR>RGB add-dummy-alpha ;
+
+: ARGB>RGBA ( bitmap -- bitmap' )
+ 4 <groups> [ unclip suffix ] map B{ } join ; inline
+
+M: ARGB normalize-component-order*
+ drop ARGB>RGBA ;
+
+M: ABGR normalize-component-order*
+ drop ARGB>RGBA BGRA>RGBA ;
+
+: normalize-scan-line-order ( image -- image )
+ dup upside-down?>> [
+ dup dim>> first 4 * '[
+ _ <groups> reverse concat
+ ] change-bitmap
+ f >>upside-down?
+ ] when ;
+
+PRIVATE>
+
+: normalize-image ( image -- image )
+ [ >byte-array ] change-bitmap
+ normalize-component-order
+ normalize-scan-line-order
+ RGBA >>component-order ;
diff --git a/basis/images/tesselation/authors.txt b/basis/images/tesselation/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/images/tesselation/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/images/tesselation/tesselation-tests.factor b/basis/images/tesselation/tesselation-tests.factor
new file mode 100644
index 0000000000..2ac8e37ae7
--- /dev/null
+++ b/basis/images/tesselation/tesselation-tests.factor
@@ -0,0 +1,46 @@
+USING: images accessors kernel tools.test literals math.ranges
+byte-arrays ;
+IN: images.tesselation
+
+! Check an invariant we depend on
+[ t ] [
+ <image> B{ 1 2 3 } >>bitmap dup clone [ bitmap>> ] bi@ eq?
+] unit-test
+
+[
+ {
+ {
+ T{ image f { 2 2 } L f B{ 1 2 5 6 } }
+ T{ image f { 2 2 } L f B{ 3 4 7 8 } }
+ }
+ {
+ T{ image f { 2 2 } L f B{ 9 10 13 14 } }
+ T{ image f { 2 2 } L f B{ 11 12 15 16 } }
+ }
+ }
+] [
+ <image>
+ 1 16 [a,b] >byte-array >>bitmap
+ { 4 4 } >>dim
+ L >>component-order
+ { 2 2 } tesselate
+] unit-test
+
+[
+ {
+ {
+ T{ image f { 2 2 } L f B{ 1 2 4 5 } }
+ T{ image f { 1 2 } L f B{ 3 6 } }
+ }
+ {
+ T{ image f { 2 1 } L f B{ 7 8 } }
+ T{ image f { 1 1 } L f B{ 9 } }
+ }
+ }
+] [
+ <image>
+ 1 9 [a,b] >byte-array >>bitmap
+ { 3 3 } >>dim
+ L >>component-order
+ { 2 2 } tesselate
+] unit-test
\ No newline at end of file
diff --git a/basis/images/tesselation/tesselation.factor b/basis/images/tesselation/tesselation.factor
new file mode 100644
index 0000000000..694041a28d
--- /dev/null
+++ b/basis/images/tesselation/tesselation.factor
@@ -0,0 +1,35 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences kernel math grouping fry columns locals accessors
+images math math.vectors arrays ;
+IN: images.tesselation
+
+: group-rows ( bitmap bitmap-dim -- rows )
+ first <sliced-groups> ; inline
+
+: tesselate-rows ( bitmap-rows tess-dim -- bitmaps )
+ second <sliced-groups> ; inline
+
+: tesselate-columns ( bitmap-rows tess-dim -- bitmaps )
+ first '[ _ <sliced-groups> ] map flip ; inline
+
+: tesselate-bitmap ( bitmap bitmap-dim tess-dim -- bitmap-grid )
+ [ group-rows ] dip
+ [ tesselate-rows ] keep
+ '[ _ tesselate-columns ] map ;
+
+: tile-width ( tile-bitmap original-image -- width )
+ [ first length ] [ component-order>> bytes-per-pixel ] bi* /i ;
+
+: <tile-image> ( tile-bitmap original-image -- tile-image )
+ clone
+ swap
+ [ concat >>bitmap ]
+ [ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
+
+:: tesselate ( image tess-dim -- image-grid )
+ image component-order>> bytes-per-pixel :> bpp
+ image dim>> { bpp 1 } v* :> image-dim'
+ tess-dim { bpp 1 } v* :> tess-dim'
+ image bitmap>> image-dim' tess-dim' tesselate-bitmap
+ [ [ image <tile-image> ] map ] map ;
\ No newline at end of file
diff --git a/basis/io/directories/search/search.factor b/basis/io/directories/search/search.factor
index a3db10ffff..6db83ebca6 100755
--- a/basis/io/directories/search/search.factor
+++ b/basis/io/directories/search/search.factor
@@ -65,9 +65,9 @@ ERROR: file-not-found ;
_ [ _ _ find-file [ file-not-found ] unless* ] attempt-all
] [
drop f
- ] recover ;
+ ] recover ; inline
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
- '[ _ _ find-all-files ] map concat ;
+ '[ _ _ find-all-files ] map concat ; inline
os windows? [ "io.directories.search.windows" require ] when
diff --git a/basis/io/encodings/ascii/ascii.factor b/basis/io/encodings/ascii/ascii.factor
index deb1a7121f..1654cb8b83 100644
--- a/basis/io/encodings/ascii/ascii.factor
+++ b/basis/io/encodings/ascii/ascii.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: io io.encodings kernel math io.encodings.private io.encodings.iana ;
+USING: io io.encodings kernel math io.encodings.private ;
IN: io.encodings.ascii
<PRIVATE
@@ -19,6 +19,4 @@ M: ascii encode-char
128 encode-if< ;
M: ascii decode-char
- 128 decode-if< ;
-
-ascii "ANSI_X3.4-1968" register-encoding
+ 128 decode-if< ;
\ No newline at end of file
diff --git a/basis/io/encodings/iana/iana.factor b/basis/io/encodings/iana/iana.factor
index cb4627460c..899bedfbc6 100644
--- a/basis/io/encodings/iana/iana.factor
+++ b/basis/io/encodings/iana/iana.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2008 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings values io.files assocs
-splitting sequences io namespaces sets io.encodings.utf8 ;
+splitting sequences io namespaces sets
+io.encodings.ascii io.encodings.utf8 ;
IN: io.encodings.iana
<PRIVATE
@@ -52,3 +53,5 @@ e>n-table [ initial-e>n ] initialize
[ n>e-table get-global set-at ] with each
] [ "Bad encoding registration" throw ] if*
] [ swap e>n-table get-global set-at ] 2bi ;
+
+ascii "ANSI_X3.4-1968" register-encoding
diff --git a/basis/io/streams/byte-array/byte-array-tests.factor b/basis/io/streams/byte-array/byte-array-tests.factor
index 77a9126740..44290bfb47 100644
--- a/basis/io/streams/byte-array/byte-array-tests.factor
+++ b/basis/io/streams/byte-array/byte-array-tests.factor
@@ -1,5 +1,5 @@
USING: tools.test io.streams.byte-array io.encodings.binary
-io.encodings.utf8 io kernel arrays strings ;
+io.encodings.utf8 io kernel arrays strings namespaces ;
[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
@@ -7,3 +7,23 @@ io.encodings.utf8 io kernel arrays strings ;
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
+
+[ B{ 121 120 } 0 ] [
+ B{ 0 121 120 0 0 0 0 0 0 } binary
+ [ 1 read drop "\0" read-until ] with-byte-reader
+] unit-test
+
+[ 1 1 4 11 f ] [
+ B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary
+ [
+ read1
+ 0 seek-absolute input-stream get stream-seek
+ read1
+ 2 seek-relative input-stream get stream-seek
+ read1
+ -2 seek-end input-stream get stream-seek
+ read1
+ 0 seek-end input-stream get stream-seek
+ read1
+ ] with-byte-reader
+] unit-test
\ No newline at end of file
diff --git a/basis/io/streams/byte-array/byte-array.factor b/basis/io/streams/byte-array/byte-array.factor
index 25d879a534..2ffb9b9a63 100644
--- a/basis/io/streams/byte-array/byte-array.factor
+++ b/basis/io/streams/byte-array/byte-array.factor
@@ -28,7 +28,7 @@ M: byte-reader stream-seek ( n seek-type stream -- )
swap {
{ seek-absolute [ (>>i) ] }
{ seek-relative [ [ + ] change-i drop ] }
- { seek-end [ dup underlying>> length >>i [ + ] change-i drop ] }
+ { seek-end [ [ underlying>> length + ] keep (>>i) ] }
[ bad-seek-type ]
} case ;
diff --git a/basis/math/bitwise/bitwise.factor b/basis/math/bitwise/bitwise.factor
index 4f639c02a7..3148567bc0 100755
--- a/basis/math/bitwise/bitwise.factor
+++ b/basis/math/bitwise/bitwise.factor
@@ -37,7 +37,7 @@ IN: math.bitwise
! flags
MACRO: flags ( values -- )
- [ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
+ [ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
! bitfield
<PRIVATE
diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor
index 5466ad2161..0603a91370 100644
--- a/basis/math/blas/ffi/ffi.factor
+++ b/basis/math/blas/ffi/ffi.factor
@@ -7,7 +7,11 @@ IN: math.blas.ffi
{ [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
{ [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
{ [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] }
- { [ os freebsd? ] [ "libblas.so" gfortran-abi add-fortran-library ] }
+ {
+ [ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ]
+ [ "libblas.so" gfortran-abi add-fortran-library ]
+ }
+ { [ os [ freebsd? ] [ linux? ] bi or ] [ "libblas.so" gfortran-abi add-fortran-library ] }
[ "libblas.so" f2c-abi add-fortran-library ]
} cond
>>
diff --git a/basis/models/models-docs.factor b/basis/models/models-docs.factor
index 82dd035467..2b90bdb0d5 100644
--- a/basis/models/models-docs.factor
+++ b/basis/models/models-docs.factor
@@ -5,12 +5,13 @@ IN: models
HELP: model
{ $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:"
{ $list
- { { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
- { { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
- { { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
- { { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." }
+ { { $slot "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
+ { { $slot "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
+ { { $slot "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
+ { { $slot "ref" } " - a reference count tracking the number of models which depend on this one." }
+ { { $slot "locked?" } " - a slot set by " { $link with-locked-model } " to ensure that the model doesn't get changed recursively" }
}
-"Other classes may delegate to " { $link model } "."
+"Other classes may inherit from " { $link model } "."
} ;
HELP: <model>
diff --git a/basis/opengl/opengl-docs.factor b/basis/opengl/opengl-docs.factor
index acff2dcd9e..f474c97b73 100644
--- a/basis/opengl/opengl-docs.factor
+++ b/basis/opengl/opengl-docs.factor
@@ -23,11 +23,11 @@ HELP: gl-line
{ $description "Draws a line between two points." } ;
HELP: gl-fill-rect
-{ $values { "dim" "a pair of integers" } }
+{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
{ $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ;
HELP: gl-rect
-{ $values { "dim" "a pair of integers" } }
+{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
{ $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ;
HELP: gen-gl-buffer
diff --git a/basis/opengl/opengl.factor b/basis/opengl/opengl.factor
index e08a7487ae..0a21f67376 100644
--- a/basis/opengl/opengl.factor
+++ b/basis/opengl/opengl.factor
@@ -3,8 +3,8 @@
! Portions copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types continuations kernel libc math macros
-namespaces math.vectors math.parser opengl.gl opengl.glu
-combinators arrays sequences splitting words byte-arrays assocs
+namespaces math.vectors math.parser opengl.gl opengl.glu combinators
+combinators.smart arrays sequences splitting words byte-arrays assocs
colors colors.constants accessors generalizations locals fry
specialized-arrays.float specialized-arrays.uint ;
IN: opengl
@@ -28,7 +28,7 @@ IN: opengl
over glEnableClientState dip glDisableClientState ; inline
: words>values ( word/value-seq -- value-seq )
- [ dup word? [ execute ] when ] map ;
+ [ ?execute ] map ;
: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
@@ -67,42 +67,46 @@ MACRO: all-enabled-client-state ( seq quot -- )
: gl-line ( a b -- )
line-vertices GL_LINES 0 2 glDrawArrays ;
-: (rect-vertices) ( dim -- vertices )
+:: (rect-vertices) ( loc dim -- vertices )
#! We use GL_LINE_STRIP with a duplicated first vertex
#! instead of GL_LINE_LOOP to work around a bug in Apple's
#! X3100 driver.
- {
- [ drop 0.5 0.5 ]
- [ first 0.3 - 0.5 ]
- [ [ first 0.3 - ] [ second 0.3 - ] bi ]
- [ second 0.3 - 0.5 swap ]
- [ drop 0.5 0.5 ]
- } cleave 10 float-array{ } nsequence ;
+ loc first2 :> y :> x
+ dim first2 :> h :> w
+ [
+ x 0.5 + y 0.5 +
+ x w + 0.3 - y 0.5 +
+ x w + 0.3 - y h + 0.3 -
+ x y h + 0.3 -
+ x 0.5 + y 0.5 +
+ ] float-array{ } output>sequence ;
-: rect-vertices ( dim -- )
+: rect-vertices ( loc dim -- )
(rect-vertices) gl-vertex-pointer ;
: (gl-rect) ( -- )
GL_LINE_STRIP 0 5 glDrawArrays ;
-: gl-rect ( dim -- )
+: gl-rect ( loc dim -- )
rect-vertices (gl-rect) ;
-: (fill-rect-vertices) ( dim -- vertices )
- {
- [ drop 0 0 ]
- [ first 0 ]
- [ first2 ]
- [ second 0 swap ]
- } cleave 8 float-array{ } nsequence ;
+:: (fill-rect-vertices) ( loc dim -- vertices )
+ loc first2 :> y :> x
+ dim first2 :> h :> w
+ [
+ x y
+ x w + y
+ x w + y h +
+ x y h +
+ ] float-array{ } output>sequence ;
-: fill-rect-vertices ( dim -- )
+: fill-rect-vertices ( loc dim -- )
(fill-rect-vertices) gl-vertex-pointer ;
: (gl-fill-rect) ( -- )
GL_QUADS 0 4 glDrawArrays ;
-: gl-fill-rect ( dim -- )
+: gl-fill-rect ( loc dim -- )
fill-rect-vertices (gl-fill-rect) ;
: do-attribs ( bits quot -- )
diff --git a/basis/opengl/textures/textures-tests.factor b/basis/opengl/textures/textures-tests.factor
index 7141caa67d..163871028d 100644
--- a/basis/opengl/textures/textures-tests.factor
+++ b/basis/opengl/textures/textures-tests.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test opengl.textures opengl.textures.private
-images kernel namespaces ;
+opengl.textures.private images kernel namespaces accessors
+sequences ;
IN: opengl.textures.tests
[ ] [
@@ -52,4 +53,17 @@ IN: opengl.textures.tests
{ component-order R32G32B32 }
{ bitmap B{ } }
} power-of-2-image
+] unit-test
+
+[
+ {
+ { { 0 0 } { 10 0 } }
+ { { 0 20 } { 10 20 } }
+ }
+] [
+ {
+ { { 10 20 } { 30 20 } }
+ { { 10 30 } { 30 300 } }
+ }
+ [ [ image new swap >>dim ] map ] map image-locs
] unit-test
\ No newline at end of file
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index 48cdafb837..810aaa2c9c 100644
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -1,16 +1,15 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs cache colors.constants destructors fry kernel
-opengl opengl.gl combinators images grouping specialized-arrays.float
-locals sequences math math.vectors generalizations ;
+opengl opengl.gl combinators images images.tesselation grouping
+specialized-arrays.float locals sequences math math.vectors
+math.matrices generalizations fry columns ;
IN: opengl.textures
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
-TUPLE: texture loc dim texture-coords texture display-list disposed ;
-
GENERIC: component-order>format ( component-order -- format type )
M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
@@ -19,8 +18,14 @@ M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
+GENERIC: draw-texture ( texture -- )
+
+GENERIC: draw-scaled-texture ( dim texture -- )
+
<PRIVATE
+TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
+
: repeat-last ( seq n -- seq' )
over peek pad-tail concat ;
@@ -69,20 +74,27 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
-: draw-textured-rect ( dim texture -- )
+: with-texturing ( quot -- )
GL_TEXTURE_2D [
GL_TEXTURE_BIT [
GL_TEXTURE_COORD_ARRAY [
COLOR: white gl-color
- dup loc>> [
- [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
- [ init-texture texture-coords>> gl-texture-coord-pointer ] bi
- fill-rect-vertices (gl-fill-rect)
- GL_TEXTURE_2D 0 glBindTexture
- ] with-translation
+ call
] do-enabled-client-state
] do-attribs
- ] do-enabled ;
+ ] do-enabled ; inline
+
+: (draw-textured-rect) ( dim texture -- )
+ [ loc>> ]
+ [ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
+ [ init-texture texture-coords>> gl-texture-coord-pointer ] tri
+ swap gl-fill-rect ;
+
+: draw-textured-rect ( dim texture -- )
+ [
+ (draw-textured-rect)
+ GL_TEXTURE_2D 0 glBindTexture
+ ] with-texturing ;
: texture-coords ( dim -- coords )
[ dup next-power-of-2 /f ] map
@@ -92,10 +104,8 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
: make-texture-display-list ( texture -- dlist )
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
-PRIVATE>
-
-: <texture> ( image loc -- texture )
- texture new swap >>loc
+: <single-texture> ( image loc -- texture )
+ single-texture new swap >>loc
swap
[ dim>> >>dim ] keep
[ dim>> product 0 = ] keep '[
@@ -105,12 +115,59 @@ PRIVATE>
dup make-texture-display-list >>display-list
] unless ;
-M: texture dispose*
+M: single-texture dispose*
[ texture>> [ delete-texture ] when* ]
[ display-list>> [ delete-dlist ] when* ] bi ;
-: draw-texture ( texture -- )
- display-list>> [ glCallList ] when* ;
+M: single-texture draw-texture display-list>> [ glCallList ] when* ;
-: draw-scaled-texture ( dim texture -- )
- dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
\ No newline at end of file
+M: single-texture draw-scaled-texture
+ dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
+
+TUPLE: multi-texture grid display-list loc disposed ;
+
+: image-locs ( image-grid -- loc-grid )
+ [ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
+ [ 0 [ + ] accumulate nip ] bi@
+ cross-zip flip ;
+
+: <texture-grid> ( image-grid loc -- grid )
+ [ dup image-locs ] dip
+ '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
+
+: draw-textured-grid ( grid -- )
+ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
+
+: make-textured-grid-display-list ( grid -- dlist )
+ GL_COMPILE [
+ [
+ [
+ [
+ [ dim>> ] keep (draw-textured-rect)
+ ] each
+ ] each
+ GL_TEXTURE_2D 0 glBindTexture
+ ] with-texturing
+ ] make-dlist ;
+
+: <multi-texture> ( image-grid loc -- multi-texture )
+ [
+ [
+ <texture-grid> dup
+ make-textured-grid-display-list
+ ] keep
+ f multi-texture boa
+ ] with-destructors ;
+
+M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
+
+M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
+
+CONSTANT: max-texture-size { 256 256 }
+
+PRIVATE>
+
+: <texture> ( image loc -- texture )
+ over dim>> max-texture-size [ <= ] 2all?
+ [ <single-texture> ]
+ [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
\ No newline at end of file
diff --git a/basis/peg/ebnf/ebnf-tests.factor b/basis/peg/ebnf/ebnf-tests.factor
index a6d3cf0b21..cc83a55c7e 100644
--- a/basis/peg/ebnf/ebnf-tests.factor
+++ b/basis/peg/ebnf/ebnf-tests.factor
@@ -3,7 +3,7 @@
!
USING: kernel tools.test peg peg.ebnf words math math.parser
sequences accessors peg.parsers parser namespaces arrays
- strings eval ;
+ strings eval unicode.data multiline ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
@@ -520,3 +520,13 @@ Tok = Spaces (Number | Special )
{ "\\" } [
"\\" [EBNF foo="\\" EBNF]
] unit-test
+
+[ "USE: peg.ebnf [EBNF EBNF]" eval ] must-fail
+
+[ <" USE: peg.ebnf [EBNF
+ lol = a
+ lol = b
+ EBNF] "> eval
+] [
+ error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
+] must-fail-with
diff --git a/basis/peg/ebnf/ebnf.factor b/basis/peg/ebnf/ebnf.factor
index 9f730831e7..b50ba685b8 100644
--- a/basis/peg/ebnf/ebnf.factor
+++ b/basis/peg/ebnf/ebnf.factor
@@ -5,13 +5,18 @@ sequences quotations vectors namespaces make math assocs
continuations peg peg.parsers unicode.categories multiline
splitting accessors effects sequences.deep peg.search
combinators.short-circuit lexer io.streams.string stack-checker
-io combinators parser ;
+io combinators parser summary ;
IN: peg.ebnf
: rule ( name word -- parser )
#! Given an EBNF word produced from EBNF: return the EBNF rule
"ebnf-parser" word-prop at ;
+ERROR: no-rule rule parser ;
+
+: lookup-rule ( rule parser -- rule' )
+ 2dup rule [ 2nip ] [ no-rule ] if* ;
+
TUPLE: tokenizer any one many ;
: default-tokenizer ( -- tokenizer )
@@ -34,8 +39,13 @@ TUPLE: tokenizer any one many ;
: reset-tokenizer ( -- )
default-tokenizer \ tokenizer set-global ;
+ERROR: no-tokenizer name ;
+
+M: no-tokenizer summary
+ drop "Tokenizer not found" ;
+
SYNTAX: TOKENIZER:
- scan search [ "Tokenizer not found" throw ] unless*
+ scan dup search [ nip ] [ no-tokenizer ] if*
execute( -- tokenizer ) \ tokenizer set-global ;
TUPLE: ebnf-non-terminal symbol ;
@@ -258,7 +268,7 @@ DEFER: 'choice'
"]]" token ensure-not ,
"]?" token ensure-not ,
[ drop t ] satisfy ,
- ] seq* [ first ] action repeat0 [ >string ] action ;
+ ] seq* repeat0 [ concat >string ] action ;
: 'ensure-not' ( -- parser )
#! Parses the '!' syntax to ensure that
@@ -367,15 +377,16 @@ M: ebnf-tokenizer (transform) ( ast -- parser )
(transform)
dup parser-tokenizer \ tokenizer set-global
] if ;
+
+ERROR: redefined-rule name ;
+
+M: redefined-rule summary
+ name>> "Rule '" "' defined more than once" surround ;
M: ebnf-rule (transform) ( ast -- parser )
dup elements>>
(transform) [
- swap symbol>> dup get parser? [
- "Rule '" over append "' defined more than once" append throw
- ] [
- set
- ] if
+ swap symbol>> dup get parser? [ redefined-rule ] [ set ] if
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
@@ -466,14 +477,18 @@ ERROR: bad-effect quot effect ;
{ [ dup (( -- b )) effect<= ] [ drop [ drop ] prepose ] }
[ bad-effect ]
} cond ;
+
+: ebnf-transform ( ast -- parser quot )
+ [ parser>> (transform) ]
+ [ code>> insert-escapes ]
+ [ parser>> ] tri build-locals
+ [ string-lines parse-lines ] call( string -- quot ) ;
M: ebnf-action (transform) ( ast -- parser )
- [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
- [ string-lines parse-lines ] call( string -- quot ) check-action-effect action ;
+ ebnf-transform check-action-effect action ;
M: ebnf-semantic (transform) ( ast -- parser )
- [ parser>> (transform) ] [ code>> insert-escapes ] [ parser>> ] tri build-locals
- [ string-lines parse-lines ] call( string -- quot ) semantic ;
+ ebnf-transform semantic ;
M: ebnf-var (transform) ( ast -- parser )
parser>> (transform) ;
@@ -481,19 +496,20 @@ M: ebnf-var (transform) ( ast -- parser )
M: ebnf-terminal (transform) ( ast -- parser )
symbol>> tokenizer one>> call( symbol -- parser ) ;
+ERROR: ebnf-foreign-not-found name ;
+
+M: ebnf-foreign-not-found summary
+ name>> "Foreign word '" "' not found" surround ;
+
M: ebnf-foreign (transform) ( ast -- parser )
- dup word>> search
- [ "Foreign word '" swap word>> append "' not found" append throw ] unless*
+ dup word>> search [ word>> ebnf-foreign-not-found ] unless*
swap rule>> [ main ] unless* over rule [
nip
] [
execute( -- parser )
] if* ;
-: parser-not-found ( name -- * )
- [
- "Parser '" % % "' not found." %
- ] "" make throw ;
+ERROR: parser-not-found name ;
M: ebnf-non-terminal (transform) ( ast -- parser )
symbol>> [
@@ -504,16 +520,16 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
'ebnf' parse transform ;
: check-parse-result ( result -- result )
- dup [
- dup remaining>> [ blank? ] trim empty? [
+ [
+ dup remaining>> [ blank? ] trim [
[
"Unable to fully parse EBNF. Left to parse was: " %
remaining>> %
] "" make throw
- ] unless
+ ] unless-empty
] [
"Could not parse EBNF" throw
- ] if ;
+ ] if* ;
: parse-ebnf ( string -- hashtable )
'ebnf' (parse) check-parse-result ast>> transform ;
@@ -522,14 +538,18 @@ M: ebnf-non-terminal (transform) ( ast -- parser )
parse-ebnf dup dup parser [ main swap at compile ] with-variable
[ compiled-parse ] curry [ with-scope ast>> ] curry ;
-SYNTAX: <EBNF "EBNF>" reset-tokenizer parse-multiline-string parse-ebnf main swap at
+SYNTAX: <EBNF
+ "EBNF>"
+ reset-tokenizer parse-multiline-string parse-ebnf main swap at
parsed reset-tokenizer ;
-SYNTAX: [EBNF "EBNF]" reset-tokenizer parse-multiline-string ebnf>quot nip
+SYNTAX: [EBNF
+ "EBNF]"
+ reset-tokenizer parse-multiline-string ebnf>quot nip
parsed \ call parsed reset-tokenizer ;
SYNTAX: EBNF:
reset-tokenizer CREATE-WORD dup ";EBNF" parse-multiline-string
- ebnf>quot swapd (( input -- ast )) define-declared "ebnf-parser" set-word-prop
+ ebnf>quot swapd
+ (( input -- ast )) define-declared "ebnf-parser" set-word-prop
reset-tokenizer ;
-
diff --git a/basis/quoting/quoting-tests.factor b/basis/quoting/quoting-tests.factor
new file mode 100644
index 0000000000..f024d9c4a7
--- /dev/null
+++ b/basis/quoting/quoting-tests.factor
@@ -0,0 +1,11 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test quoting ;
+IN: quoting.tests
+
+[ f ] [ "" quoted? ] unit-test
+[ t ] [ "''" quoted? ] unit-test
+[ t ] [ "\"\"" quoted? ] unit-test
+[ t ] [ "\"Circus Maximus\"" quoted? ] unit-test
+[ t ] [ "'Circus Maximus'" quoted? ] unit-test
+[ f ] [ "Circus Maximus" quoted? ] unit-test
diff --git a/basis/regexp/compiler/compiler.factor b/basis/regexp/compiler/compiler.factor
index 6c7896dcca..5482734865 100644
--- a/basis/regexp/compiler/compiler.factor
+++ b/basis/regexp/compiler/compiler.factor
@@ -84,21 +84,24 @@ C: <box> box
{ } assoc-like [ first integer? ] partition
[ [ literals>cases ] keep ] dip non-literals>dispatch ;
-:: step ( last-match index str quot final? direction -- last-index/f )
+: advance ( index backwards? -- index+/-1 )
+ -1 1 ? + >fixnum ; inline
+
+: check ( index string backwards? -- in-bounds? )
+ [ drop -1 eq? not ] [ length < ] if ; inline
+
+:: step ( last-match index str quot final? backwards? -- last-index/f )
final? index last-match ?
- index str bounds-check? [
- index direction + str
+ index str backwards? check [
+ index backwards? advance str
index str nth-unsafe
quot call
] when ; inline
-: direction ( -- n )
- backwards? get -1 1 ? ;
-
: transitions>quot ( transitions final-state? -- quot )
dup shortest? get and [ 2drop [ drop nip ] ] [
- [ split-literals swap case>quot ] dip direction
- '[ { array-capacity string } declare _ _ _ step ]
+ [ split-literals swap case>quot ] dip backwards? get
+ '[ { fixnum string } declare _ _ _ step ]
] if ;
: word>quot ( word dfa -- quot )
@@ -122,10 +125,13 @@ C: <box> box
: dfa>main-word ( dfa -- word )
states>words [ states>code ] keep start-state>> ;
+: word-template ( quot -- quot' )
+ '[ drop [ f ] 2dip over array-capacity? _ [ 2drop ] if ] ;
+
PRIVATE>
: dfa>word ( dfa -- quot )
- dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
+ dfa>main-word execution-quot word-template
(( start-index string regexp -- i/f )) define-temp ;
: dfa>shortest-word ( dfa -- word )
diff --git a/basis/roman/roman-docs.factor b/basis/roman/roman-docs.factor
index 4a8197f064..bef0ab90fc 100644
--- a/basis/roman/roman-docs.factor
+++ b/basis/roman/roman-docs.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel math ;
+USING: help.markup help.syntax kernel math strings ;
IN: roman
HELP: >roman
@@ -39,7 +39,7 @@ HELP: roman>
{ >roman >ROMAN roman> } related-words
HELP: roman+
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
{ $description "Adds two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
@@ -49,7 +49,7 @@ HELP: roman+
} ;
HELP: roman-
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
{ $description "Subtracts two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
@@ -61,7 +61,7 @@ HELP: roman-
{ roman+ roman- } related-words
HELP: roman*
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
{ $description "Multiplies two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
@@ -71,7 +71,7 @@ HELP: roman*
} ;
HELP: roman/i
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } }
{ $description "Computes the integer division of two Roman numerals." }
{ $examples
{ $example "USING: io roman ;"
@@ -81,7 +81,7 @@ HELP: roman/i
} ;
HELP: roman/mod
-{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
+{ $values { "string" string } { "string" string } { "string" string } { "string" string } }
{ $description "Computes the quotient and remainder of two Roman numerals." }
{ $examples
{ $example "USING: kernel io roman ;"
diff --git a/basis/roman/roman-tests.factor b/basis/roman/roman-tests.factor
index 82084e0b1f..a510514e23 100644
--- a/basis/roman/roman-tests.factor
+++ b/basis/roman/roman-tests.factor
@@ -38,3 +38,9 @@ USING: arrays kernel math roman roman.private sequences tools.test ;
[ "iii" "iii" roman- ] must-fail
[ 30 ] [ ROMAN: xxx ] unit-test
+
+[ roman+ ] must-infer
+[ roman- ] must-infer
+[ roman* ] must-infer
+[ roman/i ] must-infer
+[ roman/mod ] must-infer
diff --git a/basis/roman/roman.factor b/basis/roman/roman.factor
index 71343b723d..92202da8ca 100644
--- a/basis/roman/roman.factor
+++ b/basis/roman/roman.factor
@@ -1,29 +1,33 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays assocs kernel math math.order math.vectors
-namespaces make quotations sequences splitting.monotonic
-sequences.private strings unicode.case lexer parser
-grouping ;
+USING: accessors arrays assocs fry generalizations grouping
+kernel lexer macros make math math.order math.vectors
+namespaces parser quotations sequences sequences.private
+splitting.monotonic stack-checker strings unicode.case
+words effects ;
IN: roman
<PRIVATE
-: roman-digits ( -- seq )
- { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
+CONSTANT: roman-digits
+ { "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" }
-: roman-values ( -- seq )
- { 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
+CONSTANT: roman-values
+ { 1000 900 500 400 100 90 50 40 10 9 5 4 1 }
ERROR: roman-range-error n ;
: roman-range-check ( n -- )
dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
+: roman-digit-index ( ch -- n )
+ 1string roman-digits index ; inline
+
: roman<= ( ch1 ch2 -- ? )
- [ 1string roman-digits index ] bi@ >= ;
+ [ roman-digit-index ] bi@ >= ;
: roman>n ( ch -- n )
- 1string roman-digits index roman-values nth ;
+ roman-digit-index roman-values nth ;
: (>roman) ( n -- )
roman-values roman-digits [
@@ -31,47 +35,39 @@ ERROR: roman-range-error n ;
] 2each drop ;
: (roman>) ( seq -- n )
- [ [ roman>n ] map ] [ all-eq? ] bi [
- sum
- ] [
- first2 swap -
- ] if ;
+ [ [ roman>n ] map ] [ all-eq? ] bi
+ [ sum ] [ first2 swap - ] if ;
PRIVATE>
: >roman ( n -- str )
- dup roman-range-check
- [ (>roman) ] "" make ;
+ dup roman-range-check [ (>roman) ] "" make ;
: >ROMAN ( n -- str ) >roman >upper ;
: roman> ( str -- n )
- >lower [ roman<= ] monotonic-split
- [ (roman>) ] sigma ;
+ >lower [ roman<= ] monotonic-split [ (roman>) ] sigma ;
<PRIVATE
-: 2roman> ( str1 str2 -- m n )
- [ roman> ] bi@ ;
-
-: binary-roman-op ( str1 str2 quot -- str3 )
- [ 2roman> ] dip call >roman ; inline
+MACRO: binary-roman-op ( quot -- quot' )
+ [ infer in>> ] [ ] [ infer out>> ] tri
+ '[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
PRIVATE>
-: roman+ ( str1 str2 -- str3 )
- [ + ] binary-roman-op ;
+<<
+SYNTAX: ROMAN-OP:
+ scan-word [ name>> "roman" prepend create-in ] keep
+ 1quotation '[ _ binary-roman-op ]
+ dup infer [ in>> ] [ out>> ] bi
+ [ "string" <repetition> ] bi@ <effect> define-declared ;
+>>
-: roman- ( str1 str2 -- str3 )
- [ - ] binary-roman-op ;
-
-: roman* ( str1 str2 -- str3 )
- [ * ] binary-roman-op ;
-
-: roman/i ( str1 str2 -- str3 )
- [ /i ] binary-roman-op ;
-
-: roman/mod ( str1 str2 -- str3 str4 )
- [ /mod ] binary-roman-op [ >roman ] dip ;
+ROMAN-OP: +
+ROMAN-OP: -
+ROMAN-OP: *
+ROMAN-OP: /i
+ROMAN-OP: /mod
SYNTAX: ROMAN: scan roman> parsed ;
diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor
index 1c7392901b..c07ed8758b 100644
--- a/basis/sorting/human/human.factor
+++ b/basis/sorting/human/human.factor
@@ -11,7 +11,7 @@ IN: sorting.human
: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
-: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ;
+: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; inline
: human-sort ( seq -- seq' ) [ human<=> ] sort ;
diff --git a/basis/specialized-vectors/specialized-vectors-tests.factor b/basis/specialized-vectors/specialized-vectors-tests.factor
index df077ce189..82def17e44 100644
--- a/basis/specialized-vectors/specialized-vectors-tests.factor
+++ b/basis/specialized-vectors/specialized-vectors-tests.factor
@@ -1,5 +1,9 @@
IN: specialized-vectors.tests
-USING: specialized-vectors.double tools.test kernel sequences ;
+USING: specialized-arrays.float
+specialized-vectors.float
+specialized-vectors.double
+tools.test kernel sequences ;
[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test
+[ t ] [ 10 float-array{ } new-resizable float-vector? ] unit-test
\ No newline at end of file
diff --git a/basis/stack-checker/transforms/transforms.factor b/basis/stack-checker/transforms/transforms.factor
index dd36c5a82b..c2b348f5f1 100755
--- a/basis/stack-checker/transforms/transforms.factor
+++ b/basis/stack-checker/transforms/transforms.factor
@@ -154,6 +154,15 @@ CONSTANT: bit-member-max 256
dup sequence? [ memq-quot ] [ drop f ] if
] 1 define-transform
+! Index search
+\ index [
+ dup sequence? [
+ dup length 4 >= [
+ dup length zip >hashtable '[ _ at ]
+ ] [ drop f ] if
+ ] [ drop f ] if
+] 1 define-transform
+
! Shuffling
: nths-quot ( indices -- quot )
[ [ '[ _ swap nth ] ] map ] [ length ] bi
diff --git a/basis/syndication/syndication-docs.factor b/basis/syndication/syndication-docs.factor
index 5604a94dbd..bc9612f55c 100644
--- a/basis/syndication/syndication-docs.factor
+++ b/basis/syndication/syndication-docs.factor
@@ -35,9 +35,9 @@ HELP: download-feed
{ $values { "url" url } { "feed" feed } }
{ $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ;
-HELP: string>feed
-{ $values { "string" string } { "feed" feed } }
-{ $description "Parses a feed in string form." } ;
+HELP: parse-feed
+{ $values { "seq" "a string or a byte array" } { "feed" feed } }
+{ $description "Parses a feed." } ;
HELP: xml>feed
{ $values { "xml" xml } { "feed" feed } }
@@ -58,7 +58,7 @@ $nl
{ $subsection <entry> }
"Reading feeds:"
{ $subsection download-feed }
-{ $subsection string>feed }
+{ $subsection parse-feed }
{ $subsection xml>feed }
"Writing feeds:"
{ $subsection feed>xml }
diff --git a/basis/syndication/syndication-tests.factor b/basis/syndication/syndication-tests.factor
index 616ce2723a..3ea037352c 100644
--- a/basis/syndication/syndication-tests.factor
+++ b/basis/syndication/syndication-tests.factor
@@ -1,4 +1,4 @@
-USING: syndication io kernel io.files tools.test io.encodings.utf8
+USING: syndication io kernel io.files tools.test io.encodings.binary
calendar urls xml.writer ;
IN: syndication.tests
@@ -8,7 +8,7 @@ IN: syndication.tests
: load-news-file ( filename -- feed )
#! Load an news syndication file and process it, returning
#! it as an feed tuple.
- utf8 file-contents string>feed ;
+ binary file-contents parse-feed ;
[ T{
feed
diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor
index 9901fd4ce4..e30cd6826c 100755
--- a/basis/syndication/syndication.factor
+++ b/basis/syndication/syndication.factor
@@ -1,11 +1,11 @@
! Copyright (C) 2006 Chris Double, Daniel Ehrenberg.
-! Portions copyright (C) 2008 Slava Pestov.
+! Portions copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: xml.traversal kernel assocs math.order
- strings sequences xml.data xml.writer
- io.streams.string combinators xml xml.entities.html io.files io
- http.client namespaces make xml.syntax hashtables
- calendar.format accessors continuations urls present ;
+USING: xml.traversal kernel assocs math.order strings sequences
+xml.data xml.writer io.streams.string combinators xml
+xml.entities.html io.files io http.client namespaces make
+xml.syntax hashtables calendar.format accessors continuations
+urls present byte-arrays ;
IN: syndication
: any-tag-named ( tag names -- tag-inside )
@@ -106,12 +106,15 @@ TUPLE: entry title url description date ;
{ "feed" [ atom1.0 ] }
} case ;
-: string>feed ( string -- feed )
- [ string>xml xml>feed ] with-html-entities ;
+GENERIC: parse-feed ( seq -- feed )
+
+M: string parse-feed [ string>xml xml>feed ] with-html-entities ;
+
+M: byte-array parse-feed [ bytes>xml xml>feed ] with-html-entities ;
: download-feed ( url -- feed )
#! Retrieve an news syndication file, return as a feed tuple.
- http-get nip string>feed ;
+ http-get nip parse-feed ;
! Atom generation
diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 55433299ad..8ee0393091 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -157,6 +157,7 @@ IN: tools.deploy.shaker
"specializer"
"step-into"
"step-into?"
+ "superclass"
"transform-n"
"transform-quot"
"tuple-dispatch-generic"
diff --git a/basis/tools/scaffold/scaffold-docs.factor b/basis/tools/scaffold/scaffold-docs.factor
index 4d1240ad38..621933bfa8 100644
--- a/basis/tools/scaffold/scaffold-docs.factor
+++ b/basis/tools/scaffold/scaffold-docs.factor
@@ -26,7 +26,7 @@ HELP: scaffold-undocumented
HELP: scaffold-vocab
{ $values
{ "vocab-root" "a vocabulary root string" } { "string" string } }
-{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
+{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file and an authors.txt file." } ;
HELP: scaffold-emacs
{ $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ;
diff --git a/basis/tools/scaffold/scaffold-tests.factor b/basis/tools/scaffold/scaffold-tests.factor
new file mode 100644
index 0000000000..4c8698c114
--- /dev/null
+++ b/basis/tools/scaffold/scaffold-tests.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test tools.scaffold unicode.case kernel
+multiline tools.scaffold.private io.streams.string ;
+IN: tools.scaffold.tests
+
+: undocumented-word ( obj1 obj2 -- obj3 obj4 )
+ [ >lower ] [ >upper ] bi* ;
+
+[
+<" HELP: undocumented-word
+{ $values
+ { "obj1" object } { "obj2" object }
+ { "obj3" object } { "obj4" object }
+}
+{ $description "" } ;
+">
+]
+[
+ [ \ undocumented-word (help.) ] with-string-writer
+] unit-test
diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor
index 6280f993cc..73e896d5ff 100755
--- a/basis/tools/scaffold/scaffold.factor
+++ b/basis/tools/scaffold/scaffold.factor
@@ -134,7 +134,7 @@ ERROR: no-vocab vocab ;
vocabulary>> using get [ conjoin ] [ drop ] if* ;
: ($values.) ( array -- )
- [
+ [ bl ] [
"{ " write
dup array? [ first ] when
dup lookup-type [
@@ -145,7 +145,7 @@ ERROR: no-vocab vocab ;
null add-using
] if
" }" write
- ] each ;
+ ] interleave ;
: 4bl ( -- )
" " write ; inline
diff --git a/basis/ui/gadgets/debug/debug.factor b/basis/ui/gadgets/debug/debug.factor
index f8d496c1fc..786a97f689 100644
--- a/basis/ui/gadgets/debug/debug.factor
+++ b/basis/ui/gadgets/debug/debug.factor
@@ -58,7 +58,7 @@ M: metrics-paint draw-boundary
COLOR: red gl-color
[ dim>> ] [ >label< line-metrics ] bi
[ [ first ] [ ascent>> ] bi* [ nip 0 swap 2array ] [ 2array ] 2bi gl-line ]
- [ drop gl-rect ]
+ [ drop { 0 0 } swap gl-rect ]
2bi ;
: <metrics-gadget> ( text font -- gadget )
diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index 55622503b6..f5b7f63d22 100755
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -172,11 +172,10 @@ TUPLE: selected-line start end first? last? ;
:: draw-selection ( line pair editor -- )
pair [ editor font>> line offset>x ] map :> pair
- pair first 0 2array [
- editor selection-color>> gl-color
- pair second pair first - round 1 max
- editor line-height 2array gl-fill-rect
- ] with-translation ;
+ editor selection-color>> gl-color
+ pair first 0 2array
+ pair second pair first - round 1 max editor line-height 2array
+ gl-fill-rect ;
: draw-unselected-line ( line editor -- )
font>> swap draw-text ;
diff --git a/basis/ui/gadgets/grids/grids-tests.factor b/basis/ui/gadgets/grids/grids-tests.factor
index fb92cd2ac6..b83f1a7003 100644
--- a/basis/ui/gadgets/grids/grids-tests.factor
+++ b/basis/ui/gadgets/grids/grids-tests.factor
@@ -3,9 +3,6 @@ namespaces math.rectangles accessors ui.gadgets.grids.private
ui.gadgets.debug sequences ;
IN: ui.gadgets.grids.tests
-[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
-[ { 1 2 } { "a" "b" } cross-zip ] unit-test
-
[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
: 100x100 ( -- gadget ) <gadget> { 100 100 } >>dim ;
diff --git a/basis/ui/gadgets/grids/grids.factor b/basis/ui/gadgets/grids/grids.factor
index 4ab080464b..ddcfa1465d 100644
--- a/basis/ui/gadgets/grids/grids.factor
+++ b/basis/ui/gadgets/grids/grids.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.order namespaces make sequences words io
+USING: arrays kernel math math.order math.matrices namespaces make sequences words io
math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
math.rectangles fry ;
IN: ui.gadgets.grids
@@ -33,9 +33,6 @@ PRIVATE>
<PRIVATE
-: cross-zip ( seq1 seq2 -- seq1xseq2 )
- [ [ 2array ] with map ] curry map ;
-
TUPLE: cell pref-dim baseline cap-height ;
: <cell> ( gadget -- cell )
@@ -116,7 +113,7 @@ M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ;
M: grid children-on ( rect gadget -- seq )
dup children>> empty? [ 2drop f ] [
- { 0 1 } swap grid>>
+ [ { 0 1 } ] dip grid>>
[ 0 <column> fast-children-on ] keep
<slice> concat
] if ;
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index 44da013f2c..a6bd5c4e29 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -79,9 +79,7 @@ GENERIC: draw-selection ( loc obj -- )
M: gadget draw-selection ( loc gadget -- )
swap offset-rect [
- dup loc>> [
- dim>> gl-fill-rect
- ] with-translation
+ rect-bounds gl-fill-rect
] if-fits ;
M: node draw-selection ( loc node -- )
diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor
index 7b1befc539..f2ed5b10e0 100644
--- a/basis/ui/gadgets/tables/tables.factor
+++ b/basis/ui/gadgets/tables/tables.factor
@@ -121,16 +121,15 @@ M: table layout*
[ [ line-height ] dip * 0 swap 2array ]
[ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
-: highlight-row ( table row color quot -- )
- [ [ row-rect rect-bounds ] dip gl-color ] dip
- '[ _ @ ] with-translation ; inline
+: row-bounds ( table row -- loc dim )
+ row-rect rect-bounds ; inline
: draw-selected-row ( table -- )
{
{ [ dup selected-index>> not ] [ drop ] }
[
- [ ] [ selected-index>> ] [ selection-color>> ] tri
- [ gl-fill-rect ] highlight-row
+ [ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
+ row-bounds gl-fill-rect
]
} cond ;
@@ -139,14 +138,15 @@ M: table layout*
{ [ dup focused?>> not ] [ drop ] }
{ [ dup selected-index>> not ] [ drop ] }
[
- [ ] [ selected-index>> ] [ focus-border-color>> ] tri
- [ gl-rect ] highlight-row
+ [ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri
+ row-bounds gl-rect
]
} cond ;
: draw-moused-row ( table -- )
dup mouse-index>> dup [
- over mouse-color>> [ gl-rect ] highlight-row
+ over mouse-color>> gl-color
+ row-bounds gl-rect
] [ 2drop ] if ;
: column-line-offsets ( table -- xs )
@@ -279,7 +279,7 @@ PRIVATE>
: row-action ( table -- )
dup selected-row
- [ swap [ action>> call ] [ dup hook>> call ] bi ]
+ [ swap [ action>> call( value -- ) ] [ dup hook>> call( table -- ) ] bi ]
[ 2drop ]
if ;
diff --git a/basis/ui/pens/solid/solid.factor b/basis/ui/pens/solid/solid.factor
index 950035e773..fe44a8f341 100644
--- a/basis/ui/pens/solid/solid.factor
+++ b/basis/ui/pens/solid/solid.factor
@@ -9,8 +9,8 @@ TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
M: solid recompute-pen
swap dim>>
- [ (fill-rect-vertices) >>interior-vertices ]
- [ (rect-vertices) >>boundary-vertices ]
+ [ [ { 0 0 } ] dip (fill-rect-vertices) >>interior-vertices ]
+ [ [ { 0 0 } ] dip (rect-vertices) >>boundary-vertices ]
bi drop ;
<PRIVATE
diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index e41bfa5345..4c8f7c24e5 100755
--- a/basis/ui/render/render.factor
+++ b/basis/ui/render/render.factor
@@ -38,7 +38,7 @@ SYMBOL: viewport-translation
! white gl-clear is broken w.r.t window resizing
! Linux/PPC Radeon 9200
COLOR: white gl-color
- clip get dim>> gl-fill-rect ;
+ { 0 0 } clip get dim>> gl-fill-rect ;
GENERIC: draw-gadget* ( gadget -- )
diff --git a/basis/ui/tools/browser/browser-docs.factor b/basis/ui/tools/browser/browser-docs.factor
index 03a5218e45..b07e72dbce 100644
--- a/basis/ui/tools/browser/browser-docs.factor
+++ b/basis/ui/tools/browser/browser-docs.factor
@@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.commands ;
IN: ui.tools.browser
ARTICLE: "ui-browser" "UI browser"
-"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or articlelink presentation is clicked. It can also be opened using words:"
+"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or article link presentation is clicked. It can also be opened using words:"
{ $subsection com-browse }
{ $subsection browser-window }
{ $command-map browser-gadget "toolbar" }
diff --git a/basis/ui/tools/listener/listener.factor b/basis/ui/tools/listener/listener.factor
index 91448dfe10..7cb3c70cbc 100644
--- a/basis/ui/tools/listener/listener.factor
+++ b/basis/ui/tools/listener/listener.factor
@@ -263,8 +263,9 @@ M: listener-operation invoke-command ( target command -- )
: listener-run-files ( seq -- )
[
- [ \ listener-run-files ] dip
- '[ _ [ run-file ] each ] call-listener
+ '[ _ [ run-file ] each ]
+ \ listener-run-files
+ call-listener
] unless-empty ;
: com-end ( listener -- )
diff --git a/basis/ui/tools/operations/operations.factor b/basis/ui/tools/operations/operations.factor
index 28781e24bb..c6371ac8aa 100644
--- a/basis/ui/tools/operations/operations.factor
+++ b/basis/ui/tools/operations/operations.factor
@@ -81,8 +81,6 @@ IN: ui.tools.operations
{ +listener+ t }
} define-operation
-UNION: definition word method-spec link vocab vocab-link ;
-
[ definition? ] \ edit H{
{ +keyboard+ T{ key-down f { C+ } "e" } }
{ +listener+ t }
diff --git a/basis/unicode/breaks/breaks-tests.factor b/basis/unicode/breaks/breaks-tests.factor
index 493c2db0c2..3a26b01213 100644
--- a/basis/unicode/breaks/breaks-tests.factor
+++ b/basis/unicode/breaks/breaks-tests.factor
@@ -9,6 +9,9 @@ IN: unicode.breaks.tests
[ 3 ] [ "\u001112\u001161\u0011abA\u000300a"
dup last-grapheme head last-grapheme ] unit-test
+[ 3 ] [ 2 "hello" first-grapheme-from ] unit-test
+[ 1 ] [ 2 "hello" last-grapheme-from ] unit-test
+
: grapheme-break-test ( -- filename )
"vocab:unicode/breaks/GraphemeBreakTest.txt" ;
diff --git a/basis/unicode/breaks/breaks.factor b/basis/unicode/breaks/breaks.factor
index 22d6cddfb9..1b1d9434f8 100644
--- a/basis/unicode/breaks/breaks.factor
+++ b/basis/unicode/breaks/breaks.factor
@@ -60,7 +60,7 @@ SYMBOL: table
: finish-table ( -- table )
table get [ [ 1 = ] map ] map ;
-: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
+: eval-seq ( seq -- seq ) [ ?execute ] map ;
: (set-table) ( class1 class2 val -- )
[ table get nth ] dip '[ _ or ] change-nth ;
@@ -101,6 +101,16 @@ PRIVATE>
[ grapheme-class [ nip ] [ grapheme-break? ] 2bi ] find drop
nip swap length or 1+ ;
+: first-grapheme-from ( start str -- i )
+ over tail-slice first-grapheme + ;
+
+: last-grapheme ( str -- i )
+ unclip-last-slice grapheme-class swap
+ [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
+
+: last-grapheme-from ( end str -- i )
+ swap head-slice last-grapheme ;
+
<PRIVATE
: >pieces ( str quot: ( str -- i ) -- graphemes )
@@ -114,10 +124,6 @@ PRIVATE>
: string-reverse ( str -- rts )
>graphemes reverse concat ;
-: last-grapheme ( str -- i )
- unclip-last-slice grapheme-class swap
- [ grapheme-class dup rot grapheme-break? ] find-last drop ?1+ nip ;
-
<PRIVATE
graphemes init-table table
diff --git a/basis/xmode/code2html/code2html-tests.factor b/basis/xmode/code2html/code2html-tests.factor
index 241ab7ff75..8d5db4a6e9 100644
--- a/basis/xmode/code2html/code2html-tests.factor
+++ b/basis/xmode/code2html/code2html-tests.factor
@@ -18,4 +18,12 @@ kernel io.streams.string xml.writer ;
<" int x = "hi";
/* a comment */ "> <string-reader> htmlize-stream
write-xml
+] unit-test
+
+[ "<span class=\"MARKUP\">: foo</span> <span class=\"MARKUP\">;</span>" ] [
+ { ": foo ;" } "factor" htmlize-lines xml>string
+] unit-test
+
+[ ":foo" ] [
+ { ":foo" } "factor" htmlize-lines xml>string
] unit-test
\ No newline at end of file
diff --git a/basis/xmode/marker/marker.factor b/basis/xmode/marker/marker.factor
index f584756f33..b4c1cd6a48 100755
--- a/basis/xmode/marker/marker.factor
+++ b/basis/xmode/marker/marker.factor
@@ -84,7 +84,7 @@ M: string-matcher text-matches?
] keep string>> length and ;
M: regexp text-matches?
- [ >string ] dip re-contains? ;
+ [ >string ] dip first-match dup [ to>> ] when ;
: rule-start-matches? ( rule -- match-count/f )
dup start>> tuck swap can-match-here? [
diff --git a/core/definitions/definitions.factor b/core/definitions/definitions.factor
index 434b133b3f..c95c5816ac 100644
--- a/core/definitions/definitions.factor
+++ b/core/definitions/definitions.factor
@@ -3,6 +3,8 @@
USING: kernel sequences namespaces assocs graphs math math.order ;
IN: definitions
+MIXIN: definition
+
ERROR: no-compilation-unit definition ;
SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor
index b9cb0ddcc9..c8ed6da2aa 100644
--- a/core/effects/parser/parser.factor
+++ b/core/effects/parser/parser.factor
@@ -15,6 +15,7 @@ ERROR: bad-effect ;
scan {
{ "(" [ ")" parse-effect ] }
{ f [ ")" unexpected-eof ] }
+ [ bad-effect ]
} case 2array
] when
] if
@@ -31,4 +32,4 @@ ERROR: bad-effect ;
"(" expect ")" parse-effect ;
: parse-call( ( accum word -- accum )
- [ ")" parse-effect ] dip 2array over push-all ;
\ No newline at end of file
+ [ ")" parse-effect ] dip 2array over push-all ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 8380a41207..c22641d439 100644
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors words kernel sequences namespaces make assocs
hashtables definitions kernel.private classes classes.private
@@ -27,6 +27,8 @@ M: generic definition drop f ;
PREDICATE: method-spec < pair
first2 generic? swap class? and ;
+INSTANCE: method-spec definition
+
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
diff --git a/core/hashtables/hashtables.factor b/core/hashtables/hashtables.factor
index 8aa13a5f5e..f95a7a7e67 100644
--- a/core/hashtables/hashtables.factor
+++ b/core/hashtables/hashtables.factor
@@ -79,7 +79,7 @@ TUPLE: hashtable
: grow-hash ( hash -- )
[ [ >alist ] [ assoc-size 1+ ] bi ] keep
[ reset-hash ] keep
- swap (rehash) ; inline
+ swap (rehash) ;
: ?grow-hash ( hash -- )
dup hash-large? [
@@ -95,7 +95,7 @@ TUPLE: hashtable
PRIVATE>
: <hashtable> ( n -- hash )
- hashtable new [ reset-hash ] keep ;
+ hashtable new [ reset-hash ] keep ; inline
M: hashtable at* ( key hash -- value ? )
key@ [ 3 fixnum+fast slot t ] [ 2drop f f ] if ;
diff --git a/core/io/streams/sequence/sequence.factor b/core/io/streams/sequence/sequence.factor
index f455512ed3..0f922a37cc 100644
--- a/core/io/streams/sequence/sequence.factor
+++ b/core/io/streams/sequence/sequence.factor
@@ -15,11 +15,10 @@ SLOT: i
[ 1+ ] change-i drop ; inline
: sequence-read1 ( stream -- elt/f )
- [ >sequence-stream< ?nth ]
- [ next ] bi ; inline
+ [ >sequence-stream< ?nth ] [ next ] bi ; inline
: add-length ( n stream -- i+n )
- [ i>> + ] [ underlying>> length ] bi min ; inline
+ [ i>> + ] [ underlying>> length ] bi min ; inline
: (sequence-read) ( n stream -- seq/f )
[ add-length ] keep
@@ -32,8 +31,8 @@ SLOT: i
[ (sequence-read) ] [ 2drop f ] if ; inline
: find-sep ( seps stream -- sep/f n )
- swap [ >sequence-stream< ] dip
- [ memq? ] curry find-from swap ; inline
+ swap [ >sequence-stream< swap tail-slice ] dip
+ [ memq? ] curry find swap ; inline
: sequence-read-until ( separators stream -- seq sep/f )
[ find-sep ] keep
diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor
index 56f19595cb..baccf56059 100644
--- a/core/kernel/kernel.factor
+++ b/core/kernel/kernel.factor
@@ -23,6 +23,10 @@ GENERIC: call ( callable -- )
GENERIC: execute ( word -- )
+GENERIC: ?execute ( word -- value )
+
+M: object ?execute ;
+
DEFER: if
: ? ( ? true false -- true/false )
diff --git a/core/namespaces/namespaces.factor b/core/namespaces/namespaces.factor
index 623e2ddcda..b0e764c94d 100644
--- a/core/namespaces/namespaces.factor
+++ b/core/namespaces/namespaces.factor
@@ -30,6 +30,6 @@ PRIVATE>
: bind ( ns quot -- ) swap >n call ndrop ; inline
: counter ( variable -- n ) global [ 0 or 1+ dup ] change-at ;
: make-assoc ( quot exemplar -- hash ) 20 swap new-assoc [ swap bind ] keep ; inline
-: with-scope ( quot -- ) H{ } clone swap bind ; inline
+: with-scope ( quot -- ) 5 <hashtable> swap bind ; inline
: with-variable ( value key quot -- ) [ associate ] dip bind ; inline
: initialize ( variable quot -- ) [ global ] dip [ unless* ] curry change-at ; inline
\ No newline at end of file
diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor
index 6a7e8116cd..df9eb568f6 100644
--- a/core/syntax/syntax-docs.factor
+++ b/core/syntax/syntax-docs.factor
@@ -556,18 +556,18 @@ HELP: BIN:
{ $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ;
HELP: GENERIC:
-{ $syntax "GENERIC: word" "GENERIC: word ( stack -- effect )" }
+{ $syntax "GENERIC: word ( stack -- effect )" }
{ $values { "word" "a new word to define" } }
{ $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ;
HELP: GENERIC#
-{ $syntax "GENERIC# word n" "GENERIC# word n ( stack -- effect )" }
+{ $syntax "GENERIC# word n ( stack -- effect )" }
{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } }
{ $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
{ $notes
"The following two definitions are equivalent:"
- { $code "GENERIC: foo" }
- { $code "GENERIC# foo 0" }
+ { $code "GENERIC: foo ( obj -- )" }
+ { $code "GENERIC# foo 0 ( obj -- )" }
} ;
HELP: MATH:
@@ -576,7 +576,7 @@ HELP: MATH:
{ $description "Defines a new generic word which uses the " { $link math-combination } " method combination." } ;
HELP: HOOK:
-{ $syntax "HOOK: word variable" "HOOK: word variable ( stack -- effect ) " }
+{ $syntax "HOOK: word variable ( stack -- effect ) " }
{ $values { "word" "a new word to define" } { "variable" word } }
{ $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." }
{ $examples
diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor
index bcf9decdf3..cb5cdfd5ac 100644
--- a/core/syntax/syntax.factor
+++ b/core/syntax/syntax.factor
@@ -138,7 +138,7 @@ IN: bootstrap.syntax
] define-core-syntax
"CONSTANT:" [
- CREATE scan-object define-constant
+ CREATE-WORD scan-object define-constant
] define-core-syntax
":" [
diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor
index edac418285..2b978e8666 100644
--- a/core/vocabs/vocabs.factor
+++ b/core/vocabs/vocabs.factor
@@ -108,4 +108,6 @@ SYMBOL: load-vocab-hook ! ( name -- vocab )
: load-vocab ( name -- vocab ) load-vocab-hook get call( name -- vocab ) ;
PREDICATE: runnable-vocab < vocab
- vocab-main >boolean ;
\ No newline at end of file
+ vocab-main >boolean ;
+
+INSTANCE: vocab-spec definition
\ No newline at end of file
diff --git a/core/words/alias/alias-tests.factor b/core/words/alias/alias-tests.factor
new file mode 100644
index 0000000000..0278a4d4b9
--- /dev/null
+++ b/core/words/alias/alias-tests.factor
@@ -0,0 +1,6 @@
+USING: math eval tools.test effects ;
+IN: words.alias.tests
+
+ALIAS: foo +
+[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
+[ (( -- value )) ] [ \ foo stack-effect ] unit-test
\ No newline at end of file
diff --git a/core/words/words.factor b/core/words/words.factor
index cfdcd4517f..5b230c1b00 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -12,6 +12,8 @@ IN: words
M: word execute (execute) ;
+M: word ?execute execute( -- value ) ;
+
M: word <=>
[ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
@@ -260,3 +262,5 @@ M: word hashcode*
M: word literalize <wrapper> ;
: xref-words ( -- ) all-words [ xref ] each ;
+
+INSTANCE: word definition
\ No newline at end of file
diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor
index 0f8b5581df..f06bc2fb81 100644
--- a/extra/bank/bank.factor
+++ b/extra/bank/bank.factor
@@ -59,11 +59,11 @@ C: <transaction> transaction
[ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
] [
3drop
- ] if ;
+ ] if ; inline recursive
: process-to-date ( account date -- account )
over interest-last-paid>> 1 days time+
- [ dupd process-day ] spin each-day ;
+ [ dupd process-day ] spin each-day ; inline
: inserting-transactions ( account transactions -- account )
[ [ date>> process-to-date ] keep >>transaction ] each ;
diff --git a/extra/cap/cap.factor b/extra/cap/cap.factor
index 64696759bb..f43787673a 100644
--- a/extra/cap/cap.factor
+++ b/extra/cap/cap.factor
@@ -1,8 +1,8 @@
! Copyright (C) 2008 Doug Coleman, Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays kernel math namespaces
-opengl.gl sequences math.vectors ui images images.viewer
-models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
+opengl.gl sequences math.vectors ui images images.normalization
+images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
IN: cap
: screenshot-array ( world -- byte-array )
diff --git a/extra/game-input/game-input-tests.factor b/extra/game-input/game-input-tests.factor
index 69b40dbec7..2bf923c12b 100644
--- a/extra/game-input/game-input-tests.factor
+++ b/extra/game-input/game-input-tests.factor
@@ -1,8 +1,12 @@
IN: game-input.tests
-USING: game-input tools.test kernel system threads ;
+USING: ui game-input tools.test kernel system threads
+combinators.short-circuit calendar ;
-os windows? os macosx? or [
+{
+ [ os windows? ui-running? and ]
+ [ os macosx? ]
+} 0|| [
[ ] [ open-game-input ] unit-test
- [ ] [ yield ] unit-test
+ [ ] [ 1 seconds sleep ] unit-test
[ ] [ close-game-input ] unit-test
] when
\ No newline at end of file
diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 60e5ddbf54..94ef59bdfd 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -1,10 +1,12 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays html.parser.utils hashtables io kernel
-namespaces make prettyprint quotations sequences splitting
-html.parser.state strings unicode.categories unicode.case ;
+USING: accessors arrays hashtables html.parser.state
+html.parser.utils kernel make namespaces sequences
+unicode.case unicode.categories combinators.short-circuit
+quoting ;
IN: html.parser
+
TUPLE: tag name attributes text closing? ;
SINGLETON: text
@@ -28,116 +30,103 @@ SYMBOL: tagstack
: make-tag ( string attribs -- tag )
[ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
-: make-text-tag ( string -- tag )
+: new-tag ( string type -- tag )
tag new
- text >>name
- swap >>text ;
+ swap >>name
+ swap >>text ; inline
-: make-comment-tag ( string -- tag )
- tag new
- comment >>name
- swap >>text ;
+: make-text-tag ( string -- tag ) text new-tag ; inline
-: make-dtd-tag ( string -- tag )
- tag new
- dtd >>name
- swap >>text ;
+: make-comment-tag ( string -- tag ) comment new-tag ; inline
-: read-whitespace ( -- string )
- [ get-char blank? not ] take-until ;
+: make-dtd-tag ( string -- tag ) dtd new-tag ; inline
-: read-whitespace* ( -- ) read-whitespace drop ;
+: read-single-quote ( state-parser -- string )
+ [ [ CHAR: ' = ] take-until ] [ next drop ] bi ;
-: read-token ( -- string )
- read-whitespace*
- [ get-char blank? ] take-until ;
+: read-double-quote ( state-parser -- string )
+ [ [ CHAR: " = ] take-until ] [ next drop ] bi ;
-: read-single-quote ( -- string )
- [ get-char CHAR: ' = ] take-until ;
+: read-quote ( state-parser -- string )
+ dup get+increment CHAR: ' =
+ [ read-single-quote ] [ read-double-quote ] if ;
-: read-double-quote ( -- string )
- [ get-char CHAR: " = ] take-until ;
+: read-key ( state-parser -- string )
+ skip-whitespace
+ [ { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
-: read-quote ( -- string )
- get-char next CHAR: ' =
- [ read-single-quote ] [ read-double-quote ] if next ;
+: read-= ( state-parser -- )
+ skip-whitespace
+ [ [ CHAR: = = ] take-until drop ] [ next drop ] bi ;
-: read-key ( -- string )
- read-whitespace*
- [ get-char [ CHAR: = = ] [ blank? ] bi or ] take-until ;
+: read-token ( state-parser -- string )
+ [ blank? ] take-until ;
-: read-= ( -- )
- read-whitespace*
- [ get-char CHAR: = = ] take-until drop next ;
-
-: read-value ( -- string )
- read-whitespace*
- get-char quote? [ read-quote ] [ read-token ] if
+: read-value ( state-parser -- string )
+ skip-whitespace
+ dup get-char quote? [ read-quote ] [ read-token ] if
[ blank? ] trim ;
-: read-comment ( -- )
- "-->" take-string make-comment-tag push-tag ;
+: read-comment ( state-parser -- )
+ "-->" take-until-sequence make-comment-tag push-tag ;
-: read-dtd ( -- )
- ">" take-string make-dtd-tag push-tag ;
+: read-dtd ( state-parser -- )
+ ">" take-until-sequence make-dtd-tag push-tag ;
-: read-bang ( -- )
- next get-char CHAR: - = get-next CHAR: - = and [
+: read-bang ( state-parser -- )
+ next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [
next next
read-comment
] [
read-dtd
] if ;
-: read-tag ( -- string )
- [ get-char CHAR: > = get-char CHAR: < = or ] take-until
- get-char CHAR: < = [ next ] unless ;
+: read-tag ( state-parser -- string )
+ [ [ "><" member? ] take-until ]
+ [ dup get-char CHAR: < = [ next ] unless drop ] bi ;
-: read-< ( -- string )
- next get-char CHAR: ! = [
- read-bang f
+: read-until-< ( state-parser -- string )
+ [ CHAR: < = ] take-until ;
+
+: parse-text ( state-parser -- )
+ read-until-< [ make-text-tag push-tag ] unless-empty ;
+
+: (parse-attributes) ( state-parser -- )
+ skip-whitespace
+ dup state-parse-end? [
+ drop
] [
- read-tag
+ [
+ [ read-key >lower ] [ read-= ] [ read-value ] tri
+ 2array ,
+ ] keep (parse-attributes)
] if ;
-: read-until-< ( -- string )
- [ get-char CHAR: < = ] take-until ;
-
-: parse-text ( -- )
- read-until-< [
- make-text-tag push-tag
- ] unless-empty ;
-
-: (parse-attributes) ( -- )
- read-whitespace*
- string-parse-end? [
- read-key >lower read-= read-value
- 2array , (parse-attributes)
- ] unless ;
-
-: parse-attributes ( -- hashtable )
+: parse-attributes ( state-parser -- hashtable )
[ (parse-attributes) ] { } make >hashtable ;
: (parse-tag) ( string -- string' hashtable )
[
- read-token >lower
- parse-attributes
- ] string-parse ;
+ [ read-token >lower ] [ parse-attributes ] bi
+ ] state-parse ;
-: parse-tag ( -- )
- read-< [
- (parse-tag) make-tag push-tag
- ] unless-empty ;
+: read-< ( state-parser -- string/f )
+ next dup get-char [
+ CHAR: ! = [ read-bang f ] [ read-tag ] if
+ ] [
+ drop f
+ ] if* ;
-: (parse-html) ( -- )
- get-next [
- parse-text
- parse-tag
- (parse-html)
- ] when ;
+: parse-tag ( state-parser -- )
+ read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
+
+: (parse-html) ( state-parser -- )
+ dup get-next [
+ [ parse-text ] [ parse-tag ] [ (parse-html) ] tri
+ ] [ drop ] if ;
: tag-parse ( quot -- vector )
- V{ } clone tagstack [ string-parse ] with-variable ; inline
+ V{ } clone tagstack [ state-parse ] with-variable ; inline
: parse-html ( string -- vector )
[ (parse-html) tagstack get ] tag-parse ;
diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index da70d0fa12..f9862e1e69 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -1,14 +1,36 @@
-USING: tools.test html.parser.state ascii kernel ;
+USING: tools.test html.parser.state ascii kernel accessors ;
IN: html.parser.state.tests
-: take-rest ( -- string )
- [ f ] take-until ;
+[ "hello" ]
+[ "hello" [ take-rest ] state-parse ] unit-test
-: take-char ( -- string )
- [ get-char = ] curry take-until ;
+[ "hi" " how are you?" ]
+[
+ "hi how are you?"
+ [ [ [ blank? ] take-until ] [ take-rest ] bi ] state-parse
+] unit-test
+
+[ "foo" ";bar" ]
+[
+ "foo;bar" [
+ [ CHAR: ; take-until-object ] [ take-rest ] bi
+ ] state-parse
+] unit-test
-[ "hello" ] [ "hello" [ take-rest ] string-parse ] unit-test
-[ "hi" " how are you?" ] [ "hi how are you?" [ [ get-char blank? ] take-until take-rest ] string-parse ] unit-test
-[ "foo" ";bar" ] [ "foo;bar" [ CHAR: ; take-char take-rest ] string-parse ] unit-test
[ "foo " " bar" ]
-[ "foo and bar" [ "and" take-string take-rest ] string-parse ] unit-test
+[
+ "foo and bar" [
+ [ "and" take-until-sequence ] [ take-rest ] bi
+ ] state-parse
+] unit-test
+
+[ 6 ]
+[
+ " foo " [ skip-whitespace n>> ] state-parse
+] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 } <state-parser> [ 3 = ] take-until ] unit-test
+
+[ { 1 2 } ]
+[ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 1b3f188a78..2369b1d750 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -1,41 +1,67 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces math kernel sequences accessors fry circular ;
+USING: namespaces math kernel sequences accessors fry circular
+unicode.case unicode.categories locals ;
+
IN: html.parser.state
-TUPLE: state string i ;
+TUPLE: state-parser sequence n ;
-: get-i ( -- i ) state get i>> ; inline
+: <state-parser> ( sequence -- state-parser )
+ state-parser new
+ swap >>sequence
+ 0 >>n ;
-: get-char ( -- char )
- state get [ i>> ] [ string>> ] bi ?nth ; inline
+: (get-char) ( n state -- char/f )
+ sequence>> ?nth ; inline
-: get-next ( -- char )
- state get [ i>> 1+ ] [ string>> ] bi ?nth ; inline
+: get-char ( state -- char/f )
+ [ n>> ] keep (get-char) ; inline
-: next ( -- )
- state get [ 1+ ] change-i drop ; inline
+: get-next ( state -- char/f )
+ [ n>> 1 + ] keep (get-char) ; inline
-: string-parse ( string quot -- )
- [ 0 state boa state ] dip with-variable ; inline
+: next ( state -- state )
+ [ 1 + ] change-n ; inline
-: short* ( n seq -- n' seq )
- over [ nip dup length swap ] unless ; inline
+: get+increment ( state -- char/f )
+ [ get-char ] [ next drop ] bi ; inline
-: skip-until ( quot: ( -- ? ) -- )
- get-char [
- [ call ] keep swap
- [ drop ] [ next skip-until ] if
- ] [ drop ] if ; inline recursive
+: state-parse ( sequence quot -- )
+ [ <state-parser> ] dip call ; inline
-: take-until ( quot: ( -- ? ) -- )
- get-i [ skip-until ] dip get-i
- state get string>> subseq ; inline
+:: skip-until ( state quot: ( obj -- ? ) -- )
+ state get-char [
+ quot call [ state next quot skip-until ] unless
+ ] when* ; inline recursive
-: string-matches? ( string circular -- ? )
- get-char over push-growing-circular sequence= ; inline
+: state-parse-end? ( state -- ? ) get-next not ;
-: take-string ( match -- string )
- dup length <growing-circular>
- [ 2dup string-matches? ] take-until nip
- dup length rot length 1- - head next ; inline
+: take-until ( state quot: ( obj -- ? ) -- sequence/f )
+ over state-parse-end? [
+ 2drop f
+ ] [
+ [ drop n>> ]
+ [ skip-until ]
+ [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
+ ] if ; inline
+
+:: take-until-sequence ( state-parser sequence -- sequence' )
+ sequence length <growing-circular> :> growing
+ state-parser
+ [
+ growing push-growing-circular
+ sequence growing sequence=
+ ] take-until :> found
+ found dup length
+ growing length 1- - head
+ state-parser next drop ;
+
+: skip-whitespace ( state -- state )
+ [ [ blank? not ] take-until drop ] keep ;
+
+: take-rest ( state -- sequence )
+ [ drop f ] take-until ; inline
+
+: take-until-object ( state obj -- sequence )
+ '[ _ = ] take-until ;
diff --git a/extra/html/parser/utils/utils-tests.factor b/extra/html/parser/utils/utils-tests.factor
index 6d8e3bc05f..ec6780687d 100644
--- a/extra/html/parser/utils/utils-tests.factor
+++ b/extra/html/parser/utils/utils-tests.factor
@@ -1,20 +1,13 @@
USING: assocs combinators continuations hashtables
hashtables.private io kernel math
namespaces prettyprint quotations sequences splitting
-strings tools.test ;
-USING: html.parser.utils ;
+strings tools.test html.parser.utils quoting ;
IN: html.parser.utils.tests
[ "'Rome'" ] [ "Rome" single-quote ] unit-test
[ "\"Roma\"" ] [ "Roma" double-quote ] unit-test
[ "'Firenze'" ] [ "Firenze" quote ] unit-test
[ "\"Caesar's\"" ] [ "Caesar's" quote ] unit-test
-[ f ] [ "" quoted? ] unit-test
-[ t ] [ "''" quoted? ] unit-test
-[ t ] [ "\"\"" quoted? ] unit-test
-[ t ] [ "\"Circus Maximus\"" quoted? ] unit-test
-[ t ] [ "'Circus Maximus'" quoted? ] unit-test
-[ f ] [ "Circus Maximus" quoted? ] unit-test
[ "'Italy'" ] [ "Italy" ?quote ] unit-test
[ "'Italy'" ] [ "'Italy'" ?quote ] unit-test
[ "\"Italy\"" ] [ "\"Italy\"" ?quote ] unit-test
diff --git a/extra/html/parser/utils/utils.factor b/extra/html/parser/utils/utils.factor
index c913b9d306..7abd2fcdf7 100644
--- a/extra/html/parser/utils/utils.factor
+++ b/extra/html/parser/utils/utils.factor
@@ -3,16 +3,12 @@
USING: assocs circular combinators continuations hashtables
hashtables.private io kernel math namespaces prettyprint
quotations sequences splitting html.parser.state strings
-combinators.short-circuit ;
+combinators.short-circuit quoting ;
IN: html.parser.utils
-: string-parse-end? ( -- ? ) get-next not ;
-
: trim1 ( seq ch -- newseq )
[ [ ?head-slice drop ] [ ?tail-slice drop ] bi ] 2keep drop like ;
-: quote? ( ch -- ? ) "'\"" member? ;
-
: single-quote ( str -- newstr ) "'" dup surround ;
: double-quote ( str -- newstr ) "\"" dup surround ;
@@ -21,14 +17,4 @@ IN: html.parser.utils
CHAR: ' over member?
[ double-quote ] [ single-quote ] if ;
-: quoted? ( str -- ? )
- {
- [ length 1 > ]
- [ first quote? ]
- [ [ first ] [ peek ] bi = ]
- } 1&& ;
-
: ?quote ( str -- newstr ) dup quoted? [ quote ] unless ;
-
-: unquote ( str -- newstr )
- dup quoted? [ but-last-slice rest-slice >string ] when ;
diff --git a/extra/id3/id3-docs.factor b/extra/id3/id3-docs.factor
index d171d03798..feb110fab8 100644
--- a/extra/id3/id3-docs.factor
+++ b/extra/id3/id3-docs.factor
@@ -1,23 +1,113 @@
! Copyright (C) 2008 Tim Wawrzynczak
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax sequences kernel accessors ;
+USING: help.markup help.syntax sequences kernel accessors
+id3.private strings ;
IN: id3
-HELP: file-id3-tags
+HELP: mp3>id3
{ $values
{ "path" "a path string" }
{ "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
- { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: "
- $nl { $link title>> }
- $nl { $link artist>> }
- $nl { $link album>> }
- $nl { $link year>> }
- $nl { $link genre>> }
- $nl { $link comment>> } } ;
+ { $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:"
+ { $list
+ { $link title }
+ { $link artist }
+ { $link album }
+ { $link year }
+ { $link genre }
+ { $link comment }
+ }
+ "For other fields, use the " { $link find-id3-frame } " word."
+ } ;
+
+HELP: album
+{ $values
+ { "id3" id3v2-info }
+ { "album/f" "string or f" }
+}
+{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: artist
+{ $values
+ { "id3" id3v2-info }
+ { "artist/f" "string or f" }
+}
+{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: comment
+{ $values
+ { "id3" id3v2-info }
+ { "comment/f" "string or f" }
+}
+{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: genre
+{ $values
+ { "id3" id3v2-info }
+ { "genre/f" "string or f" }
+}
+{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: title
+{ $values
+ { "id3" id3v2-info }
+ { "title/f" "string or f" }
+}
+{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: year
+{ $values
+ { "id3" id3v2-info }
+ { "year/f" "string or f" }
+}
+{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
+
+HELP: find-id3-frame
+{ $values
+ { "id3" id3v2-info } { "name" string }
+ { "obj/f" "object or f" }
+}
+{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;
+
+HELP: mp3-paths>id3s
+{ $values
+ { "seq" sequence }
+ { "seq'" sequence }
+}
+{ $description "From a sequence of pathnames, parses each ID3 header and returns a sequence of key/value pairs of pathnames and ID3 objects." } ;
+
+HELP: find-mp3s
+{ $values
+ { "path" "a pathname string" }
+ { "seq" sequence }
+}
+{ $description "Returns a sequence of MP3 pathnames from a directory and all of its subdirectories." } ;
+
+HELP: parse-mp3-directory
+{ $values
+ { "path" "a pathname string" }
+ { "seq" sequence }
+}
+{ $description "Returns a sequence of key/value pairs where the key is the path of an MP3 and the value is the parsed ID3 header or " { $link f } " recursively for each MP3 file in the directory and all subdirectories." } ;
ARTICLE: "id3" "ID3 tags"
"The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl
-"Parsing ID3 tags from an MP3 file:"
-{ $subsection file-id3-tags } ;
+"Parsing ID3 tags for a directory of MP3s, recursively:"
+{ $subsection parse-mp3-directory }
+"Finding MP3 files recursively:"
+{ $subsection find-mp3s }
+"Parsing a sequence of MP3 pathnames:"
+{ $subsection mp3-paths>id3s }
+"Parsing an MP3 file's ID3 tags:"
+{ $subsection mp3>id3 }
+"ID3v1 frame tag accessors:"
+{ $subsection album }
+{ $subsection artist }
+{ $subsection comment }
+{ $subsection genre }
+{ $subsection title }
+{ $subsection year }
+"Access any frame tag:"
+{ $subsection find-id3-frame } ;
ABOUT: "id3"
diff --git a/extra/id3/id3-tests.factor b/extra/id3/id3-tests.factor
index aefbec8550..a8f35e582c 100644
--- a/extra/id3/id3-tests.factor
+++ b/extra/id3/id3-tests.factor
@@ -5,12 +5,12 @@ IN: id3.tests
: id3-params ( id3 -- title artist album year comment genre )
{
- [ id3-title ]
- [ id3-artist ]
- [ id3-album ]
- [ id3-year ]
- [ id3-comment ]
- [ id3-genre ]
+ [ title ]
+ [ artist ]
+ [ album ]
+ [ year ]
+ [ comment ]
+ [ genre ]
} cleave ;
[
@@ -20,7 +20,7 @@ IN: id3.tests
"2009"
"COMMENT"
"Bluegrass"
-] [ "vocab:id3/tests/blah.mp3" file-id3-tags id3-params ] unit-test
+] [ "vocab:id3/tests/blah.mp3" mp3>id3 id3-params ] unit-test
[
"Anthem of the Trinity"
@@ -29,7 +29,7 @@ IN: id3.tests
f
f
"Classical"
-] [ "vocab:id3/tests/blah2.mp3" file-id3-tags id3-params ] unit-test
+] [ "vocab:id3/tests/blah2.mp3" mp3>id3 id3-params ] unit-test
[
"Stormy Weather"
@@ -38,5 +38,5 @@ IN: id3.tests
f
"eng, AG# 08E1C12E"
"Big Band"
-] [ "vocab:id3/tests/blah3.mp3" file-id3-tags id3-params ] unit-test
+] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
diff --git a/extra/id3/id3.factor b/extra/id3/id3.factor
index 3def293771..8e824d689f 100644
--- a/extra/id3/id3.factor
+++ b/extra/id3/id3.factor
@@ -48,15 +48,14 @@ TUPLE: id3v2-info header frames ;
TUPLE: id3v1-info title artist album year comment genre ;
-: <id3v1-info> ( -- object ) id3v1-info new ;
+: <id3v1-info> ( -- object ) id3v1-info new ; inline
: <id3v2-info> ( header frames -- object )
- [ [ frame-id>> ] keep ] H{ } map>assoc
- id3v2-info boa ;
+ [ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
-: <header> ( -- object ) header new ;
+: <header> ( -- object ) header new ; inline
-: <frame> ( -- object ) frame new ;
+: <frame> ( -- object ) frame new ; inline
: id3v2? ( mmap -- ? ) "ID3" head? ; inline
@@ -66,7 +65,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
: id3v1-frame ( string key -- frame )
<frame>
swap >>frame-id
- swap >>data ;
+ swap >>data ; inline
: id3v1>id3v2 ( id3v1 -- id3v2 )
[
@@ -78,7 +77,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
[ comment>> "COMM" id3v1-frame ]
[ genre>> "TCON" id3v1-frame ]
} cleave
- ] output>array f swap <id3v2-info> ;
+ ] output>array f swap <id3v2-info> ; inline
: >28bitword ( seq -- int )
0 [ [ 7 shift ] dip bitor ] reduce ; inline
@@ -104,11 +103,11 @@ TUPLE: id3v1-info title artist album year comment genre ;
[ [ 4 8 ] dip subseq >28bitword >>size ]
[ [ 8 10 ] dip subseq >byte-array >>flags ]
[ read-frame-data decode-text >>data ]
- } cleave ;
+ } cleave ; inline
: read-frame ( mmap -- frame/f )
dup 4 head-slice valid-frame-id?
- [ (read-frame) ] [ drop f ] if ;
+ [ (read-frame) ] [ drop f ] if ; inline
: remove-frame ( mmap frame -- mmap )
size>> 10 + tail-slice ; inline
@@ -116,10 +115,8 @@ TUPLE: id3v1-info title artist album year comment genre ;
: read-frames ( mmap -- frames )
[ dup read-frame dup ]
[ [ remove-frame ] keep ]
- produce 2nip ;
+ produce 2nip ; inline
-! header stuff
-
: read-v2-header ( seq -- id3header )
[ <header> ] dip
{
@@ -133,8 +130,6 @@ TUPLE: id3v1-info title artist album year comment genre ;
[ read-v2-header ]
[ read-frames ] bi* <id3v2-info> ; inline
-! v1 information
-
: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
: (read-v1-tag-data) ( seq -- mp3-file )
@@ -159,28 +154,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
drop
] if ; inline
-PRIVATE>
-
-: frame-named ( id3 name quot -- obj )
- [ swap frames>> at* ] dip
- [ data>> ] prepose [ drop f ] if ; inline
-
-: id3-title ( id3 -- title/f ) "TIT2" [ ] frame-named ; inline
-
-: id3-artist ( id3 -- artist/f ) "TPE1" [ ] frame-named ; inline
-
-: id3-album ( id3 -- album/f ) "TALB" [ ] frame-named ; inline
-
-: id3-year ( id3 -- year/f ) "TYER" [ ] frame-named ; inline
-
-: id3-comment ( id3 -- comment/f ) "COMM" [ ] frame-named ; inline
-
-: id3-genre ( id3 -- genre/f )
- "TCON" [ parse-genre ] frame-named ; inline
-
-: id3-frame ( id3 key -- value/f ) [ ] frame-named ; inline
-
-: (file-id3-tags) ( path -- id3v2-info/f )
+: (mp3>id3) ( path -- id3v2-info/f )
[
{
{ [ dup id3v2? ] [ read-v2-tag-data ] }
@@ -189,9 +163,36 @@ PRIVATE>
} cond
] with-mapped-uchar-file ;
-: file-id3-tags ( path -- id3v2-info/f )
- dup file-info size>> 0 <= [ drop f ] [ (file-id3-tags) ] if ;
+: (find-id3-frame) ( id3 name quot: ( obj -- obj' ) -- obj' )
+ [ swap frames>> at* ] dip
+ [ data>> ] prepose [ drop f ] if ; inline
-: parse-id3s ( path -- seq )
- [ >lower ".mp3" tail? ] find-all-files
- [ dup file-id3-tags ] { } map>assoc ;
+PRIVATE>
+
+: mp3>id3 ( path -- id3v2-info/f )
+ dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
+
+: find-id3-frame ( id3 name -- obj/f )
+ [ ] (find-id3-frame) ; inline
+
+: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
+
+: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
+
+: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
+
+: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
+
+: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
+
+: genre ( id3 -- genre/f )
+ "TCON" [ parse-genre ] (find-id3-frame) ; inline
+
+: find-mp3s ( path -- seq )
+ [ >lower ".mp3" tail? ] find-all-files ; inline
+
+: mp3-paths>id3s ( seq -- seq' )
+ [ dup mp3>id3 ] { } map>assoc ; inline
+
+: parse-mp3-directory ( path -- seq )
+ find-mp3s mp3-paths>id3s ;
diff --git a/extra/irc/client/client.factor b/extra/irc/client/client.factor
index c82f2e292c..97fa659209 100755
--- a/extra/irc/client/client.factor
+++ b/extra/irc/client/client.factor
@@ -165,7 +165,7 @@ M: irc-chat to-chat in-messages>> mailbox-put ;
" hostname servername :irc.factor" irc-print ;
: /CONNECT ( server port -- stream )
- irc> connect>> call drop ;
+ irc> connect>> call drop ; inline
: /JOIN ( channel password -- )
"JOIN " irc-write
diff --git a/extra/math/matrices/matrices-tests.factor b/extra/math/matrices/matrices-tests.factor
index 6f87109ba0..20942356de 100644
--- a/extra/math/matrices/matrices-tests.factor
+++ b/extra/math/matrices/matrices-tests.factor
@@ -104,3 +104,6 @@ USING: math.matrices math.vectors tools.test math ;
[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
+
+[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
+[ { 1 2 } { "a" "b" } cross-zip ] unit-test
\ No newline at end of file
diff --git a/extra/math/matrices/matrices.factor b/extra/math/matrices/matrices.factor
index 0088b17372..7c687d753d 100755
--- a/extra/math/matrices/matrices.factor
+++ b/extra/math/matrices/matrices.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.order math.vectors sequences ;
IN: math.matrices
@@ -57,3 +57,6 @@ PRIVATE>
: norm-gram-schmidt ( seq -- orthonormal )
gram-schmidt [ normalize ] map ;
+
+: cross-zip ( seq1 seq2 -- seq1xseq2 )
+ [ [ 2array ] with map ] curry map ;
\ No newline at end of file
diff --git a/extra/spider/spider-docs.factor b/extra/spider/spider-docs.factor
index cdbd5e7e09..4ed00d39f6 100644
--- a/extra/spider/spider-docs.factor
+++ b/extra/spider/spider-docs.factor
@@ -16,11 +16,6 @@ HELP: run-spider
{ "spider" spider } }
{ $description "Runs a spider until completion. See the " { $subsection "spider-tutorial" } " for a complete description of the tuple slots that affect how thet spider works." } ;
-HELP: slurp-heap-while
-{ $values
- { "heap" "a heap" } { "quot1" quotation } { "quot2" quotation } }
-{ $description "Removes values from a heap that match the predicate quotation " { $snippet "quot1" } " and processes them with " { $snippet "quot2" } " until the predicate quotation no longer matches." } ;
-
ARTICLE: "spider-tutorial" "Spider tutorial"
"To create a new spider, call the " { $link <spider> } " word with a link to the site you wish to spider."
{ $code <" "http://concatenative.org" <spider> "> }
diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index bd5b2668be..d08276a9bb 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -3,8 +3,8 @@
USING: accessors fry html.parser html.parser.analyzer
http.client kernel tools.time sets assocs sequences
concurrency.combinators io threads namespaces math multiline
-heaps math.parser inspector urls assoc-heaps logging
-combinators.short-circuit continuations calendar prettyprint ;
+math.parser inspector urls logging combinators.short-circuit
+continuations calendar prettyprint dlists deques locals ;
IN: spider
TUPLE: spider base count max-count sleep max-depth initial-links
@@ -13,12 +13,33 @@ filters spidered todo nonmatching quiet ;
TUPLE: spider-result url depth headers fetch-time parsed-html
links processing-time timestamp ;
+TUPLE: todo-url url depth ;
+
+: <todo-url> ( url depth -- todo-url )
+ todo-url new
+ swap >>depth
+ swap >>url ;
+
+TUPLE: unique-deque assoc deque ;
+
+: <unique-deque> ( -- unique-deque )
+ H{ } clone <dlist> unique-deque boa ;
+
+: push-url ( url depth unique-deque -- )
+ [ <todo-url> ] dip
+ [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
+ [ deque>> push-back ] 2bi ;
+
+: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
+
+: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
+
: <spider> ( base -- spider )
>url
spider new
over >>base
- swap 0 <unique-min-heap> [ heap-push ] keep >>todo
- <unique-min-heap> >>nonmatching
+ swap 0 <unique-deque> [ push-url ] keep >>todo
+ <unique-deque> >>nonmatching
0 >>max-depth
0 >>count
1/0. >>max-count
@@ -27,10 +48,10 @@ links processing-time timestamp ;
<PRIVATE
: apply-filters ( links spider -- links' )
- filters>> [ '[ _ 1&& ] filter ] when* ;
+ filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ;
-: push-links ( links level assoc-heap -- )
- '[ _ _ heap-push ] each ;
+: push-links ( links level unique-deque -- )
+ '[ _ _ push-url ] each ;
: add-todo ( links level spider -- )
todo>> push-links ;
@@ -38,64 +59,72 @@ links processing-time timestamp ;
: add-nonmatching ( links level spider -- )
nonmatching>> push-links ;
-: filter-base ( spider spider-result -- base-links nonmatching-links )
+: filter-base-links ( spider spider-result -- base-links nonmatching-links )
[ base>> host>> ] [ links>> prune ] bi*
[ host>> = ] with partition ;
: add-spidered ( spider spider-result -- )
[ [ 1+ ] change-count ] dip
2dup [ spidered>> ] [ dup url>> ] bi* rot set-at
- [ filter-base ] 2keep
+ [ filter-base-links ] 2keep
depth>> 1+ swap
[ add-nonmatching ]
[ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
-: normalize-hrefs ( links -- links' )
- [ >url ] map
- spider get base>> swap [ derive-url ] with map ;
+: normalize-hrefs ( links spider -- links' )
+ [ [ >url ] map ] dip
+ base>> swap [ derive-url ] with map ;
: print-spidering ( url depth -- )
"depth: " write number>string write
", spidering: " write . yield ;
-: (spider-page) ( url depth -- spider-result )
- f pick spider get spidered>> set-at
- over '[ _ http-get ] benchmark swap
- [ parse-html dup find-hrefs normalize-hrefs ] benchmark
+:: new-spidered-result ( spider url depth -- spider-result )
+ f url spider spidered>> set-at
+ [ url http-get ] benchmark :> fetch-time :> html :> headers
+ [
+ html parse-html [ ] [ find-hrefs spider normalize-hrefs ] bi
+ ] benchmark :> processing-time :> links :> parsed-html
+ url depth headers fetch-time parsed-html links processing-time
now spider-result boa ;
-: spider-page ( url depth -- )
- spider get quiet>> [ 2dup print-spidering ] unless
- (spider-page)
- spider get [ quiet>> [ dup describe ] unless ]
- [ swap add-spidered ] bi ;
+:: spider-page ( spider url depth -- )
+ spider quiet>> [ url depth print-spidering ] unless
+ spider url depth new-spidered-result :> spidered-result
+ spider quiet>> [ spidered-result describe ] unless
+ spider spidered-result add-spidered ;
\ spider-page ERROR add-error-logging
-: spider-sleep ( -- )
- spider get sleep>> [ sleep ] when* ;
+: spider-sleep ( spider -- )
+ sleep>> [ sleep ] when* ;
-: queue-initial-links ( spider -- spider )
- [ initial-links>> normalize-hrefs 0 ] keep
- [ add-todo ] keep ;
+:: queue-initial-links ( spider -- spider )
+ spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ;
-: slurp-heap-while ( heap quot1 quot2: ( value key -- ) -- )
- pick heap-empty? [ 3drop ] [
- [ [ heap-pop dup ] 2dip slip [ t ] compose [ 2drop f ] if ]
- [ roll [ slurp-heap-while ] [ 3drop ] if ] 3bi
- ] if ; inline recursive
+: spider-page? ( spider -- ? )
+ {
+ [ todo>> deque>> deque-empty? not ]
+ [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
+ [ [ count>> ] [ max-count>> ] bi < ]
+ } 1&& ;
+
+: setup-next-url ( spider -- spider url depth )
+ dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
+
+: spider-next-page ( spider -- )
+ setup-next-url spider-page ;
PRIVATE>
+: run-spider-loop ( spider -- )
+ dup spider-page? [
+ [ spider-next-page ] [ run-spider-loop ] bi
+ ] [
+ drop
+ ] if ;
+
: run-spider ( spider -- spider )
"spider" [
- dup spider [
- queue-initial-links
- [ todo>> ] [ max-depth>> ] bi
- '[
- _ <= spider get
- [ count>> ] [ max-count>> ] bi < and
- ] [ spider-page spider-sleep ] slurp-heap-while
- spider get
- ] with-variable
+ queue-initial-links [ run-spider-loop ] keep
] with-logging ;
diff --git a/extra/tetris/gl/gl.factor b/extra/tetris/gl/gl.factor
index f8c901ff56..d1f398994e 100644
--- a/extra/tetris/gl/gl.factor
+++ b/extra/tetris/gl/gl.factor
@@ -8,7 +8,7 @@ IN: tetris.gl
#! OpenGL rendering for tetris
: draw-block ( block -- )
- [ { 1 1 } gl-fill-rect ] with-translation ;
+ { 1 1 } gl-fill-rect ;
: draw-piece-blocks ( piece -- )
piece-blocks [ draw-block ] each ;
diff --git a/extra/ui/gadgets/lists/lists.factor b/extra/ui/gadgets/lists/lists.factor
index d7301ca042..aa98793c70 100644
--- a/extra/ui/gadgets/lists/lists.factor
+++ b/extra/ui/gadgets/lists/lists.factor
@@ -57,9 +57,7 @@ M: list draw-gadget*
origin get [
dup color>> gl-color
selected-rect [
- dup loc>> [
- dim>> gl-fill-rect
- ] with-translation
+ rect-bounds gl-fill-rect
] when*
] with-translation ;
diff --git a/extra/webapps/wiki/wiki-common.xml b/extra/webapps/wiki/wiki-common.xml
index bca48ce260..6bdc449dc8 100644
--- a/extra/webapps/wiki/wiki-common.xml
+++ b/extra/webapps/wiki/wiki-common.xml
@@ -20,7 +20,7 @@
</t:a>
</h2>
- <t:farkup t:name="parsed" t:parsed="true" />
+ <t:farkup t:name="content" />
</t:bind>
</div>
</td>
@@ -58,7 +58,7 @@
<tr>
<td colspan="2" class="footer">
<t:bind t:name="footer">
- <t:farkup t:name="parsed" t:parsed="true" />
+ <t:farkup t:name="content" />
</t:bind>
</td>
</tr>
diff --git a/vm/Config.linux.x86.64 b/vm/Config.linux.x86.64
index a02fcb4d6d..bfd1222496 100644
--- a/vm/Config.linux.x86.64
+++ b/vm/Config.linux.x86.64
@@ -1,4 +1,3 @@
include vm/Config.linux
include vm/Config.x86.64
LIBPATH = -L/usr/X11R6/lib64 -L/usr/X11R6/lib
-FFI_TEST_CFLAGS = -fPIC
diff --git a/vm/Config.macosx b/vm/Config.macosx
index 6655d548b7..98d14cfdf4 100644
--- a/vm/Config.macosx
+++ b/vm/Config.macosx
@@ -4,6 +4,7 @@ CFLAGS += -fPIC
PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o
DLL_EXTENSION = .dylib
+SHARED_DLL_EXTENSION = .dylib
SHARED_FLAG = -dynamiclib
diff --git a/vm/Config.unix b/vm/Config.unix
index 8f2f140247..339c3c3ffb 100644
--- a/vm/Config.unix
+++ b/vm/Config.unix
@@ -5,7 +5,7 @@ endif
EXE_SUFFIX =
DLL_PREFIX = lib
DLL_EXTENSION = .a
-# DLL_EXTENSION = .so
+SHARED_DLL_EXTENSION = .so
SHARED_FLAG = -shared
PLAF_DLL_OBJS = vm/os-unix.o
diff --git a/vm/Config.windows b/vm/Config.windows
index 75452a9bb4..cdb72f4e24 100644
--- a/vm/Config.windows
+++ b/vm/Config.windows
@@ -5,5 +5,6 @@ SHARED_FLAG = -shared
EXE_EXTENSION=.exe
CONSOLE_EXTENSION=.com
DLL_EXTENSION=.dll
+SHARED_DLL_EXTENSION=.dll
LINKER = $(CC) -shared -mno-cygwin -o
LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)
diff --git a/vm/alien.c b/vm/alien.c
index 8b7df45e9a..2681579c5d 100755
--- a/vm/alien.c
+++ b/vm/alien.c
@@ -160,7 +160,7 @@ void box_value_struct(void *src, CELL size)
dpush(tag_object(array));
}
-/* On OS X, structs <= 8 bytes are returned in registers. */
+/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
void box_small_struct(CELL x, CELL y, CELL size)
{
CELL data[2];
@@ -169,6 +169,17 @@ void box_small_struct(CELL x, CELL y, CELL size)
box_value_struct(data,size);
}
+/* On OS X/PPC, complex numbers are returned in registers. */
+void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
+{
+ CELL data[4];
+ data[0] = x1;
+ data[1] = x2;
+ data[2] = x3;
+ data[3] = x4;
+ box_value_struct(data,size);
+}
+
/* open a native library and push a handle */
void primitive_dlopen(void)
{
diff --git a/vm/alien.h b/vm/alien.h
index ec1eb08acf..dc76d49810 100755
--- a/vm/alien.h
+++ b/vm/alien.h
@@ -40,6 +40,7 @@ void primitive_set_alien_cell(void);
DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
DLLEXPORT void box_value_struct(void *src, CELL size);
DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
+void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size);
DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
diff --git a/vm/callstack.c b/vm/callstack.c
index d44a889756..b7e6b946bb 100755
--- a/vm/callstack.c
+++ b/vm/callstack.c
@@ -103,7 +103,7 @@ CELL frame_type(F_STACK_FRAME *frame)
CELL frame_executing(F_STACK_FRAME *frame)
{
F_CODE_BLOCK *compiled = frame_code(frame);
- if(compiled->literals == F)
+ if(compiled->literals == F || !stack_traces_p())
return F;
else
{
diff --git a/vm/code_block.c b/vm/code_block.c
index a9b5277c84..8dda8bc16e 100644
--- a/vm/code_block.c
+++ b/vm/code_block.c
@@ -11,7 +11,7 @@ void iterate_relocations(F_CODE_BLOCK *compiled, RELOCATION_ITERATOR iter)
{
F_BYTE_ARRAY *relocation = untag_object(compiled->relocation);
- CELL index = 1;
+ CELL index = stack_traces_p() ? 1 : 0;
F_REL *rel = (F_REL *)(relocation + 1);
F_REL *rel_end = (F_REL *)((char *)rel + byte_array_capacity(relocation));
@@ -195,8 +195,6 @@ void mark_code_block(F_CODE_BLOCK *compiled)
copy_handle(&compiled->literals);
copy_handle(&compiled->relocation);
-
- flush_icache_for(compiled);
}
void mark_stack_frame_step(F_STACK_FRAME *frame)
@@ -370,11 +368,6 @@ void deposit_integers(CELL here, F_ARRAY *array, CELL format)
}
}
-bool stack_traces_p(void)
-{
- return to_boolean(userenv[STACK_TRACES_ENV]);
-}
-
CELL compiled_code_format(void)
{
return untag_fixnum_fast(userenv[JIT_CODE_FORMAT]);
@@ -431,6 +424,10 @@ F_CODE_BLOCK *add_code_block(
UNREGISTER_ROOT(relocation);
UNREGISTER_ROOT(literals);
+ /* slight space optimization */
+ if(type_of(literals) == ARRAY_TYPE && array_capacity(untag_object(literals)) == 0)
+ literals = F;
+
/* compiled header */
compiled->block.type = type;
compiled->block.last_scan = NURSERY;
diff --git a/vm/code_block.h b/vm/code_block.h
index b00e4be8b6..cb8ebf5e19 100644
--- a/vm/code_block.h
+++ b/vm/code_block.h
@@ -75,7 +75,10 @@ void relocate_code_block(F_CODE_BLOCK *relocating);
CELL compiled_code_format(void);
-bool stack_traces_p(void);
+INLINE bool stack_traces_p(void)
+{
+ return userenv[STACK_TRACES_ENV] != F;
+}
F_CODE_BLOCK *add_code_block(
CELL type,
diff --git a/vm/debug.c b/vm/debug.c
index adae1cdd36..6f7e883785 100755
--- a/vm/debug.c
+++ b/vm/debug.c
@@ -311,7 +311,7 @@ void find_data_references(CELL look_for_)
/* Dump all code blocks for debugging */
void dump_code_heap(void)
{
- CELL size = 0;
+ CELL reloc_size = 0, literal_size = 0;
F_BLOCK *scan = first_block(&code_heap);
@@ -324,11 +324,13 @@ void dump_code_heap(void)
status = "free";
break;
case B_ALLOCATED:
- size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+ reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+ literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
status = "allocated";
break;
case B_MARKED:
- size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+ reloc_size += object_size(((F_CODE_BLOCK *)scan)->relocation);
+ literal_size += object_size(((F_CODE_BLOCK *)scan)->literals);
status = "marked";
break;
default:
@@ -343,7 +345,8 @@ void dump_code_heap(void)
scan = next_block(&code_heap,scan);
}
- print_cell(size); print_string(" bytes of relocation data\n");
+ print_cell(reloc_size); print_string(" bytes of relocation data\n");
+ print_cell(literal_size); print_string(" bytes of literal data\n");
}
void factorbug(void)
diff --git a/vm/quotations.c b/vm/quotations.c
index 86e47745b7..e18e6b6098 100755
--- a/vm/quotations.c
+++ b/vm/quotations.c
@@ -180,7 +180,8 @@ void jit_compile(CELL quot, bool relocate)
GROWABLE_ARRAY(literals);
REGISTER_ROOT(literals);
- GROWABLE_ARRAY_ADD(literals,stack_traces_p() ? quot : F);
+ if(stack_traces_p())
+ GROWABLE_ARRAY_ADD(literals,quot);
bool stack_frame = jit_stack_frame_p(untag_object(array));