Merge branch 'master' of git://factorcode.org/git/factor

.gitignore

@@ -21,3 +21,5 @@ logs
 work
 build-support/wordsize
 *.bak
+.#*
+*.swo

Factor.app/Contents/Info.plist

@@ -32,7 +32,7 @@
 	<key>CFBundlePackageType</key>
 	<string>APPL</string>
 	<key>NSHumanReadableCopyright</key>
-	<string>Copyright © 2003-2008, Slava Pestov and friends</string>
+	<string>Copyright © 2003-2009, Slava Pestov and friends</string>
 	<key>NSServices</key>
 	<array>
 		<dict>

Makefile

@@ -3,6 +3,7 @@ AR = ar
 LD = ld
 
 EXECUTABLE = factor
+CONSOLE_EXECUTABLE = factor-console
 VERSION = 0.92
 
 IMAGE = factor.image
@@ -25,23 +26,25 @@ ENGINE = $(DLL_PREFIX)factor$(DLL_SUFFIX)$(DLL_EXTENSION)
 DLL_OBJS = $(PLAF_DLL_OBJS) \
 	vm/alien.o \
 	vm/bignum.o \
+	vm/callstack.o \
+	vm/code_block.o \
+	vm/code_gc.o \
 	vm/code_heap.o \
+	vm/data_gc.o \
+	vm/data_heap.o \
 	vm/debug.o \
+	vm/errors.o \
 	vm/factor.o \
 	vm/ffi_test.o \
 	vm/image.o \
 	vm/io.o \
 	vm/math.o \
-	vm/data_gc.o \
-	vm/code_gc.o \
 	vm/primitives.o \
-	vm/run.o \
+	vm/profiler.o \
-	vm/callstack.o \
-	vm/types.o \
 	vm/quotations.o \
-	vm/utilities.o \
+	vm/run.o \
-	vm/errors.o \
+	vm/types.o \
-	vm/profiler.o
+	vm/utilities.o
 
 EXE_OBJS = $(PLAF_EXE_OBJS)
 
@@ -136,9 +139,11 @@ zlib1.dll:
 
 winnt-x86-32: freetype6.dll zlib1.dll
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
+	$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.32
 
 winnt-x86-64:
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
+	$(MAKE) $(CONSOLE_EXECUTABLE) CONFIG=vm/Config.windows.nt.x86.64
 
 wince-arm:
 	$(MAKE) $(EXECUTABLE) CONFIG=vm/Config.windows.ce.arm
@@ -159,6 +164,11 @@ factor: $(DLL_OBJS) $(EXE_OBJS)
 	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
 		$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
 
+factor-console: $(DLL_OBJS) $(EXE_OBJS)
+	$(LINKER) $(ENGINE) $(DLL_OBJS)
+	$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
+		$(CFLAGS) $(CFLAGS_CONSOLE) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
+
 clean:
 	rm -f vm/*.o
 	rm -f factor*.dll libfactor.{a,so,dylib}

basis/alias/alias-docs.factor

@@ -1,26 +0,0 @@
-! Copyright (C) 2008 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-USING: kernel words help.markup help.syntax ;
-IN: alias
-
-HELP: ALIAS:
-{ $syntax "ALIAS: new-word existing-word" }
-{ $values { "new-word" word } { "existing-word" word } }
-{ $description "Creates a " { $snippet "new" } " inlined word that calls the " { $snippet "existing" } " word." }
-{ $examples
-    { $example "USING: alias prettyprint sequences ;"
-               "IN: alias.test"
-               "ALIAS: sequence-nth nth"
-               "0 { 10 20 30 } sequence-nth ."
-               "10"
-    }
-} ;
-
-ARTICLE: "alias" "Word aliasing"
-"The " { $vocab-link "alias" } " vocabulary implements a way to make many different names for the same word. Although creating new names for words is generally frowned upon, aliases are useful for the Win32 API and other cases where words need to be renamed for symmetry." $nl 
-"Make a new word that aliases another word:"
-{ $subsection define-alias }
-"Make an alias at parse-time:"
-{ $subsection POSTPONE: ALIAS: } ;
-
-ABOUT: "alias"

basis/alien/c-types/c-types-tests.factor

@@ -8,10 +8,6 @@ sequences system libc alien.strings io.encodings.utf8 ;
 
 [ { "blah" 123 } ] [ { "blah" xyz } expand-constants ] unit-test
 
-: foo ( -- n ) &: fdafd [ 123 ] unless* ;
-
-[ 123 ] [ foo ] unit-test
-
 [ -1 ] [ -1 <char> *char ] unit-test
 [ -1 ] [ -1 <short> *short ] unit-test
 [ -1 ] [ -1 <int> *int ] unit-test

basis/alien/c-types/c-types.factor

@@ -234,17 +234,16 @@ M: long-long-type box-return ( type -- )
     f swap box-parameter ;
 
 : define-deref ( name -- )
-    [ CHAR: * prefix "alien.c-types" create ]
+    [ CHAR: * prefix "alien.c-types" create ] [ c-getter 0 prefix ] bi
-    [ c-getter 0 prefix ] bi
+    (( c-ptr -- value )) define-inline ;
-    define-inline ;
 
 : define-out ( name -- )
     [ "alien.c-types" constructor-word ]
-    [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ]
+    [ dup c-setter '[ _ <c-object> [ 0 @ ] keep ] ] bi
-    bi define-inline ;
+    (( value -- c-ptr )) define-inline ;
 
 : c-bool> ( int -- ? )
-    zero? not ;
+    0 = not ; inline
 
 : define-primitive-type ( type name -- )
     [ typedef ]

basis/alien/remote-control/remote-control-tests.factor

@@ -0,0 +1,44 @@
+USING: interpolate multiline
+io io.directories io.encodings.ascii io.files
+io.files.temp io.launcher io.streams.string kernel locals system
+tools.test sequences ;
+IN: alien.remote-control.tests
+
+: compile-file ( contents -- )
+    "test.c" ascii set-file-contents
+    { "gcc" "-I../" "-L.." "-lfactor" "test.c" }
+    os macosx? cpu x86.64? and [ "-m64" suffix ] when
+    try-process ;
+
+: run-test ( -- line )
+    os windows? "temp/a.exe" "temp/a.out" ?
+    ascii [ readln ] with-process-reader ;
+
+:: test-embedding ( code -- line )
+    image :> image
+
+    [
+        I[
+#include <vm/master.h>
+#include <stdio.h>
+#include <stdbool.h>
+
+int main(int argc, char **argv)
+{
+    F_PARAMETERS p;
+    default_parameters(&p);
+    p.image_path = STRING_LITERAL("${image}");
+    init_factor(&p);
+    start_embedded_factor(&p);
+    ${code}
+    printf("Done.\n");
+    return 0;
+}
+        ]I
+    ] with-string-writer
+    "resource:temp" [ compile-file ] with-directory
+    "resource:" [ run-test ] with-directory ;
+
+! [ "Done." ] [ "" test-embedding ] unit-test
+
+! [ "Done." ] [ "factor_yield();" test-embedding ] unit-test

basis/alien/remote-control/remote-control.factor

@@ -15,7 +15,7 @@ IN: alien.remote-control
     "void" { "long" } "cdecl" [ sleep ] alien-callback ;
 
 : ?callback ( word -- alien )
-    dup compiled>> [ execute ] [ drop f ] if ; inline
+    dup optimized>> [ execute ] [ drop f ] if ; inline
 
 : init-remote-control ( -- )
     \ eval-callback ?callback 16 setenv

basis/alien/structs/fields/fields.factor

@@ -52,8 +52,8 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
         [ (>>offset) ] [ type>> heap-size + ] 2bi
     ] reduce ;
 
-: define-struct-slot-word ( word quot spec -- )
+: define-struct-slot-word ( word quot spec effect -- )
-    offset>> prefix define-inline ;
+    [ offset>> prefix ] dip define-inline ;
 
 : define-getter ( type spec -- )
     [ set-reader-props ] keep
@@ -62,11 +62,13 @@ PREDICATE: slot-writer < word "writing" word-prop >boolean ;
         type>>
         [ c-getter ] [ c-type-boxer-quot ] bi append
     ]
-    [ ] tri define-struct-slot-word ;
+    [ ] tri
+    (( c-ptr -- value )) define-struct-slot-word ;
 
 : define-setter ( type spec -- )
     [ set-writer-props ] keep
-    [ writer>> ] [ type>> c-setter ] [ ] tri define-struct-slot-word ;
+    [ writer>> ] [ type>> c-setter ] [ ] tri
+    (( value c-ptr -- )) define-struct-slot-word ;
 
 : define-field ( type spec -- )
     [ define-getter ] [ define-setter ] 2bi ;

basis/alien/syntax/syntax.factor

@@ -4,7 +4,7 @@ USING: accessors arrays alien alien.c-types alien.structs
 alien.arrays alien.strings kernel math namespaces parser
 sequences words quotations math.parser splitting grouping
 effects assocs combinators lexer strings.parser alien.parser 
-fry ;
+fry vocabs.parser words.constant ;
 IN: alien.syntax
 
 : DLL" lexer get skip-blank parse-string dlopen parsed ; parsing
@@ -31,10 +31,11 @@ IN: alien.syntax
 
 : C-ENUM:
     ";" parse-tokens
-    dup length
+    [ [ create-in ] dip define-constant ] each-index ;
-    [ [ create-in ] dip 1quotation define ] 2each ;
     parsing
 
+: address-of ( name library -- value )
+    load-library dlsym [ "No such symbol" throw ] unless* ;
+
 : &:
-    scan "c-library" get
+    scan "c-library" get '[ _ _ address-of ] over push-all ; parsing
-    '[ _ _ load-library dlsym ] over push-all ; parsing

basis/ascii/ascii-docs.factor

@@ -37,8 +37,30 @@ HELP: quotable?
 { $values { "ch" "a character" } { "?" "a boolean" } }
 { $description "Tests for characters which may appear in a Factor string literal without escaping." } ;
 
-ARTICLE: "ascii" "ASCII character classes"
+HELP: ascii?
-"The " { $vocab-link "ascii" } " vocabulary implements traditional ASCII character classes:"
+{ $values { "ch" "a character" } { "?" "a boolean" } }
+{ $description "Tests for whether a number is an ASCII character." } ;
+
+HELP: ch>lower
+{ $values { "ch" "a character" } { "lower" "a character" } }
+{ $description "Converts an ASCII character to lower case." } ;
+
+HELP: ch>upper
+{ $values { "ch" "a character" } { "upper" "a character" } }
+{ $description "Converts an ASCII character to upper case." } ;
+
+HELP: >lower
+{ $values { "str" "a string" } { "lower" "a string" } }
+{ $description "Converts an ASCII string to lower case." } ;
+
+HELP: >upper
+{ $values { "str" "a string" } { "upper" "a string" } }
+{ $description "Converts an ASCII string to upper case." } ;
+
+ARTICLE: "ascii" "ASCII"
+"The " { $vocab-link "ascii" } " vocabulary implements support for the legacy ASCII character set. Most applications should use " { $link "unicode" } " instead."
+$nl
+"ASCII character classes:"
 { $subsection blank? }
 { $subsection letter? }
 { $subsection LETTER? }
@@ -46,6 +68,11 @@ ARTICLE: "ascii" "ASCII character classes"
 { $subsection printable? }
 { $subsection control? }
 { $subsection quotable? }
-"Modern applications should use Unicode 5.0 instead (" { $vocab-link "unicode.categories" } ")." ;
+{ $subsection ascii? }
+"ASCII case conversion:"
+{ $subsection ch>lower }
+{ $subsection ch>upper }
+{ $subsection >lower }
+{ $subsection >upper } ;
 
 ABOUT: "ascii"

basis/ascii/ascii-tests.factor

@@ -12,3 +12,8 @@ IN: ascii.tests
     0 "There are Four Upper Case characters"
     [ LETTER? [ 1+ ] when ] each
 ] unit-test
+
+[ t f ] [ CHAR: \s ascii? 400 ascii? ] unit-test
+
+[ "HELLO HOW ARE YOU?" ] [ "hellO hOw arE YOU?" >upper ] unit-test
+[ "i'm good thx bai" ] [ "I'm Good THX bai" >lower ] unit-test

basis/ascii/ascii.factor

@@ -1,27 +1,23 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
+! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.order sequences
+USING: kernel math math.order sequences strings
-combinators.short-circuit ;
+combinators.short-circuit hints ;
 IN: ascii
 
+: ascii? ( ch -- ? ) 0 127 between? ; inline
 : blank? ( ch -- ? ) " \t\n\r" member? ; inline
-
 : letter? ( ch -- ? ) CHAR: a CHAR: z between? ; inline
-
 : LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
-
 : digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
-
 : printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
+: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline
+: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
+: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
+: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
+: ch>lower ( ch -- lower ) dup LETTER? [ HEX: 20 + ] when ; inline
+: >lower ( str -- lower ) [ ch>lower ] map ;
+: ch>upper ( ch -- upper ) dup letter? [ HEX: 20 - ] when ; inline
+: >upper ( str -- upper ) [ ch>upper ] map ;
 
-: control? ( ch -- ? )
+HINTS: >lower string ;
-    "\0\e\r\n\t\u000008\u00007f" member? ; inline
+HINTS: >upper string ;
-
-: quotable? ( ch -- ? )
-    dup printable? [ "\"\\" member? not ] [ drop f ] if ; inline
-
-: Letter? ( ch -- ? )
-    [ [ letter? ] [ LETTER? ] ] 1|| ;
-
-: alpha? ( ch -- ? )
-    [ [ Letter? ] [ digit? ] ] 1|| ;

basis/assoc-heaps/assoc-heaps-docs.factor

@@ -1,20 +1,19 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax io.streams.string ;
+USING: help.markup help.syntax io.streams.string assocs
+heaps.private ;
 IN: assoc-heaps
 
 HELP: <assoc-heap>
+{ $values { "assoc" assoc } { "heap" heap } { "assoc-heap" assoc-heap } }
 { $description "Constructs a new " { $link assoc-heap } " from two existing data structures." } ;
 
 HELP: <unique-max-heap>
-{ $values
+{ $values { "unique-heap" assoc-heap } }
-    
-     { "unique-heap" assoc-heap } }
 { $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a max-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
 
 HELP: <unique-min-heap>
-{ $values
+{ $values { "unique-heap" assoc-heap } }
-     { "unique-heap" assoc-heap } }
 { $description "Creates a new " { $link assoc-heap } " where the assoc is a hashtable and the heap is a min-heap. Popping an element from the heap leaves this element in the hashtable to ensure that the element will not be processed again." } ;
 
 { <unique-max-heap> <unique-min-heap> } related-words

basis/base64/base64-docs.factor

@@ -7,7 +7,13 @@ HELP: >base64
 { $examples
     { $example "USING: prettyprint base64 strings ;" "\"The monorail is a free service.\" >base64 >string ." "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\"" }
 }
-{ $see-also base64> } ;
+{ $see-also base64> >base64-lines } ;
+
+HELP: >base64-lines
+{ $values { "seq" sequence } { "base64" "a string of base64 characters" } }
+{ $description "Converts a sequence to its base64 representation by taking six bits at a time as an index into a lookup table containing alphanumerics, '+', and '/'.  The result is padded with '=' if the input was not a multiple of six bits. A crlf is inserted for every 76 characters of output." }
+{ $see-also base64> >base64-lines } ;
+
 
 HELP: base64>
 { $values { "base64" "a string of base64 characters" } { "seq" sequence } }
@@ -16,13 +22,26 @@ HELP: base64>
     { $example "USING: prettyprint base64 strings ;" "\"VGhlIG1vbm9yYWlsIGlzIGEgZnJlZSBzZXJ2aWNlLg==\" base64> >string ." "\"The monorail is a free service.\"" }
 }
 { $notes "This word will throw if the input string contains characters other than those allowed in base64 encodings." }
-{ $see-also >base64 } ;
+{ $see-also >base64 >base64-lines } ;
+
+HELP: encode-base64
+{ $description "Reads the standard input and writes it to standard output encoded in base64." } ;
+
+HELP: decode-base64
+{ $description "Reads the standard input and decodes it, writing to standard output." } ;
+
+HELP: encode-base64-lines
+{ $description "Reads the standard input and writes it to standard output encoded in base64 with a crlf every 76 characters." } ;
 
 ARTICLE: "base64" "Base 64 conversions"
 "The " { $vocab-link "base64" } " vocabulary implements conversions of sequences to printable characters in base 64. These plain-text representations of binary data may be passed around and converted back to binary data later." $nl
-"Converting to base 64:"
+"Converting to and from base64 as strings:"
 { $subsection >base64 }
-"Converting back to binary:"
+{ $subsection >base64-lines }
-{ $subsection base64> } ;
+{ $subsection base64> }
+"Using base64 from streams:"
+{ $subsection encode-base64 }
+{ $subsection encode-base64-lines }
+{ $subsection decode-base64 } ;
 
 ABOUT: "base64"

basis/base64/base64-tests.factor

@@ -1,4 +1,4 @@
-USING: kernel tools.test base64 strings ;
+USING: kernel tools.test base64 strings sequences  ;
 IN: base64.tests
 
 [ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
@@ -7,6 +7,7 @@ IN: base64.tests
 [ "a" ] [ "a" >base64 base64> >string ] unit-test
 [ "ab" ] [ "ab" >base64 base64> >string ] unit-test
 [ "abc" ] [ "abc" >base64 base64> >string ] unit-test
+[ "abcde" ] [ "abcde" >base64 3 cut "\r\n" swap 3append base64> >string ] unit-test
 
 ! From http://en.wikipedia.org/wiki/Base64
 [ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
@@ -15,5 +16,11 @@ IN: base64.tests
     >base64 >string
 ] unit-test
 
+[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
+[
+    "Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
+    >base64-lines >string
+] unit-test
+
 \ >base64 must-infer
 \ base64> must-infer

basis/base64/base64.factor

@@ -1,16 +1,22 @@
-! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences io.binary splitting grouping
+USING: combinators io io.binary io.encodings.binary
-accessors ;
+io.streams.byte-array io.streams.string kernel math namespaces
+sequences strings io.crlf ;
 IN: base64
 
 <PRIVATE
 
-: count-end ( seq quot -- n )
+: read1-ignoring ( ignoring -- ch )
-    trim-right-slice [ seq>> length ] [ to>> ] bi - ; inline
+    read1 2dup swap member? [ drop read1-ignoring ] [ nip ] if ;
+
+: read-ignoring ( ignoring n -- str )
+    [ drop read1-ignoring ] with map harvest
+    [ f ] [ >string ] if-empty ;
 
 : ch>base64 ( ch -- ch )
-    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" nth ;
+    "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"
+    nth ; inline
 
 : base64>ch ( ch -- ch )
     {
@@ -19,32 +25,60 @@ IN: base64
         f 0 f f f 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21
         22 23 24 25 f f f f f f 26 27 28 29 30 31 32 33 34 35 36 37 38 39
         40 41 42 43 44 45 46 47 48 49 50 51
-    } nth ;
+    } nth ; inline
 
-: encode3 ( seq -- seq )
+SYMBOL: column
+
+: write1-lines ( ch -- )
+    write1
+    column get [
+        1+ [ 76 = [ crlf ] when ]
+        [ 76 mod column set ] bi
+    ] when* ;
+
+: write-lines ( str -- )
+    [ write1-lines ] each ;
+
+: encode3 ( seq -- )
     be> 4 <reversed> [
-        -6 * shift HEX: 3f bitand ch>base64
+        -6 * shift HEX: 3f bitand ch>base64 write1-lines
-    ] with B{ } map-as ;
+    ] with each ; inline
 
-: decode4 ( str -- str )
+: encode-pad ( seq n -- )
-    0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ;
+    [ 3 0 pad-tail binary [ encode3 ] with-byte-writer ]
+    [ 1+ ] bi* head-slice 4 CHAR: = pad-tail write-lines ; inline
 
-: >base64-rem ( str -- str )
+ERROR: malformed-base64 ;
-    [ 3 0 pad-right encode3 ] [ length 1+ ] bi
+
-    head-slice 4 CHAR: = pad-right ;
+: decode4 ( seq -- )
+    [ 0 [ base64>ch swap 6 shift bitor ] reduce 3 >be ]
+    [ [ CHAR: = = ] count ] bi head-slice*
+    [ write1 ] each ; inline
 
 PRIVATE>
 
+: encode-base64 ( -- )
+    3 read dup length {
+        { 0 [ drop ] }
+        { 3 [ encode3 encode-base64 ] }
+        [ encode-pad encode-base64 ]
+    } case ;
+
+: encode-base64-lines ( -- )
+    0 column [ encode-base64 ] with-variable ;
+
+: decode-base64 ( -- )
+    "\n\r" 4 read-ignoring dup length {
+        { 0 [ drop ] }
+        { 4 [ decode4 decode-base64 ] }
+        [ malformed-base64 ]
+    } case ;
+
 : >base64 ( seq -- base64 )
-    #! cut string into two pieces, convert 3 bytes at a time
+    binary [ [ encode-base64 ] with-string-reader ] with-byte-writer ;
-    #! pad string with = when not enough bits
-    dup length dup 3 mod - cut
-    [ 3 <groups> [ encode3 ] map concat ]
-    [ [ "" ] [ >base64-rem ] if-empty ]
-    bi* append ;
 
 : base64> ( base64 -- seq )
-    #! input length must be a multiple of 4
+    [ binary [ decode-base64 ] with-byte-reader ] with-string-writer ;
-    [ 4 <groups> [ decode4 ] map concat ]
+
-    [ [ CHAR: = = ] count-end ]
+: >base64-lines ( seq -- base64 )
-    bi head* ;
+    binary [ [ encode-base64-lines ] with-string-reader ] with-byte-writer ;

basis/base64/tags.txt

@@ -0,0 +1,2 @@
+parsing
+web

basis/bit-arrays/bit-arrays-tests.factor

@@ -76,3 +76,7 @@ IN: bit-arrays.tests
     t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
     t t t t t t t t   t t t t t t t t   t t t t t t t t  t t t t t t t t
 } bit-array>integer ] unit-test
+
+[ 49 ] [ 49 <bit-array> dup set-bits [ ] count ] unit-test
+
+[ HEX: 100 ] [ ?{ f f f f f f f f t } bit-array>integer ] unit-test

basis/bit-arrays/bit-arrays.factor

@@ -11,7 +11,7 @@ TUPLE: bit-array
 
 <PRIVATE
 
-: n>byte -3 shift ; inline
+: n>byte ( m -- n ) -3 shift ; inline
 
 : byte/bit ( n alien -- byte bit )
     over n>byte alien-unsigned-1 swap 7 bitand ; inline
@@ -19,13 +19,13 @@ TUPLE: bit-array
 : set-bit ( ? byte bit -- byte )
     2^ rot [ bitor ] [ bitnot bitand ] if ; inline
 
-: bits>cells 31 + -5 shift ; inline
+: bits>cells ( m -- n ) 31 + -5 shift ; inline
 
-: bits>bytes 7 + n>byte ; inline
+: bits>bytes ( m -- n ) 7 + n>byte ; inline
 
 : (set-bits) ( bit-array n -- )
     [ [ length bits>cells ] keep ] dip swap underlying>>
-    '[ [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
+    '[ 2 shift [ _ _ ] dip set-alien-unsigned-4 ] each ; inline
 
 PRIVATE>
 
@@ -83,7 +83,7 @@ M: bit-array byte-length length 7 + -3 shift ;
     ] if ;
 
 : bit-array>integer ( bit-array -- n )
-    0 swap underlying>> dup length [
+    0 swap underlying>> dup length <reversed> [
         alien-unsigned-1 swap 8 shift bitor
     ] with each ;
 

basis/bootstrap/compiler/compiler.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors compiler cpu.architecture vocabs.loader system
 sequences namespaces parser kernel kernel.private classes
@@ -25,8 +25,8 @@ IN: bootstrap.compiler
 
 enable-compiler
 
-: compile-uncompiled ( words -- )
+: compile-unoptimized ( words -- )
-    [ compiled>> not ] filter compile ;
+    [ optimized>> not ] filter compile ;
 
 nl
 "Compiling..." write flush
@@ -48,70 +48,70 @@ nl
     wrap probe
 
     namestack*
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     bitand bitor bitxor bitnot
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     + 1+ 1- 2/ < <= > >= shift
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     new-sequence nth push pop peek flip
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     hashcode* = get set
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     memq? split harvest sift cut cut-slice start index clone
     set-at reverse push-all class number>string string>number
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     lines prefix suffix unclip new-assoc update
     word-prop set-word-prop 1array 2array 3array ?nth
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
 {
     malloc calloc free memcpy
-} compile-uncompiled
+} compile-unoptimized
 
 "." write flush
 
-{ build-tree } compile-uncompiled
+{ build-tree } compile-unoptimized
 
 "." write flush
 
-{ optimize-tree } compile-uncompiled
+{ optimize-tree } compile-unoptimized
 
 "." write flush
 
-{ optimize-cfg } compile-uncompiled
+{ optimize-cfg } compile-unoptimized
 
 "." write flush
 
-{ (compile) } compile-uncompiled
+{ (compile) } compile-unoptimized
 
 "." write flush
 
-vocabs [ words compile-uncompiled "." write flush ] each
+vocabs [ words compile-unoptimized "." write flush ] each
 
 " done" print flush

basis/bootstrap/finish-bootstrap.factor

@@ -12,5 +12,6 @@ namespaces eval kernel vocabs.loader io ;
         ignore-cli-args? not script get and
         [ run-script ] [ "run" get run ] if*
         output-stream get [ stream-flush ] when*
+        0 exit
     ] [ print-error 1 exit ] recover
 ] set-boot-quot

basis/bootstrap/finish-staging.factor

@@ -7,4 +7,5 @@ io ;
     (command-line) parse-command-line
     "run" get run
     output-stream get [ stream-flush ] when*
+    0 exit
 ] set-boot-quot

basis/bootstrap/help/help.factor

@@ -4,6 +4,7 @@ parser vocabs.loader vocabs.loader.private accessors assocs ;
 IN: bootstrap.help
 
 : load-help ( -- )
+    "help.lint" require
     "alien.syntax" require
     "compiler" require
 

basis/bootstrap/image/image-docs.factor

@@ -1,4 +1,4 @@
-USING: help.markup help.syntax io io.files ;
+USING: help.markup help.syntax io io.files io.pathnames ;
 IN: bootstrap.image
 
 ARTICLE: "bootstrap.image" "Bootstrapping new images"

basis/bootstrap/image/image.factor

@@ -1,15 +1,16 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien arrays byte-arrays generic assocs hashtables assocs
-hashtables.private io kernel kernel.private math namespaces make
+hashtables.private io io.binary io.files io.encodings.binary
-parser prettyprint sequences sequences.private strings sbufs
+io.pathnames kernel kernel.private math namespaces make parser
+prettyprint sequences sequences.private strings sbufs
 vectors words quotations assocs system layouts splitting
 grouping growable classes classes.builtin classes.tuple
-classes.tuple.private words.private io.binary io.files vocabs
+classes.tuple.private words.private vocabs
 vocabs.loader source-files definitions debugger
 quotations.private sequences.private combinators
-io.encodings.binary math.order math.private accessors
+math.order math.private accessors
-slots.private compiler.units ;
+slots.private compiler.units fry ;
 IN: bootstrap.image
 
 : arch ( os cpu -- arch )
@@ -65,14 +66,14 @@ M: id equal?
 
 SYMBOL: objects
 
-: (objects) <id> objects get ; inline
+: (objects) ( obj -- id assoc ) <id> objects get ; inline
 
 : lookup-object ( obj -- n/f ) (objects) at ;
 
 : put-object ( n obj -- ) (objects) set-at ;
 
 : cache-object ( obj quot -- value )
-    [ (objects) ] dip [ obj>> ] prepose cache ; inline
+    [ (objects) ] dip '[ obj>> @ ] cache ; inline
 
 ! Constants
 
@@ -94,7 +95,7 @@ SYMBOL: objects
 SYMBOL: sub-primitives
 
 : make-jit ( quot rc rt offset -- quad )
-    { [ { } make ] [ ] [ ] [ ] } spread 4array ; inline
+    [ { } make ] 3dip 4array ; inline
 
 : jit-define ( quot rc rt offset name -- )
     [ make-jit ] dip set ; inline
@@ -343,25 +344,37 @@ M: wrapper '
     [ emit ] emit-object ;
 
 ! Strings
+: native> ( object -- object )
+    big-endian get [ [ be> ] map ] [ [ le> ] map ] if ;
+
 : emit-bytes ( seq -- )
-    bootstrap-cell <groups>
+    bootstrap-cell <groups> native> emit-seq ;
-    big-endian get [ [ be> ] map ] [ [ le> ] map ] if
-    emit-seq ;
 
 : pad-bytes ( seq -- newseq )
-    dup length bootstrap-cell align 0 pad-right ;
+    dup length bootstrap-cell align 0 pad-tail ;
 
-: check-string ( string -- )
+: extended-part ( str -- str' )
-    [ 127 > ] contains?
+    dup [ 128 < ] all? [ drop f ] [
-    [ "Bootstrap cannot emit non-ASCII strings" throw ] when ;
+        [ -7 shift 1 bitxor ] { } map-as
+        big-endian get
+        [ [ 2 >be ] { } map-as ]
+        [ [ 2 >le ] { } map-as ] if
+        B{ } join
+    ] if ;
+
+: ascii-part ( str -- str' )
+    [
+        [ 128 mod ] [ 128 >= ] bi
+        [ 128 bitor ] when
+    ] B{ } map-as ;
 
 : emit-string ( string -- ptr )
-    dup check-string
+    [ length ] [ extended-part ' ] [ ] tri
     string type-number object tag-number [
-        dup length emit-fixnum
+        [ emit-fixnum ]
-        f ' emit
+        [ emit ]
-        f ' emit
+        [ f ' emit ascii-part pad-bytes emit-bytes ]
-        pad-bytes emit-bytes
+        tri*
     ] emit-object ;
 
 M: string '
@@ -432,7 +445,7 @@ M: quotation '
         array>> '
         quotation type-number object tag-number [
             emit ! array
-            f ' emit ! compiled>>
+            f ' emit ! compiled
             0 emit ! xt
             0 emit ! code
         ] emit-object
@@ -523,11 +536,9 @@ M: quotation '
 ! Image output
 
 : (write-image) ( image -- )
-    bootstrap-cell big-endian get [
+    bootstrap-cell big-endian get
-        [ >be write ] curry each
+    [ '[ _ >be write ] each ]
-    ] [
+    [ '[ _ >le write ] each ] if ;
-        [ >le write ] curry each
-    ] if ;
 
 : write-image ( image -- )
     "Writing image to " write

basis/bootstrap/image/upload/upload.factor

@@ -2,7 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: checksums checksums.openssl splitting assocs
 kernel io.files bootstrap.image sequences io namespaces make
-io.launcher math io.encodings.ascii ;
+io.launcher math io.encodings.ascii io.files.temp io.pathnames
+io.directories ;
 IN: bootstrap.image.upload
 
 SYMBOL: upload-images-destination

basis/bootstrap/io/io.factor

@@ -1,12 +1,11 @@
 USING: system vocabs vocabs.loader kernel combinators
-namespaces sequences io.backend ;
+namespaces sequences io.backend accessors ;
 IN: bootstrap.io
 
 "bootstrap.compiler" vocab [
-    "io." {
+    "io.backend." {
         { [ "io-backend" get ] [ "io-backend" get ] }
-        { [ os unix? ] [ "unix" ] }
+        { [ os unix? ] [ "unix." os name>> append ] }
         { [ os winnt? ] [ "windows.nt" ] }
-        { [ os wince? ] [ "windows.ce" ] }
     } cond append require
 ] when

basis/bootstrap/math/math.factor

@@ -3,5 +3,3 @@ USING: vocabs vocabs.loader kernel ;
 "math.ratios" require
 "math.floats" require
 "math.complex" require
-
-"prettyprint" vocab [ "math.complex.prettyprint" require ] when

basis/bootstrap/stage2.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors init namespaces words io
+USING: accessors init namespaces words words.symbol io
 kernel.private math memory continuations kernel io.files
-io.backend system parser vocabs sequences
+io.pathnames io.backend system parser vocabs sequences
 vocabs.loader combinators splitting source-files strings
-definitions assocs compiler.errors compiler.units
+definitions assocs compiler.errors compiler.units math.parser
-math.parser generic sets command-line ;
+generic sets command-line ;
 IN: bootstrap.stage2
 
 SYMBOL: core-bootstrap-time
@@ -13,7 +13,7 @@ SYMBOL: core-bootstrap-time
 SYMBOL: bootstrap-time
 
 : default-image-name ( -- string )
-    vm file-name os windows? [ "." split1 drop ] when
+    vm file-name os windows? [ "." split1-last drop ] when
     ".image" append resource-path ;
 
 : do-crossref ( -- )
@@ -42,7 +42,7 @@ SYMBOL: bootstrap-time
     "Core bootstrap completed in " write core-bootstrap-time get print-time
     "Bootstrap completed in "      write bootstrap-time      get print-time
 
-    [ compiled>> ] count-words " compiled words" print
+    [ optimized>> ] count-words " compiled words" print
     [ symbol? ] count-words " symbol words" print
     [ ] count-words " words total" print
 
@@ -102,6 +102,8 @@ SYMBOL: bootstrap-time
     ] if
 ] [
     drop
-    load-help? off
+    [
-    "resource:basis/bootstrap/bootstrap-error.factor" run-file
+        load-help? off
+        "resource:basis/bootstrap/bootstrap-error.factor" run-file
+    ] with-scope
 ] recover

basis/bootstrap/threads/threads.factor

@@ -1,11 +1,11 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: vocabs vocabs.loader kernel ;
+USING: vocabs vocabs.loader kernel io.thread threads
+compiler.utilities namespaces ;
 IN: bootstrap.threads
 
-USE: io.thread
-USE: threads
-
 "debugger" vocab [
     "debugger.threads" require
 ] when
+
+[ yield ] yield-hook set-global

basis/bootstrap/unicode/unicode.factor

@@ -1,5 +1 @@
-USING: strings.parser kernel namespaces unicode.data ;
+USE: unicode
-IN: bootstrap.unicode
-
-[ name>char [ "Invalid character" throw ] unless* ]
-name>char-hook set-global

basis/cairo/cairo.factor

@@ -17,20 +17,21 @@ M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
     [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
 
 SYMBOL: cairo
-: cr ( -- cairo ) cairo get ;
+: cr ( -- cairo ) cairo get ; inline
 
 : (with-cairo) ( cairo-t quot -- )
-    >r alien>> cairo r> [ cr cairo_status check-cairo ]
+    [ alien>> cairo ] dip
-    compose with-variable ; inline
+    '[ @ cr cairo_status check-cairo ]
+    with-variable ; inline
     
 : with-cairo ( cairo quot -- )
-    >r <cairo-t> r> [ (with-cairo) ] curry with-disposal ; inline
+    [ <cairo-t> ] dip '[ _ (with-cairo) ] with-disposal ; inline
 
 : (with-surface) ( cairo-surface-t quot -- )
-    >r alien>> r> [ cairo_surface_status check-cairo ] bi ; inline
+    [ alien>> ] dip [ cairo_surface_status check-cairo ] bi ; inline
 
 : with-surface ( cairo_surface quot -- )
-    >r <cairo-surface-t> r> [ (with-surface) ] curry with-disposal ; inline
+    [ <cairo-surface-t> ] dip '[ _ (with-surface) ] with-disposal ; inline
 
 : with-cairo-from-surface ( cairo_surface quot -- )
     '[ cairo_create _ with-cairo ] with-surface ; inline

basis/cairo/ffi/ffi.factor

@@ -37,7 +37,7 @@ TYPEDEF: void* cairo_pattern_t
 
 TYPEDEF: void* cairo_destroy_func_t
 : cairo-destroy-func ( quot -- callback )
-    >r "void" { "void*" } "cdecl" r> alien-callback ; inline
+    [ "void" { "void*" } "cdecl" ] dip alien-callback ; inline
 
 ! See cairo.h for details
 C-STRUCT: cairo_user_data_key_t
@@ -78,13 +78,11 @@ TYPEDEF: int cairo_content_t
 
 TYPEDEF: void* cairo_write_func_t
 : cairo-write-func ( quot -- callback )
-    >r "cairo_status_t" { "void*" "uchar*" "int" }
+    [ "cairo_status_t" { "void*" "uchar*" "int" } "cdecl" ] dip alien-callback ; inline
-    "cdecl" r> alien-callback ; inline
                           
 TYPEDEF: void* cairo_read_func_t
 : cairo-read-func ( quot -- callback )
-    >r "cairo_status_t" { "void*" "uchar*" "int" }
+    [ "cairo_status_t" { "void*" "uchar*" "int" } "cdecl" ] dip alien-callback ; inline
-    "cdecl" r> alien-callback ; inline
 
 ! Functions for manipulating state objects
 FUNCTION: cairo_t*

basis/cairo/gadgets/gadgets.factor

@@ -0,0 +1,43 @@
+! Copyright (C) 2008 Matthew Willis.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sequences math kernel byte-arrays cairo.ffi cairo
+io.backend ui.gadgets accessors opengl.gl arrays fry
+classes ui.render namespaces destructors libc ;
+IN: cairo.gadgets
+
+<PRIVATE
+: width>stride ( width -- stride ) 4 * ;
+
+: image-dims ( gadget -- width height stride )
+    dim>> first2 over width>stride ; inline
+: image-buffer ( width height stride -- alien )
+    * nip malloc ; inline
+PRIVATE>
+    
+GENERIC: render-cairo* ( gadget -- )
+
+: render-cairo ( gadget -- alien )
+    [
+        image-dims
+        [ image-buffer dup CAIRO_FORMAT_ARGB32 ] 
+        [ cairo_image_surface_create_for_data ] 3bi
+    ] [ '[ _ render-cairo* ] with-cairo-from-surface ] bi ;
+
+TUPLE: cairo-gadget < gadget ;
+
+: <cairo-gadget> ( dim -- gadget )
+    cairo-gadget new-gadget
+        swap >>dim ;
+
+M: cairo-gadget draw-gadget*
+    [
+        [ dim>> ] [ render-cairo &free ] bi
+        origin get first2 glRasterPos2i
+        1.0 -1.0 glPixelZoom
+        [ first2 GL_BGRA GL_UNSIGNED_BYTE ] dip
+        glDrawPixels
+    ] with-destructors ;
+
+: copy-surface ( surface -- )
+    cr swap 0 0 cairo_set_source_surface
+    cr cairo_paint ;

basis/calendar/calendar.factor

@@ -211,7 +211,7 @@ M: real +minute ( timestamp n -- timestamp )
 M: number +second ( timestamp n -- timestamp )
     [ over second>> + seconds/minutes [ >>second ] dip +minute ] unless-zero ;
 
-: (time+)
+: (time+) ( timestamp duration -- timestamp' duration )
     [ second>> +second ] keep
     [ minute>> +minute ] keep
     [ hour>>   +hour   ] keep
@@ -219,7 +219,8 @@ M: number +second ( timestamp n -- timestamp )
     [ month>>  +month  ] keep
     [ year>>   +year   ] keep ; inline
 
-: +slots [ bi@ + ] curry 2keep ; inline
+: +slots ( obj1 obj2 quot -- n obj1 obj2 )
+    [ bi@ + ] curry 2keep ; inline
 
 PRIVATE>
 

basis/calendar/format/format.factor

@@ -5,11 +5,11 @@ sequences io accessors arrays io.streams.string splitting
 combinators accessors calendar calendar.format.macros present ;
 IN: calendar.format
 
-: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-left ;
+: pad-00 ( n -- str ) number>string 2 CHAR: 0 pad-head ;
 
-: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-left ;
+: pad-0000 ( n -- str ) number>string 4 CHAR: 0 pad-head ;
 
-: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-left ;
+: pad-00000 ( n -- str ) number>string 5 CHAR: 0 pad-head ;
 
 : write-00 ( n -- ) pad-00 write ;
 

basis/channels/remote/remote-docs.factor

@@ -6,6 +6,7 @@ IN: channels.remote
 HELP: <remote-channel>
 { $values { "node" "a node object" }
           { "id" "the id of the published channel on the node" } 
+          { "remote-channel" remote-channel }
 }
 { $description "Create a remote channel that acts as a proxy for a "
 "channel on another node. The remote node's channel must have been "

basis/checksums/common/common.factor

@@ -1,21 +1,20 @@
 ! Copyright (C) 2006, 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.bitwise strings io.binary namespaces
-make grouping ;
+make grouping byte-arrays ;
 IN: checksums.common
 
 SYMBOL: bytes-read
 
-: calculate-pad-length ( length -- pad-length )
+: calculate-pad-length ( length -- length' )
-    dup 56 < 55 119 ? swap - ;
+    [ 56 < 55 119 ? ] keep - ;
 
 : pad-last-block ( str big-endian? length -- str )
     [
-        rot %
+        [ % ] 2dip HEX: 80 ,
-        HEX: 80 ,
+        [ HEX: 3f bitand calculate-pad-length <byte-array> % ]
-        dup HEX: 3f bitand calculate-pad-length 0 <string> %
+        [ 3 shift 8 rot [ >be ] [ >le ] if % ] bi
-        3 shift 8 rot [ >be ] [ >le ] if %
+    ] B{ } make 64 group ;
-    ] "" make 64 group ;
 
 : update-old-new ( old new -- )
     [ [ get ] bi@ w+ dup ] 2keep [ set ] bi@ ; inline

basis/checksums/md5/md5.factor

@@ -2,9 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel io io.binary io.files io.streams.byte-array math
 math.functions math.parser namespaces splitting grouping strings
-sequences byte-arrays locals sequences.private
+sequences byte-arrays locals sequences.private macros fry
-io.encodings.binary symbols math.bitwise checksums
+io.encodings.binary math.bitwise checksums
-checksums.common checksums.stream ;
+checksums.common checksums.stream combinators ;
 IN: checksums.md5
 
 ! See http://www.faqs.org/rfcs/rfc1321.html
@@ -29,7 +29,7 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
     old-c c update-old-new
     old-d d update-old-new ;
 
-:: (ABCD) ( x s i k func a b c d -- )
+:: (ABCD) ( x a b c d k s i func -- )
     #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
     a [
         b get c get d get func call w+
@@ -39,11 +39,6 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
         b get w+
     ] change ; inline
 
-: ABCD a b c d (ABCD) ; inline
-: BCDA b c d a (ABCD) ; inline
-: CDAB c d a b (ABCD) ; inline
-: DABC d a b c (ABCD) ; inline
-
 : F ( X Y Z -- FXYZ )
     #! F(X,Y,Z) = XY v not(X) Z
     pick bitnot bitand [ bitand ] [ bitor ] bi* ;
@@ -60,104 +55,113 @@ SYMBOLS: a b c d old-a old-b old-c old-d ;
     #! I(X,Y,Z) = Y xor (X v not(Z))
     rot swap bitnot bitor bitxor ;
 
-: S11 7  ; inline
+CONSTANT: S11 7
-: S12 12 ; inline
+CONSTANT: S12 12
-: S13 17 ; inline
+CONSTANT: S13 17
-: S14 22 ; inline
+CONSTANT: S14 22
-: S21 5  ; inline
+CONSTANT: S21 5
-: S22 9  ; inline
+CONSTANT: S22 9
-: S23 14 ; inline
+CONSTANT: S23 14
-: S24 20 ; inline
+CONSTANT: S24 20
-: S31 4 ;  inline
+CONSTANT: S31 4
-: S32 11 ; inline
+CONSTANT: S32 11
-: S33 16 ; inline
+CONSTANT: S33 16
-: S34 23 ; inline
+CONSTANT: S34 23
-: S41 6  ; inline
+CONSTANT: S41 6
-: S42 10 ; inline
+CONSTANT: S42 10
-: S43 15 ; inline
+CONSTANT: S43 15
-: S44 21 ; inline
+CONSTANT: S44 21
 
-: (process-md5-block-F) ( block -- block )
+MACRO: with-md5-round ( ops func -- )
-    dup S11 1  0  [ F ] ABCD
+    '[ [ _ (ABCD) ] compose ] map '[ _ cleave ] ;
-    dup S12 2  1  [ F ] DABC
-    dup S13 3  2  [ F ] CDAB
-    dup S14 4  3  [ F ] BCDA
-    dup S11 5  4  [ F ] ABCD
-    dup S12 6  5  [ F ] DABC
-    dup S13 7  6  [ F ] CDAB
-    dup S14 8  7  [ F ] BCDA
-    dup S11 9  8  [ F ] ABCD
-    dup S12 10 9  [ F ] DABC
-    dup S13 11 10 [ F ] CDAB
-    dup S14 12 11 [ F ] BCDA
-    dup S11 13 12 [ F ] ABCD
-    dup S12 14 13 [ F ] DABC
-    dup S13 15 14 [ F ] CDAB
-    dup S14 16 15 [ F ] BCDA ;
 
-: (process-md5-block-G) ( block -- block )
+: (process-md5-block-F) ( block -- )
-    dup S21 17 1  [ G ] ABCD
+    {
-    dup S22 18 6  [ G ] DABC
+        [ a b c d 0  S11 1  ]
-    dup S23 19 11 [ G ] CDAB
+        [ d a b c 1  S12 2  ]
-    dup S24 20 0  [ G ] BCDA
+        [ c d a b 2  S13 3  ]
-    dup S21 21 5  [ G ] ABCD
+        [ b c d a 3  S14 4  ]
-    dup S22 22 10 [ G ] DABC
+        [ a b c d 4  S11 5  ]
-    dup S23 23 15 [ G ] CDAB
+        [ d a b c 5  S12 6  ]
-    dup S24 24 4  [ G ] BCDA
+        [ c d a b 6  S13 7  ]
-    dup S21 25 9  [ G ] ABCD
+        [ b c d a 7  S14 8  ]
-    dup S22 26 14 [ G ] DABC
+        [ a b c d 8  S11 9  ]
-    dup S23 27 3  [ G ] CDAB
+        [ d a b c 9  S12 10 ]
-    dup S24 28 8  [ G ] BCDA
+        [ c d a b 10 S13 11 ]
-    dup S21 29 13 [ G ] ABCD
+        [ b c d a 11 S14 12 ]
-    dup S22 30 2  [ G ] DABC
+        [ a b c d 12 S11 13 ]
-    dup S23 31 7  [ G ] CDAB
+        [ d a b c 13 S12 14 ]
-    dup S24 32 12 [ G ] BCDA ;
+        [ c d a b 14 S13 15 ]
+        [ b c d a 15 S14 16 ]
+    } [ F ] with-md5-round ;
 
-: (process-md5-block-H) ( block -- block )
+: (process-md5-block-G) ( block -- )
-    dup S31 33 5  [ H ] ABCD
+    {
-    dup S32 34 8  [ H ] DABC
+        [ a b c d 1  S21 17 ]
-    dup S33 35 11 [ H ] CDAB
+        [ d a b c 6  S22 18 ]
-    dup S34 36 14 [ H ] BCDA
+        [ c d a b 11 S23 19 ]
-    dup S31 37 1  [ H ] ABCD
+        [ b c d a 0  S24 20 ]
-    dup S32 38 4  [ H ] DABC
+        [ a b c d 5  S21 21 ]
-    dup S33 39 7  [ H ] CDAB
+        [ d a b c 10 S22 22 ]
-    dup S34 40 10 [ H ] BCDA
+        [ c d a b 15 S23 23 ]
-    dup S31 41 13 [ H ] ABCD
+        [ b c d a 4  S24 24 ]
-    dup S32 42 0  [ H ] DABC
+        [ a b c d 9  S21 25 ]
-    dup S33 43 3  [ H ] CDAB
+        [ d a b c 14 S22 26 ]
-    dup S34 44 6  [ H ] BCDA
+        [ c d a b 3  S23 27 ]
-    dup S31 45 9  [ H ] ABCD
+        [ b c d a 8  S24 28 ]
-    dup S32 46 12 [ H ] DABC
+        [ a b c d 13 S21 29 ]
-    dup S33 47 15 [ H ] CDAB
+        [ d a b c 2  S22 30 ]
-    dup S34 48 2  [ H ] BCDA ;
+        [ c d a b 7  S23 31 ]
+        [ b c d a 12 S24 32 ]
+    } [ G ] with-md5-round ;
 
-: (process-md5-block-I) ( block -- block )
+: (process-md5-block-H) ( block -- )
-    dup S41 49 0  [ I ] ABCD
+    {
-    dup S42 50 7  [ I ] DABC
+        [ a b c d 5  S31 33 ]
-    dup S43 51 14 [ I ] CDAB
+        [ d a b c 8  S32 34 ]
-    dup S44 52 5  [ I ] BCDA
+        [ c d a b 11 S33 35 ]
-    dup S41 53 12 [ I ] ABCD
+        [ b c d a 14 S34 36 ]
-    dup S42 54 3  [ I ] DABC
+        [ a b c d 1  S31 37 ]
-    dup S43 55 10 [ I ] CDAB
+        [ d a b c 4  S32 38 ]
-    dup S44 56 1  [ I ] BCDA
+        [ c d a b 7  S33 39 ]
-    dup S41 57 8  [ I ] ABCD
+        [ b c d a 10 S34 40 ]
-    dup S42 58 15 [ I ] DABC
+        [ a b c d 13 S31 41 ]
-    dup S43 59 6  [ I ] CDAB
+        [ d a b c 0  S32 42 ]
-    dup S44 60 13 [ I ] BCDA
+        [ c d a b 3  S33 43 ]
-    dup S41 61 4  [ I ] ABCD
+        [ b c d a 6  S34 44 ]
-    dup S42 62 11 [ I ] DABC
+        [ a b c d 9  S31 45 ]
-    dup S43 63 2  [ I ] CDAB
+        [ d a b c 12 S32 46 ]
-    dup S44 64 9  [ I ] BCDA ;
+        [ c d a b 15 S33 47 ]
+        [ b c d a 2  S34 48 ]
+    } [ H ] with-md5-round ;
+
+: (process-md5-block-I) ( block -- )
+    {
+        [ a b c d 0  S41 49 ]
+        [ d a b c 7  S42 50 ]
+        [ c d a b 14 S43 51 ]
+        [ b c d a 5  S44 52 ]
+        [ a b c d 12 S41 53 ]
+        [ d a b c 3  S42 54 ]
+        [ c d a b 10 S43 55 ]
+        [ b c d a 1  S44 56 ]
+        [ a b c d 8  S41 57 ]
+        [ d a b c 15 S42 58 ]
+        [ c d a b 6  S43 59 ]
+        [ b c d a 13 S44 60 ]
+        [ a b c d 4  S41 61 ]
+        [ d a b c 11 S42 62 ]
+        [ c d a b 2  S43 63 ]
+        [ b c d a 9  S44 64 ]
+    } [ I ] with-md5-round ;
 
 : (process-md5-block) ( block -- )
-    4 <groups> [ le> ] map
+    4 <groups> [ le> ] map {
-
+        [ (process-md5-block-F) ]
-    (process-md5-block-F)
+        [ (process-md5-block-G) ]
-    (process-md5-block-G)
+        [ (process-md5-block-H) ]
-    (process-md5-block-H)
+        [ (process-md5-block-I) ]
-    (process-md5-block-I)
+    } cleave
-
-    drop
 
     update-md ;
 

basis/checksums/openssl/openssl-docs.factor

@@ -4,8 +4,8 @@ USING: help.syntax help.markup ;
 HELP: openssl-checksum
 { $class-description "The class of checksum algorithms implemented by OpenSSL. The exact set of algorithms supported depends on how the OpenSSL library was compiled; " { $snippet "md5" } " and " { $snippet "sha1" } " should be universally available." } ;
 
-HELP: <openssl-checksum> ( name -- checksum )
+HELP: <openssl-checksum>
-{ $values { "name" "an EVP message digest name" } { "checksum" openssl-checksum } }
+{ $values { "name" "an EVP message digest name" } { "openssl-checksum" openssl-checksum } }
 { $description "Creates a new OpenSSL checksum object." } ;
 
 HELP: openssl-md5

basis/checksums/sha1/sha1.factor

@@ -3,7 +3,7 @@
 USING: arrays combinators kernel io io.encodings.binary io.files
 io.streams.byte-array math.vectors strings sequences namespaces
 make math parser sequences assocs grouping vectors io.binary
-hashtables symbols math.bitwise checksums checksums.common
+hashtables math.bitwise checksums checksums.common
 checksums.stream ;
 IN: checksums.sha1
 
@@ -128,7 +128,7 @@ M: sha1 checksum-stream ( stream -- sha1 )
     [ zip concat ] keep like ;
 
 : sha1-interleave ( string -- seq )
-    [ zero? ] trim-left
+    [ zero? ] trim-head
     dup length odd? [ rest ] when
     seq>2seq [ sha1 checksum-bytes ] bi@
     2seq>seq ;

basis/checksums/sha2/sha2.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel splitting grouping math sequences namespaces make
-io.binary symbols math.bitwise checksums checksums.common
+io.binary math.bitwise checksums checksums.common
 sbufs strings ;
 IN: checksums.sha2
 
@@ -62,7 +62,7 @@ SYMBOLS: vars M K H S0 S1 process-M word-size block-size ;
     [ + + w+ ] 2dip swap set-nth ; inline
 
 : prepare-message-schedule ( seq -- w-seq )
-    word-size get group [ be> ] map block-size get 0 pad-right
+    word-size get group [ be> ] map block-size get 0 pad-tail
     dup 16 64 dup <slice> [
         process-M-256
     ] with each ;

basis/cocoa/application/application-docs.factor

@@ -30,10 +30,6 @@ HELP: cocoa-app
 { $values { "quot" quotation } }
 { $description "Initializes Cocoa, calls the quotation, and starts the Cocoa event loop." } ;
 
-HELP: do-event
-{ $values { "app" "an " { $snippet "NSApplication" } } { "?" "a boolean" } }
-{ $description "Processes a pending event in the queue, if any, returning a boolean indicating if there was one. Does not block." } ;
-
 HELP: add-observer
 { $values { "observer" "an " { $snippet "NSObject" } } { "selector" string } { "name" "an " { $snippet "NSString" } } { "object" "an " { $snippet "NSObject" } } }
 { $description "Registers an observer with the " { $snippet "NSNotificationCenter" } " singleton." } ;
@@ -52,7 +48,6 @@ HELP: objc-error
 ARTICLE: "cocoa-application-utils" "Cocoa application utilities"
 "Utilities:"
 { $subsection NSApp }
-{ $subsection do-event }
 { $subsection add-observer }
 { $subsection remove-observer }
 { $subsection install-delegate }

basis/cocoa/application/application.factor

@@ -1,10 +1,10 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.syntax io kernel namespaces core-foundation
-core-foundation.run-loop core-foundation.arrays
+core-foundation.arrays core-foundation.data
-core-foundation.data core-foundation.strings cocoa.messages
+core-foundation.strings cocoa.messages cocoa cocoa.classes
-cocoa cocoa.classes cocoa.runtime sequences threads init summary
+cocoa.runtime sequences threads init summary kernel.private
-kernel.private assocs ;
+assocs ;
 IN: cocoa.application
 
 : <NSString> ( str -- alien ) <CFString> -> autorelease ;
@@ -35,13 +35,6 @@ FUNCTION: void NSBeep ( ) ;
 : with-cocoa ( quot -- )
     [ NSApp drop call ] with-autorelease-pool ; inline
 
-: next-event ( app -- event )
-    NSAnyEventMask f CFRunLoopDefaultMode 1
-    -> nextEventMatchingMask:untilDate:inMode:dequeue: ;
-
-: do-event ( app -- ? )
-    dup next-event [ dupd -> sendEvent: -> updateWindows t ] [ drop f ] if* ;
-
 : add-observer ( observer selector name object -- )
     [
         [ NSNotificationCenter -> defaultCenter ] 2dip

basis/cocoa/views/views-docs.factor

@@ -2,7 +2,7 @@ USING: help.syntax help.markup ;
 IN: cocoa.views
 
 HELP: <PixelFormat>
-{ $values { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
+{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
 { $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ;
 
 HELP: <GLView>

basis/cocoa/windows/windows.factor

@@ -14,7 +14,7 @@ IN: cocoa.windows
 : NSBackingStoreNonretained 1 ; inline
 : NSBackingStoreBuffered    2 ; inline
 
-: standard-window-type
+: standard-window-type ( -- n )
     {
         NSTitledWindowMask
         NSClosableWindowMask

basis/columns/columns-docs.factor

@@ -4,8 +4,8 @@ IN: columns
 HELP: column
 { $class-description "A virtual sequence which presents a fixed column of a matrix represented as a sequence of rows. New instances can be created by calling " { $link <column> } "." } ;
 
-HELP: <column> ( seq n -- column )
+HELP: <column>
-{ $values { "seq" sequence } { "n" "a non-negative integer" } { "column" column } }
+{ $values { "seq" sequence } { "col" "a non-negative integer" } { "column" column } }
 { $description "Outputs a new virtual sequence which presents a fixed column of a matrix represented as a sequence of rows." "The " { $snippet "i" } "th element of a column is the " { $snippet "n" } "th element of the " { $snippet "i" } "th element of " { $snippet "seq" } ". Every element of " { $snippet "seq" } " must be a sequence, and all sequences must have equal length." }
 { $examples
     { $example

basis/columns/columns.factor

@@ -9,7 +9,7 @@ TUPLE: column seq col ;
 C: <column> column
 
 M: column virtual-seq seq>> ;
-M: column virtual@ dup col>> -rot seq>> nth bounds-check ;
+M: column virtual@ [ col>> swap ] [ seq>> ] bi nth bounds-check ;
 M: column length seq>> length ;
 
 INSTANCE: column virtual-sequence

basis/combinators/smart/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/combinators/smart/smart-docs.factor

@@ -0,0 +1,125 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel quotations math sequences
+multiline ;
+IN: combinators.smart
+
+HELP: input<sequence
+{ $values
+     { "quot" quotation }
+     { "newquot" quotation }
+}
+{ $description "Infers the number of inputs, " { $snippet "n" } ", to " { $snippet "quot" } " and calls the " { $snippet "quot" } " with the first " { $snippet "n" } " values from a sequence." }
+{ $examples
+    { $example
+        "USING: combinators.smart math prettyprint ;"
+        "{ 1 2 3 } [ + + ] input<sequence ."
+        "6"
+    }
+} ;
+
+HELP: output>array
+{ $values
+     { "quot" quotation }
+     { "newquot" quotation }
+}
+{ $description "Infers the number or outputs from the quotation and constructs an array from those outputs." }
+{ $examples
+    { $example
+        <" USING: combinators combinators.smart math prettyprint ;
+9 [
+    { [ 1- ] [ 1+ ] [ sq ] } cleave
+] output>array .">
+    "{ 8 10 81 }"
+    }
+} ;
+
+HELP: output>sequence
+{ $values
+     { "quot" quotation } { "exemplar" "an exemplar" }
+     { "newquot" quotation }
+}
+{ $description "Infers the number of outputs from the quotation and constructs a new sequence from those objects of the same type as the exemplar." }
+{ $examples
+    { $example
+        "USING: combinators.smart kernel math prettyprint ;"
+        "4 [ [ 1 + ] [ 2 + ] [ 3 + ] tri ] V{ } output>sequence ."
+        "V{ 5 6 7 }"
+    }
+} ;
+
+HELP: reduce-outputs
+{ $values
+     { "quot" quotation } { "operation" quotation }
+     { "newquot" quotation }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and reduces them using " { $snippet "operation" } ". The identity for the " { $link reduce } " operation is the first output." }
+{ $examples
+    { $example
+        "USING: combinators.smart kernel math prettyprint ;"
+        "3 [ [ 4 * ] [ 4 / ] [ 4 - ] tri ] [ * ] reduce-outputs ."
+        "-9"
+    }
+} ;
+
+HELP: sum-outputs
+{ $values
+     { "quot" quotation }
+     { "n" integer }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns their sum." }
+{ $examples
+    { $example
+        "USING: combinators.smart kernel math prettyprint ;"
+        "10 [ [ 1- ] [ 1+ ] bi ] sum-outputs ."
+        "20"
+    }
+} ;
+
+HELP: append-outputs
+{ $values
+     { "quot" quotation }
+     { "seq" sequence }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns a sequence of the outputs appended." }
+{ $examples
+    { $example
+        "USING: combinators.smart prettyprint ;"
+        "[ { 1 2 } { \"A\" \"b\" } ] append-outputs ."
+        "{ 1 2 \"A\" \"b\" }"
+    }
+} ;
+
+HELP: append-outputs-as
+{ $values
+     { "quot" quotation } { "exemplar" sequence }
+     { "seq" sequence }
+}
+{ $description "Infers the number of outputs from " { $snippet "quot" } " and returns a sequence of type " { $snippet "exemplar" } " of the outputs appended." }
+{ $examples
+    { $example
+        "USING: combinators.smart prettyprint ;"
+        "[ { 1 2 } { \"A\" \"b\" } ] V{ } append-outputs-as ."
+        "V{ 1 2 \"A\" \"b\" }"
+    }
+} ;
+
+{ append-outputs append-outputs-as } related-words
+
+
+ARTICLE: "combinators.smart" "Smart combinators"
+"The " { $vocab-link "combinators.smart" } " vocabulary implements " { $emphasis "smart combinators" } ". A smart combinator is one whose behavior depends on the static stack effect of an input quotation." $nl
+"Smart inputs from a sequence:"
+{ $subsection input<sequence }
+"Smart outputs to a sequence:"
+{ $subsection output>sequence }
+{ $subsection output>array }
+"Reducing the output of a quotation:"
+{ $subsection reduce-outputs }
+"Summing the output of a quotation:"
+{ $subsection sum-outputs }
+"Appending the results of a quotation:"
+{ $subsection append-outputs }
+{ $subsection append-outputs-as } ;
+
+ABOUT: "combinators.smart"

basis/combinators/smart/smart-tests.factor

@@ -0,0 +1,39 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test combinators.smart math kernel ;
+IN: combinators.smart.tests
+
+: test-bi ( -- 9 11 )
+    10 [ 1- ] [ 1+ ] bi ;
+
+[ [ test-bi ] output>array ] must-infer
+[ { 9 11 } ] [ [ test-bi ] output>array ] unit-test
+
+[ { 9 11 } [ + ] input<sequence ] must-infer
+[ 20 ] [ { 9 11 } [ + ] input<sequence ] unit-test
+
+[ 6 ] [ [ 1 2 3 ] [ + ] reduce-outputs ] unit-test
+
+[ [ 1 2 3 ] [ + ] reduce-outputs ] must-infer
+
+[ 6 ] [ [ 1 2 3 ] sum-outputs ] unit-test
+
+[ "ab" ]
+[
+    [ "a" "b" ] "" append-outputs-as
+] unit-test
+
+[ "" ]
+[
+    [ ] "" append-outputs-as
+] unit-test
+
+[ { } ]
+[
+    [ ] append-outputs
+] unit-test
+
+[ B{ 1 2 3 } ]
+[
+    [ { 1 } { 2 } { 3 } ] B{ } append-outputs-as
+] unit-test

basis/combinators/smart/smart.factor

@@ -0,0 +1,28 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors fry generalizations kernel macros math.order
+stack-checker math ;
+IN: combinators.smart
+
+MACRO: output>sequence ( quot exemplar -- newquot )
+    [ dup infer out>> ] dip
+    '[ @ _ _ nsequence ] ;
+
+: output>array ( quot -- newquot )
+    { } output>sequence ; inline
+
+MACRO: input<sequence ( quot -- newquot )
+    [ infer in>> ] keep
+    '[ _ firstn @ ] ;
+
+MACRO: reduce-outputs ( quot operation -- newquot )
+    [ dup infer out>> 1 [-] ] dip n*quot compose ;
+
+: sum-outputs ( quot -- n )
+    [ + ] reduce-outputs ; inline
+
+MACRO: append-outputs-as ( quot exemplar -- newquot )
+    [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;
+
+: append-outputs ( quot -- seq )
+    { } append-outputs-as ; inline

basis/command-line/command-line.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2003, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: init continuations hashtables io io.encodings.utf8
-io.files kernel kernel.private namespaces parser sequences
+io.files io.pathnames kernel kernel.private namespaces parser
-strings system splitting vocabs.loader ;
+sequences strings system splitting vocabs.loader ;
 IN: command-line
 
 SYMBOL: script

basis/compiler/cfg/alias-analysis/alias-analysis-tests.factor

@@ -13,7 +13,7 @@ IN: compiler.cfg.alias-analysis.tests
 
 [ ] [
     {
-        T{ ##load-indirect f V int-regs 1 "hello" }
+        T{ ##load-reference f V int-regs 1 "hello" }
         T{ ##slot-imm f V int-regs 0 V int-regs 1 0 3 }
     } alias-analysis drop
 ] unit-test

basis/compiler/cfg/alias-analysis/alias-analysis.factor

@@ -68,7 +68,8 @@ IN: compiler.cfg.alias-analysis
 ! Map vregs -> alias classes
 SYMBOL: vregs>acs
 
-: check [ "BUG: static type error detected" throw ] unless* ; inline
+: check ( obj -- obj )
+    [ "BUG: static type error detected" throw ] unless* ; inline
  
 : vreg>ac ( vreg -- ac )
     #! Only vregs produced by ##allot, ##peek and ##slot can
@@ -223,7 +224,7 @@ GENERIC: analyze-aliases* ( insn -- insn' )
 M: ##load-immediate analyze-aliases*
     dup [ val>> ] [ dst>> ] bi constants get set-at ;
 
-M: ##load-indirect analyze-aliases*
+M: ##load-reference analyze-aliases*
     dup dst>> set-heap-ac ;
 
 M: ##alien-global analyze-aliases*

basis/compiler/cfg/builder/builder-tests.factor

@@ -14,7 +14,7 @@ kernel.private math ;
     [ ]
     [ dup ]
     [ swap ]
-    [ >r r> ]
+    [ [ ] dip ]
     [ fixnum+ ]
     [ fixnum+fast ]
     [ 3 fixnum+fast ]

basis/compiler/cfg/hats/hats.factor

@@ -5,17 +5,17 @@ sequences classes.tuple cpu.architecture compiler.cfg.registers
 compiler.cfg.instructions ;
 IN: compiler.cfg.hats
 
-: i int-regs next-vreg ; inline
+: i ( -- vreg ) int-regs next-vreg ; inline
-: ^^i i dup ; inline
+: ^^i ( -- vreg vreg ) i dup ; inline
-: ^^i1 [ ^^i ] dip ; inline
+: ^^i1 ( obj -- vreg vreg obj ) [ ^^i ] dip ; inline
-: ^^i2 [ ^^i ] 2dip ; inline
+: ^^i2 ( obj obj -- vreg vreg obj obj ) [ ^^i ] 2dip ; inline
-: ^^i3 [ ^^i ] 3dip ; inline
+: ^^i3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^i ] 3dip ; inline
 
-: d double-float-regs next-vreg ; inline
+: d ( -- vreg ) double-float-regs next-vreg ; inline
-: ^^d d dup ; inline
+: ^^d  ( -- vreg vreg ) d dup ; inline
-: ^^d1 [ ^^d ] dip ; inline
+: ^^d1 ( obj -- vreg vreg obj ) [ ^^d ] dip ; inline
-: ^^d2 [ ^^d ] 2dip ; inline
+: ^^d2 ( obj obj -- vreg vreg obj obj ) [ ^^d ] 2dip ; inline
-: ^^d3 [ ^^d ] 3dip ; inline
+: ^^d3 ( obj obj obj -- vreg vreg obj obj obj ) [ ^^d ] 3dip ; inline
 
 : ^^load-literal ( obj -- dst ) ^^i1 ##load-literal ; inline
 : ^^peek ( loc -- dst ) ^^i1 ##peek ; inline

basis/compiler/cfg/instructions/instructions.factor

@@ -36,13 +36,13 @@ TUPLE: ##alien-setter < ##effect { value vreg } ;
 
 ! Stack operations
 INSN: ##load-immediate < ##pure { val integer } ;
-INSN: ##load-indirect < ##pure obj ;
+INSN: ##load-reference < ##pure obj ;
 
 GENERIC: ##load-literal ( dst value -- )
 
 M: fixnum ##load-literal tag-fixnum ##load-immediate ;
 M: f ##load-literal drop \ f tag-number ##load-immediate ;
-M: object ##load-literal ##load-indirect ;
+M: object ##load-literal ##load-reference ;
 
 INSN: ##peek < ##read { loc loc } ;
 INSN: ##replace < ##write { loc loc } ;

basis/compiler/cfg/instructions/syntax/syntax.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: classes.tuple classes.tuple.parser kernel words
-make fry sequences parser ;
+make fry sequences parser accessors ;
 IN: compiler.cfg.instructions.syntax
 
 : insn-word ( -- word )
@@ -10,10 +10,13 @@ IN: compiler.cfg.instructions.syntax
     #! this one.
     "insn" "compiler.cfg.instructions" lookup ;
 
+: insn-effect ( word -- effect )
+    boa-effect [ but-last ] change-in { } >>out ;
+
 : INSN:
     parse-tuple-definition "regs" suffix
     [ dup tuple eq? [ drop insn-word ] when ] dip
     [ define-tuple-class ]
     [ 2drop save-location ]
-    [ 2drop dup '[ f _ boa , ] define-inline ]
+    [ 2drop [ ] [ '[ f _ boa , ] ] [ insn-effect ] tri define-inline ]
     3tri ; parsing

basis/compiler/cfg/intrinsics/intrinsics.factor

@@ -1,7 +1,6 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: qualified words sequences kernel combinators
+USING: words sequences kernel combinators cpu.architecture
-cpu.architecture
 compiler.cfg.hats
 compiler.cfg.instructions
 compiler.cfg.intrinsics.alien

basis/compiler/cfg/linear-scan/linear-scan-tests.factor

@@ -1,7 +1,7 @@
 IN: compiler.cfg.linear-scan.tests
 USING: tools.test random sorting sequences sets hashtables assocs
 kernel fry arrays splitting namespaces math accessors vectors
-math.order
+math.order grouping
 cpu.architecture
 compiler.cfg.instructions
 compiler.cfg.registers
@@ -249,7 +249,7 @@ SYMBOL: max-uses
     ] with-scope ;
 
 : random-test ( num-intervals max-uses max-registers max-insns -- )
-    over >r random-live-intervals r> int-regs associate check-linear-scan ;
+    over [ random-live-intervals ] dip int-regs associate check-linear-scan ;
 
 [ ] [ 30 2 1 60 random-test ] unit-test
 [ ] [ 60 2 2 60 random-test ] unit-test

basis/compiler/cfg/linearization/linearization.factor

@@ -37,7 +37,7 @@ M: insn linearize-insn , drop ;
 M: ##branch linearize-insn
     drop dup successors>> first emit-branch ;
 
-: (binary-conditional)
+: (binary-conditional) ( basic-block insn -- basic-block successor1 successor2 src1 src2 cc )
     [ dup successors>> first2 ]
     [ [ src1>> ] [ src2>> ] [ cc>> ] tri ] bi* ; inline
 
@@ -63,7 +63,7 @@ M: ##compare-float-branch linearize-insn
             ##box-float
             ##box-alien
         } memq?
-    ] contains? ;
+    ] any? ;
 
 : linearize-basic-block ( bb -- )
     [ number>> _label ]

basis/compiler/cfg/value-numbering/expressions/expressions.factor

@@ -39,8 +39,6 @@ GENERIC: >expr ( insn -- expr )
 
 M: ##load-immediate >expr val>> <constant> ;
 
-M: ##load-indirect >expr obj>> <constant> ;
-
 M: ##unary >expr
     [ class ] [ src>> vreg>vn ] bi unary-expr boa ;
 

basis/compiler/cfg/value-numbering/value-numbering-tests.factor

@@ -81,7 +81,7 @@ sequences ;
 
 [
     {
-        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##load-reference f V int-regs 1 + }
         T{ ##peek f V int-regs 2 D 0 }
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
         T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
@@ -89,7 +89,7 @@ sequences ;
     }
 ] [
     {
-        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##load-reference f V int-regs 1 + }
         T{ ##peek f V int-regs 2 D 0 }
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc> }
         T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc/= }
@@ -99,7 +99,7 @@ sequences ;
 
 [
     {
-        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##load-reference f V int-regs 1 + }
         T{ ##peek f V int-regs 2 D 0 }
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
         T{ ##compare f V int-regs 6 V int-regs 2 V int-regs 1 cc> }
@@ -107,7 +107,7 @@ sequences ;
     }
 ] [
     {
-        T{ ##load-indirect f V int-regs 1 + }
+        T{ ##load-reference f V int-regs 1 + }
         T{ ##peek f V int-regs 2 D 0 }
         T{ ##compare f V int-regs 4 V int-regs 2 V int-regs 1 cc<= }
         T{ ##compare-imm f V int-regs 6 V int-regs 4 7 cc= }

basis/compiler/codegen/codegen.factor

@@ -1,9 +1,9 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces make math math.order math.parser sequences accessors
 kernel kernel.private layouts assocs words summary arrays
 combinators classes.algebra alien alien.c-types alien.structs
-alien.strings alien.arrays sets threads libc continuations.private
+alien.strings alien.arrays sets libc continuations.private
 fry cpu.architecture
 compiler.errors
 compiler.alien
@@ -11,7 +11,8 @@ compiler.cfg
 compiler.cfg.instructions
 compiler.cfg.registers
 compiler.cfg.builder
-compiler.codegen.fixup ;
+compiler.codegen.fixup
+compiler.utilities ;
 IN: compiler.codegen
 
 GENERIC: generate-insn ( insn -- )
@@ -69,8 +70,8 @@ SYMBOL: labels
 M: ##load-immediate generate-insn
     [ dst>> register ] [ val>> ] bi %load-immediate ;
 
-M: ##load-indirect generate-insn
+M: ##load-reference generate-insn
-    [ dst>> register ] [ obj>> ] bi %load-indirect ;
+    [ dst>> register ] [ obj>> ] bi %load-reference ;
 
 M: ##peek generate-insn
     [ dst>> register ] [ loc>> ] bi %peek ;
@@ -95,7 +96,7 @@ M: ##dispatch-label generate-insn label>> %dispatch-label ;
 M: ##dispatch generate-insn
     [ src>> register ] [ temp>> register ] [ offset>> ] tri %dispatch ;
 
-: >slot<
+: >slot< ( insn -- dst obj slot tag )
     {
         [ dst>> register ]
         [ obj>> register ]
@@ -109,7 +110,7 @@ M: ##slot generate-insn
 M: ##slot-imm generate-insn
     >slot< %slot-imm ;
 
-: >set-slot<
+: >set-slot< ( insn -- src obj slot tag )
     {
         [ src>> register ]
         [ obj>> register ]
@@ -209,7 +210,8 @@ M: ##alien-cell       generate-insn dst/src %alien-cell       ;
 M: ##alien-float      generate-insn dst/src %alien-float      ;
 M: ##alien-double     generate-insn dst/src %alien-double     ;
 
-: >alien-setter< [ src>> register ] [ value>> register ] bi ; inline
+: >alien-setter< ( insn -- src value )
+    [ src>> register ] [ value>> register ] bi ; inline
 
 M: ##set-alien-integer-1 generate-insn >alien-setter< %set-alien-integer-1 ;
 M: ##set-alien-integer-2 generate-insn >alien-setter< %set-alien-integer-2 ;
@@ -398,7 +400,7 @@ M: no-such-symbol compiler-error-type
 
 : check-dlsym ( symbols dll -- )
     dup dll-valid? [
-        dupd '[ _ dlsym ] contains?
+        dupd '[ _ dlsym ] any?
         [ drop ] [ no-such-symbol ] if
     ] [
         dll-path no-such-library drop
@@ -462,7 +464,7 @@ TUPLE: callback-context ;
     dup current-callback eq? [
         drop
     ] [
-        yield wait-to-return
+        yield-hook get call wait-to-return
     ] if ;
 
 : do-callback ( quot token -- )

basis/compiler/compiler.factor

@@ -1,14 +1,14 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces arrays sequences io
 words fry continuations vocabs assocs dlists definitions math
-threads graphs generic combinators deques search-deques io
+graphs generic combinators deques search-deques io
 stack-checker stack-checker.state stack-checker.inlining
 compiler.errors compiler.units compiler.tree.builder
 compiler.tree.optimizer compiler.cfg.builder
 compiler.cfg.optimizer compiler.cfg.linearization
 compiler.cfg.two-operand compiler.cfg.linear-scan
-compiler.cfg.stack-frame compiler.codegen ;
+compiler.cfg.stack-frame compiler.codegen compiler.utilities ;
 IN: compiler
 
 SYMBOL: compile-queue
@@ -24,7 +24,7 @@ SYMBOL: compiled
     } cond drop ;
 
 : maybe-compile ( word -- )
-    dup compiled>> [ drop ] [ queue-compile ] if ;
+    dup optimized>> [ drop ] [ queue-compile ] if ;
 
 SYMBOL: +failed+
 
@@ -107,10 +107,10 @@ t compile-dependencies? set-global
     ] with-return ;
 
 : compile-loop ( deque -- )
-    [ (compile) yield ] slurp-deque ;
+    [ (compile) yield-hook get call ] slurp-deque ;
 
 : decompile ( word -- )
-    f 2array 1array t modify-code-heap ;
+    f 2array 1array modify-code-heap ;
 
 : optimized-recompile-hook ( words -- alist )
     [

basis/compiler/tests/codegen.factor

@@ -75,7 +75,7 @@ unit-test
     -12 -13 [ [ 0 swap fixnum-fast ] bi@ ] compile-call
 ] unit-test
 
-[ -1 2 ] [ 1 2 [ >r 0 swap fixnum- r> ] compile-call ] unit-test
+[ -1 2 ] [ 1 2 [ [ 0 swap fixnum- ] dip ] compile-call ] unit-test
 
 [ 12 13 ] [
     -12 -13 [ [ 0 swap fixnum- ] bi@ ] compile-call
@@ -88,13 +88,13 @@ unit-test
 ! Test slow shuffles
 [ 3 1 2 3 4 5 6 7 8 9 ] [
     1 2 3 4 5 6 7 8 9
-    [ >r >r >r >r >r >r >r >r >r 3 r> r> r> r> r> r> r> r> r> ]
+    [ [ [ [ [ [ [ [ [ [ 3 ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ] dip ]
     compile-call
 ] unit-test
 
 [ 2 2 2 2 2 2 2 2 2 2 1 ] [
     1 2
-    [ swap >r dup dup dup dup dup dup dup dup dup r> ] compile-call
+    [ swap [ dup dup dup dup dup dup dup dup dup ] dip ] compile-call
 ] unit-test
 
 [ ] [ [ 9 [ ] times ] compile-call ] unit-test
@@ -110,7 +110,7 @@ unit-test
     float+ swap { [ "hey" ] [ "bye" ] } dispatch ;
 
 : try-breaking-dispatch-2 ( -- ? )
-    1 1.0 2.5 try-breaking-dispatch "bye" = >r 3.5 = r> and ;
+    1 1.0 2.5 try-breaking-dispatch "bye" = [ 3.5 = ] dip and ;
 
 [ t ] [
     10000000 [ drop try-breaking-dispatch-2 ] all?
@@ -131,10 +131,10 @@ unit-test
     2dup 1 slot eq? [ 2drop ] [ 
         2dup array-nth tombstone? [ 
             [
-                [ array-nth ] 2keep >r 1 fixnum+fast r> array-nth
+                [ array-nth ] 2keep [ 1 fixnum+fast ] dip array-nth
                 pick 2dup hellish-bug-1 3drop
             ] 2keep
-        ] unless >r 2 fixnum+fast r> hellish-bug-2
+        ] unless [ 2 fixnum+fast ] dip hellish-bug-2
     ] if ; inline recursive
 
 : hellish-bug-3 ( hash array -- ) 
@@ -159,9 +159,9 @@ TUPLE: my-tuple ;
 [ 5 ] [ "hi" foox ] unit-test
 
 ! Making sure we don't needlessly unbox/rebox
-[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ >r eq? r> ] compile-call ] unit-test
+[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ [ eq? ] dip ] compile-call ] unit-test
 
-[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call >r eq? r> ] unit-test
+[ t 3.0 ] [ 1.0 dup [ dup 2.0 float+ ] compile-call [ eq? ] dip ] unit-test
 
 [ t ] [ 1.0 dup [ [ 2.0 float+ ] keep ] compile-call nip eq? ] unit-test
 
@@ -188,7 +188,7 @@ TUPLE: my-tuple ;
 
 [ 2 1 ] [
     2 1
-    [ 2dup fixnum< [ >r die r> ] when ] compile-call
+    [ 2dup fixnum< [ [ die ] dip ] when ] compile-call
 ] unit-test
 
 ! Regression
@@ -211,7 +211,7 @@ TUPLE: my-tuple ;
     { tuple vector } 3 slot { word } declare
     dup 1 slot 0 fixnum-bitand { [ ] } dispatch ;
 
-[ t ] [ \ dispatch-alignment-regression compiled>> ] unit-test
+[ t ] [ \ dispatch-alignment-regression optimized>> ] unit-test
 
 [ vector ] [ dispatch-alignment-regression ] unit-test
 
@@ -276,3 +276,9 @@ TUPLE: id obj ;
 
 [ 4 ] [ 2 [ dup fixnum* ] compile-call ] unit-test
 [ 7 ] [ 2 [ dup fixnum* 3 fixnum+fast ] compile-call ] unit-test
+
+TUPLE: cucumber ;
+
+M: cucumber equal? "The cucumber has no equal" throw ;
+
+[ t ] [ [ cucumber ] compile-call cucumber eq? ] unit-test

basis/compiler/tests/curry.factor

@@ -8,7 +8,7 @@ IN: compiler.tests
 [ 3 ] [ 5 [ 2 [ - ] 2curry call ] compile-call ] unit-test
 [ 3 ] [ 5 2 [ [ - ] 2curry call ] compile-call ] unit-test
 [ 3 ] [ 5 2 [ [ - ] 2curry 9 swap call /i ] compile-call ] unit-test
-[ 3 ] [ 5 2 [ [ - ] 2curry >r 9 r> call /i ] compile-call ] unit-test
+[ 3 ] [ 5 2 [ [ - ] 2curry [ 9 ] dip call /i ] compile-call ] unit-test
 
 [ -10 -20 ] [ 10 20 -1 [ [ * ] curry bi@ ] compile-call ] unit-test
 
@@ -21,14 +21,14 @@ IN: compiler.tests
 [ [ 6 2 + ] ]
 [
     2 5
-    [ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry ]
+    [ [ [ + ] curry ] dip 0 < [ -2 ] [ 6 ] if swap curry ]
     compile-call >quotation
 ] unit-test
 
 [ 8 ]
 [
     2 5
-    [ >r [ + ] curry r> 0 < [ -2 ] [ 6 ] if swap curry call ]
+    [ [ [ + ] curry ] dip 0 < [ -2 ] [ 6 ] if swap curry call ]
     compile-call
 ] unit-test
 

basis/compiler/tests/optimizer.factor

@@ -9,7 +9,7 @@ IN: optimizer.tests
 GENERIC: xyz ( obj -- obj )
 M: array xyz xyz ;
 
-[ t ] [ \ xyz compiled>> ] unit-test
+[ t ] [ \ xyz optimized>> ] unit-test
 
 ! Test predicate inlining
 : pred-test-1
@@ -94,7 +94,7 @@ TUPLE: pred-test ;
 ! regression
 GENERIC: void-generic ( obj -- * )
 : breakage ( -- * ) "hi" void-generic ;
-[ t ] [ \ breakage compiled>> ] unit-test
+[ t ] [ \ breakage optimized>> ] unit-test
 [ breakage ] must-fail
 
 ! regression
@@ -119,7 +119,7 @@ GENERIC: void-generic ( obj -- * )
 ! compiling <tuple> with a non-literal class failed
 : <tuple>-regression ( class -- tuple ) <tuple> ;
 
-[ t ] [ \ <tuple>-regression compiled>> ] unit-test
+[ t ] [ \ <tuple>-regression optimized>> ] unit-test
 
 GENERIC: foozul ( a -- b )
 M: reversed foozul ;
@@ -228,7 +228,7 @@ USE: binary-search.private
 : node-successor-f-bug ( x -- * )
     [ 3 throw ] [ empty-compound ] compose [ 3 throw ] if ;
 
-[ t ] [ \ node-successor-f-bug compiled>> ] unit-test
+[ t ] [ \ node-successor-f-bug optimized>> ] unit-test
 
 [ ] [ [ new ] build-tree optimize-tree drop ] unit-test
 
@@ -242,18 +242,18 @@ USE: binary-search.private
         ] if
     ] if ;
 
-[ t ] [ \ lift-throw-tail-regression compiled>> ] unit-test
+[ t ] [ \ lift-throw-tail-regression optimized>> ] unit-test
 [ 3 "an integer" ] [ 3 lift-throw-tail-regression ] unit-test
 [ "hi" "a string" ] [ "hi" lift-throw-tail-regression ] unit-test
 
 : lift-loop-tail-test-1 ( a quot -- )
     over even? [
-        [ >r 3 - r> call ] keep lift-loop-tail-test-1
+        [ [ 3 - ] dip call ] keep lift-loop-tail-test-1
     ] [
         over 0 < [
             2drop
         ] [
-            [ >r 2 - r> call ] keep lift-loop-tail-test-1
+            [ [ 2 - ] dip call ] keep lift-loop-tail-test-1
         ] if
     ] if ; inline
 
@@ -271,7 +271,7 @@ HINTS: recursive-inline-hang array ;
 : recursive-inline-hang-1 ( -- a )
     { } recursive-inline-hang ;
 
-[ t ] [ \ recursive-inline-hang-1 compiled>> ] unit-test
+[ t ] [ \ recursive-inline-hang-1 optimized>> ] unit-test
 
 DEFER: recursive-inline-hang-3
 
@@ -290,7 +290,7 @@ HINTS: recursive-inline-hang-3 array ;
 
 ! Wow
 : counter-example ( a b c d -- a' b' c' d' )
-    dup 0 > [ 1 - >r rot 2 * r> counter-example ] when ; inline
+    dup 0 > [ 1 - [ rot 2 * ] dip counter-example ] when ; inline
 
 : counter-example' ( -- a' b' c' d' )
     1 2 3.0 3 counter-example ;
@@ -330,7 +330,7 @@ PREDICATE: list < improper-list
 [ 0 5 ] [ 0 interval-inference-bug ] unit-test
 
 : aggressive-flush-regression ( a -- b )
-    f over >r <array> drop r> 1 + ;
+    f over [ <array> drop ] dip 1 + ;
 
 [ 1.0 aggressive-flush-regression drop ] must-fail
 

basis/compiler/tests/peg-regression.factor

@@ -22,5 +22,5 @@ pipeline = "hello" => [[ ast>pipeline-expr ]]
 
 USE: tools.test
 
-[ t ] [ \ expr compiled>> ] unit-test
+[ t ] [ \ expr optimized>> ] unit-test
-[ t ] [ \ ast>pipeline-expr compiled>> ] unit-test
+[ t ] [ \ ast>pipeline-expr optimized>> ] unit-test

basis/compiler/tests/redefine1.factor

@@ -23,36 +23,36 @@ M: integer method-redefine-test 3 + ;
 : hey ( -- ) ;
 : there ( -- ) hey ;
 
-[ t ] [ \ hey compiled>> ] unit-test
+[ t ] [ \ hey optimized>> ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
 [ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval ] unit-test
-[ f ] [ \ hey compiled>> ] unit-test
+[ f ] [ \ hey optimized>> ] unit-test
-[ f ] [ \ there compiled>> ] unit-test
+[ f ] [ \ there optimized>> ] unit-test
 [ ] [ "IN: compiler.tests : hey ( -- ) ;" eval ] unit-test
-[ t ] [ \ there compiled>> ] unit-test
+[ t ] [ \ there optimized>> ] unit-test
 
 : good ( -- ) ;
 : bad ( -- ) good ;
 : ugly ( -- ) bad ;
 
-[ t ] [ \ good compiled>> ] unit-test
+[ t ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
 
 [ f ] [ \ good compiled-usage assoc-empty? ] unit-test
 
 [ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval ] unit-test
 
-[ f ] [ \ good compiled>> ] unit-test
+[ f ] [ \ good optimized>> ] unit-test
-[ f ] [ \ bad compiled>> ] unit-test
+[ f ] [ \ bad optimized>> ] unit-test
-[ f ] [ \ ugly compiled>> ] unit-test
+[ f ] [ \ ugly optimized>> ] unit-test
 
 [ t ] [ \ good compiled-usage assoc-empty? ] unit-test
 
 [ ] [ "IN: compiler.tests : good ( -- ) ;" eval ] unit-test
 
-[ t ] [ \ good compiled>> ] unit-test
+[ t ] [ \ good optimized>> ] unit-test
-[ t ] [ \ bad compiled>> ] unit-test
+[ t ] [ \ bad optimized>> ] unit-test
-[ t ] [ \ ugly compiled>> ] unit-test
+[ t ] [ \ ugly optimized>> ] unit-test
 
 [ f ] [ \ good compiled-usage assoc-empty? ] unit-test

basis/compiler/tests/redefine3.factor

@@ -14,7 +14,7 @@ M: empty-mixin sheeple drop "wake up" ;
 : sheeple-test ( -- string ) { } sheeple ;
 
 [ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled>> ] unit-test
+[ t ] [ \ sheeple-test optimized>> ] unit-test
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 
@@ -27,6 +27,6 @@ M: empty-mixin sheeple drop "wake up" ;
 [ ] [ [ array empty-mixin remove-mixin-instance ] with-compilation-unit ] unit-test
 
 [ "sheeple" ] [ sheeple-test ] unit-test
-[ t ] [ \ sheeple-test compiled>> ] unit-test
+[ t ] [ \ sheeple-test optimized>> ] unit-test
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

basis/compiler/tests/simple.factor

@@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
 10 [
     [ "compiler.tests.foo" forget-vocab ] with-compilation-unit
     [ t ] [
-        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) compiled>>" eval
+        "USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval
     ] unit-test
 ] times

basis/compiler/tests/spilling.factor

@@ -47,7 +47,7 @@ IN: compiler.tests
 [ 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 2.0 ]
 [ 1.0 float-spill-bug ] unit-test
 
-[ t ] [ \ float-spill-bug compiled>> ] unit-test
+[ t ] [ \ float-spill-bug optimized>> ] unit-test
 
 : float-fixnum-spill-bug ( object -- object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object object )
     {
@@ -132,7 +132,7 @@ IN: compiler.tests
 [ 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 2.0 2 ]
 [ 1.0 float-fixnum-spill-bug ] unit-test
 
-[ t ] [ \ float-fixnum-spill-bug compiled>> ] unit-test
+[ t ] [ \ float-fixnum-spill-bug optimized>> ] unit-test
 
 : resolve-spill-bug ( a b -- c )
     [ 1 fixnum+fast ] bi@ dup 10 fixnum< [
@@ -159,7 +159,7 @@ IN: compiler.tests
         16 narray
     ] if ;
 
-[ t ] [ \ resolve-spill-bug compiled>> ] unit-test
+[ t ] [ \ resolve-spill-bug optimized>> ] unit-test
 
 [ 4 ] [ 1 1 resolve-spill-bug ] unit-test
 

basis/compiler/tests/stack-trace.factor

@@ -19,14 +19,14 @@ words splitting grouping sorting accessors ;
 
 : bleh ( seq -- seq' ) [ 3 + ] map [ 0 > ] filter ;
 
-: stack-trace-contains? ( word -- ? ) symbolic-stack-trace memq? ;
+: stack-trace-any? ( word -- ? ) symbolic-stack-trace memq? ;
 
 [ t ] [
-    [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-contains?
+    [ { 1 "hi" } bleh ] ignore-errors \ + stack-trace-any?
 ] unit-test
     
 [ t f ] [
     [ { "hi" } bleh ] ignore-errors
-    \ + stack-trace-contains?
+    \ + stack-trace-any?
-    \ > stack-trace-contains?
+    \ > stack-trace-any?
 ] unit-test

basis/compiler/tree/builder/builder-tests.factor

@@ -8,4 +8,4 @@ compiler.tree ;
 
 : inline-recursive ( -- ) inline-recursive ; inline recursive
 
-[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] contains? nip ] unit-test
+[ t ] [ \ inline-recursive build-tree-from-word [ #recursive? ] any? nip ] unit-test

basis/compiler/tree/checker/checker.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: sequences kernel sets namespaces accessors assocs
 arrays combinators continuations columns math vectors
-stack-checker.branches
+grouping stack-checker.branches
 compiler.tree
 compiler.tree.def-use
 compiler.tree.combinators ;
@@ -175,7 +175,7 @@ M: #branch check-stack-flow*
     branch-out get [ ] find nip swap head* >vector datastack set ;
 
 M: #phi check-stack-flow*
-    branch-out get [ ] contains? [
+    branch-out get [ ] any? [
         [ check-phi-in ] [ set-phi-datastack ] [ check-out-d ] tri
     ] [ drop terminated? on ] if ;
 

basis/compiler/tree/cleanup/cleanup-tests.factor

@@ -498,7 +498,7 @@ cell-bits 32 = [
 
 [ t ] [
     [ { array-capacity } declare 1 fixnum+ ] cleaned-up-tree
-    [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] contains?
+    [ { [ #call? ] [ node-input-infos second literal>> 1 = ] } 1&& ] any?
 ] unit-test
 
 [ ] [

basis/compiler/tree/combinators/combinators.factor

@@ -34,14 +34,14 @@ IN: compiler.tree.combinators
     dup dup '[
         _ keep swap [ drop t ] [
             dup #branch? [
-                children>> [ _ contains-node? ] contains?
+                children>> [ _ contains-node? ] any?
             ] [
                 dup #recursive? [
                     child>> _ contains-node?
                 ] [ drop f ] if
             ] if
         ] if
-    ] contains? ; inline recursive
+    ] any? ; inline recursive
 
 : select-children ( seq flags -- seq' )
     [ [ drop f ] unless ] 2map ;

basis/compiler/tree/dead-code/dead-code-tests.factor

@@ -79,7 +79,7 @@ IN: compiler.tree.dead-code.tests
 
 [ [ read drop 1 2 ] ] [ [ read [ 1 2 ] dip drop ] optimize-quot ] unit-test
 
-[ [ over >r + r> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
+[ [ over >R + R> ] ] [ [ [ + ] [ drop ] 2bi ] optimize-quot ] unit-test
 
 [ [ [ ] [ ] if ] ] [ [ [ 1 ] [ 2 ] if drop ] optimize-quot ] unit-test
 

basis/compiler/tree/dead-code/simple/simple.factor

@@ -79,7 +79,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
     dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
 
 : some-outputs-dead? ( #call -- ? )
-    out-d>> [ live-value? not ] contains? ;
+    out-d>> [ live-value? not ] any? ;
 
 : maybe-drop-dead-outputs ( node -- nodes )
     dup some-outputs-dead? [

basis/compiler/tree/debugger/debugger.factor

@@ -4,7 +4,7 @@ USING: kernel assocs match fry accessors namespaces make effects
 sequences sequences.private quotations generic macros arrays
 prettyprint prettyprint.backend prettyprint.custom
 prettyprint.sections math words combinators
-combinators.short-circuit io sorting hints qualified
+combinators.short-circuit io sorting hints
 compiler.tree
 compiler.tree.recursive
 compiler.tree.normalization
@@ -80,10 +80,12 @@ M: shuffle-node pprint* effect>> effect>string text ;
         [ out-d>> length 1 = ]
     } 1&& ;
 
+SYMBOLS: >R R> ;
+
 M: #shuffle node>quot
     {
-        { [ dup #>r? ] [ drop \ >r , ] }
+        { [ dup #>r? ] [ drop \ >R , ] }
-        { [ dup #r>? ] [ drop \ r> , ] }
+        { [ dup #r>? ] [ drop \ R> , ] }
         {
             [ dup [ in-r>> empty? ] [ out-r>> empty? ] bi and ]
             [

basis/compiler/tree/escape-analysis/branches/branches.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel namespaces sequences sets fry columns
-stack-checker.branches
+grouping stack-checker.branches
 compiler.tree
 compiler.tree.propagation.branches
 compiler.tree.escape-analysis.nodes

basis/compiler/tree/modular-arithmetic/modular-arithmetic-tests.factor

@@ -8,13 +8,13 @@ compiler.tree.debugger ;
 : test-modular-arithmetic ( quot -- quot' )
     build-tree optimize-tree nodes>quot ;
 
-[ [ >r >fixnum r> >fixnum fixnum+fast ] ]
+[ [ >R >fixnum R> >fixnum fixnum+fast ] ]
 [ [ { integer integer } declare + >fixnum ] test-modular-arithmetic ] unit-test
 
 [ [ +-integer-integer dup >fixnum ] ]
 [ [ { integer integer } declare + dup >fixnum ] test-modular-arithmetic ] unit-test
 
-[ [ >r >fixnum r> >fixnum fixnum+fast 4 fixnum*fast ] ]
+[ [ >R >fixnum R> >fixnum fixnum+fast 4 fixnum*fast ] ]
 [ [ { integer integer } declare + 4 * >fixnum ] test-modular-arithmetic ] unit-test
 
 TUPLE: declared-fixnum { x fixnum } ;

basis/compiler/tree/normalization/normalization.factor

@@ -60,7 +60,7 @@ M: #branch normalize*
 : eliminate-phi-introductions ( introductions seq terminated -- seq' )
     [
         [ nip ] [
-            dup [ +bottom+ eq? ] trim-left
+            dup [ +bottom+ eq? ] trim-head
             [ [ length ] bi@ - tail* ] keep append
         ] if
     ] 3map ;

basis/compiler/tree/propagation/copy/copy.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces sequences assocs math kernel accessors fry
-combinators sets locals columns
+combinators sets locals columns grouping
 stack-checker.branches
 compiler.tree
 compiler.tree.def-use

basis/compiler/tree/propagation/inlining/inlining.factor

@@ -3,7 +3,7 @@
 USING: accessors kernel arrays sequences math math.order
 math.partial-dispatch generic generic.standard generic.math
 classes.algebra classes.union sets quotations assocs combinators
-words namespaces continuations classes fry
+words namespaces continuations classes fry combinators.smart
 compiler.tree
 compiler.tree.builder
 compiler.tree.recursive
@@ -124,7 +124,7 @@ DEFER: (flat-length)
         [ class-types length 1 = ]
         [ union-class? not ]
         bi and
-    ] contains? ;
+    ] any? ;
 
 : node-count-bias ( -- n )
     45 node-count get [-] 8 /i ;
@@ -134,17 +134,19 @@ DEFER: (flat-length)
     over 2 <= [ drop ] [ 2/ 1+ * ] if 24 swap [-] 4 /i ;
 
 : inlining-rank ( #call word -- n )
-    [ classes-known? 2 0 ? ]
     [
-        {
+        [ classes-known? 2 0 ? ]
-            [ body-length-bias ]
+        [
-            [ "default" word-prop -4 0 ? ]
+            {
-            [ "specializer" word-prop 1 0 ? ]
+                [ body-length-bias ]
-            [ method-body? 1 0 ? ]
+                [ "default" word-prop -4 0 ? ]
-        } cleave
+                [ "specializer" word-prop 1 0 ? ]
-        node-count-bias
+                [ method-body? 1 0 ? ]
-        loop-nesting get 0 or 2 *
+            } cleave
-    ] bi* + + + + + + ;
+            node-count-bias
+            loop-nesting get 0 or 2 *
+        ] bi*
+    ] sum-outputs ;
 
 : should-inline? ( #call word -- ? )
     dup "inline" word-prop [ 2drop t ] [ inlining-rank 5 >= ] if ;

basis/compiler/tree/propagation/known-words/known-words.factor

@@ -6,7 +6,7 @@ math.parser math.order layouts words sequences sequences.private
 arrays assocs classes classes.algebra combinators generic.math
 splitting fry locals classes.tuple alien.accessors
 classes.tuple.private slots.private definitions strings.private
-vectors hashtables
+vectors hashtables generic
 stack-checker.state
 compiler.tree.comparisons
 compiler.tree.propagation.info
@@ -337,3 +337,12 @@ generic-comparison-ops [
         bi
     ] [ 2drop object-info ] if
 ] "outputs" set-word-prop
+
+\ equal? [
+    ! If first input has a known type and second input is an
+    ! object, we convert this to [ swap equal? ].
+    in-d>> first2 value-info class>> object class= [
+        value-info class>> \ equal? specific-method
+        [ swap equal? ] f ?
+    ] [ drop f ] if
+] "custom-inlining" set-word-prop

basis/compiler/tree/propagation/propagation-tests.factor

@@ -18,7 +18,7 @@ IN: compiler.tree.propagation.tests
 
 [ V{ fixnum } ] [ [ 1 ] final-classes ] unit-test
 
-[ V{ fixnum } ] [ [ 1 >r r> ] final-classes ] unit-test
+[ V{ fixnum } ] [ [ 1 [ ] dip ] final-classes ] unit-test
 
 [ V{ fixnum object } ] [ [ 1 swap ] final-classes ] unit-test
 
@@ -198,7 +198,7 @@ IN: compiler.tree.propagation.tests
     [
         { fixnum byte-array } declare
         [ nth-unsafe ] 2keep [ nth-unsafe ] 2keep nth-unsafe
-        >r >r 298 * r> 100 * - r> 208 * - 128 + -8 shift
+        [ [ 298 * ] dip 100 * - ] dip 208 * - 128 + -8 shift
         255 min 0 max
     ] final-classes
 ] unit-test
@@ -640,6 +640,10 @@ MIXIN: empty-mixin
     [ { fixnum } declare log2 0 >= ] final-classes
 ] unit-test
 
+[ V{ POSTPONE: f } ] [
+    [ { word object } declare equal? ] final-classes
+] unit-test
+
 ! [ V{ string } ] [
 !     [ dup string? t xor [ "A" throw ] [ ] if ] final-classes
 ! ] unit-test

basis/compiler/tree/tuple-unboxing/tuple-unboxing.factor

@@ -118,7 +118,7 @@ M: #return-recursive unbox-tuples*
 ! These nodes never participate in unboxing
 : assert-not-unboxed ( values -- )
     dup array?
-    [ [ unboxed-allocation ] contains? ] [ unboxed-allocation ] if
+    [ [ unboxed-allocation ] any? ] [ unboxed-allocation ] if
     [ "Unboxing wrong value" throw ] when ;
 
 M: #branch unbox-tuples* dup in-d>> assert-not-unboxed ;

basis/compiler/utilities/utilities.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel sequences sequences.private arrays vectors fry
-math.order ;
+math.order namespaces assocs ;
 IN: compiler.utilities
 
 : flattener ( seq quot -- seq vector quot' )
@@ -22,10 +22,6 @@ IN: compiler.utilities
 
 : 2map-flat ( seq quot -- seq' ) [ 2each ] flattening ; inline
 
-: (3each) ( seq1 seq2 seq3 quot -- n quot' )
+SYMBOL: yield-hook
-    [ [ [ length ] tri@ min min ] 3keep ] dip
-    '[ [ _ nth-unsafe ] [ _ nth-unsafe ] [ _ nth-unsafe ] tri @ ] ; inline
 
-: 3each ( seq1 seq2 seq3 quot -- seq ) (3each) each ; inline
+yield-hook global [ [ ] or ] change-at
-
-: 3map ( seq1 seq2 seq3 quot -- seq ) (3each) map ; inline