From 89852b22d4b1f304008801750973a810eb2f1fb8 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Tue, 16 Dec 2008 22:43:22 -0500
Subject: [PATCH 001/135] Add Project Euler solution for problem 1 from IRC

---
 extra/project-euler/001/001-tests.factor | 1 +
 extra/project-euler/001/001.factor       | 9 ++++++++-
 2 files changed, 9 insertions(+), 1 deletion(-)

diff --git a/extra/project-euler/001/001-tests.factor b/extra/project-euler/001/001-tests.factor
index 8d2461a510..1cab275619 100644
--- a/extra/project-euler/001/001-tests.factor
+++ b/extra/project-euler/001/001-tests.factor
@@ -4,3 +4,4 @@ IN: project-euler.001.tests
 [ 233168 ] [ euler001 ] unit-test
 [ 233168 ] [ euler001a ] unit-test
 [ 233168 ] [ euler001b ] unit-test
+[ 233168 ] [ euler001c ] unit-test
diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor
index 1e49be9a60..c9145c9b73 100644
--- a/extra/project-euler/001/001.factor
+++ b/extra/project-euler/001/001.factor
@@ -1,4 +1,4 @@
-! Copyright (c) 2007 Aaron Schaefer.
+! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel math math.ranges sequences ;
 IN: project-euler.001
@@ -51,4 +51,11 @@ PRIVATE>
 ! [ euler001b ] 100 ave-time
 ! 0 ms run / 0 ms GC ave time - 100 trials
 
+
+: euler001c ( -- answer )
+    1000 [ { 3 5 } [ mod 0 = ] with contains? ] filter sum ;
+
+! [ euler001c ] 100 ave-time
+! 0 ms ave run time - 0.06 SD (100 trials)
+
 MAIN: euler001

From adac92dfa5ad7439fc8a0c23078afcb4975e2a6b Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Sat, 20 Dec 2008 18:53:17 -0500
Subject: [PATCH 002/135] Remove roll from Project Euler problem 33 solution

---
 extra/project-euler/033/033.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/project-euler/033/033.factor b/extra/project-euler/033/033.factor
index d0c79c220a..2cc114a545 100644
--- a/extra/project-euler/033/033.factor
+++ b/extra/project-euler/033/033.factor
@@ -33,7 +33,7 @@ IN: project-euler.033
     10 99 [a,b] dup cartesian-product [ first2 < ] filter ;
 
 : safe? ( ax xb -- ? )
-    [ 10 /mod ] bi@ -roll = rot zero? not and nip ;
+    [ 10 /mod ] bi@ [ = ] dip zero? not and nip ;
 
 : ax/xb ( ax xb -- z/f )
     2dup safe? [ [ 10 /mod ] bi@ 2nip / ] [ 2drop f ] if ;

From 51530700f406f2effe8ff1f6cde953a10d7a0665 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 7 Jan 2009 18:47:32 -0500
Subject: [PATCH 003/135] Add number-length word and clean cartesian-product

---
 extra/project-euler/common/common.factor | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index 1a57a91e5e..49eb730632 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -56,7 +56,7 @@ PRIVATE>
     >lower [ CHAR: a - 1+ ] sigma ;
 
 : cartesian-product ( seq1 seq2 -- seq1xseq2 )
-    swap [ swap [ 2array ] with map ] with map concat ;
+    [ [ 2array ] with map ] curry map concat ;
 
 : log10 ( m -- n )
     log 10 log / ;
@@ -74,6 +74,9 @@ PRIVATE>
 : number>digits ( n -- seq )
     [ dup 0 = not ] [ 10 /mod ] [ ] produce reverse nip ;
 
+: number-length ( n -- m )
+    log10 floor 1+ >integer ;
+
 : nth-triangle ( n -- n )
     dup 1+ * 2 / ;
 

From 84b5ace86378d51ea4d6c9ad40aeaff1b8a0e0b5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 28 Mar 2009 22:26:49 -0500
Subject: [PATCH 004/135] alien.destructors: ignore any output values from
 disposal word

---
 basis/alien/destructors/destructors.factor | 5 +++--
 basis/combinators/smart/smart.factor       | 3 +++
 2 files changed, 6 insertions(+), 2 deletions(-)

diff --git a/basis/alien/destructors/destructors.factor b/basis/alien/destructors/destructors.factor
index 1b6022d3b7..1c5c975fe6 100644
--- a/basis/alien/destructors/destructors.factor
+++ b/basis/alien/destructors/destructors.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: functors destructors accessors kernel parser words ;
+USING: functors destructors accessors kernel parser words
+combinators.smart ;
 IN: alien.destructors
 
 SLOT: alien
@@ -18,7 +19,7 @@ TUPLE: F-destructor alien disposed ;
 
 : <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
 
-M: F-destructor dispose* alien>> F ;
+M: F-destructor dispose* [ alien>> F ] drop-outputs ;
 
 : &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
 
diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor
index e7bdd75ced..aa7960539c 100644
--- a/basis/combinators/smart/smart.factor
+++ b/basis/combinators/smart/smart.factor
@@ -4,6 +4,9 @@ USING: accessors fry generalizations kernel macros math.order
 stack-checker math ;
 IN: combinators.smart
 
+MACRO: drop-outputs ( quot -- quot' )
+    dup infer out>> '[ @ _ ndrop ] ;
+
 MACRO: output>sequence ( quot exemplar -- newquot )
     [ dup infer out>> ] dip
     '[ @ _ _ nsequence ] ;

From a58ce33bb3e8bf00e1c8f4196458c9ed4af97420 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 28 Mar 2009 22:27:18 -0500
Subject: [PATCH 005/135] Split off some code from ui.backend.windows into
 windows.offscreen

---
 basis/ui/backend/windows/windows.factor  | 50 ++++++------------------
 basis/windows/gdi32/gdi32.factor         |  6 ++-
 basis/windows/offscreen/authors.txt      |  1 +
 basis/windows/offscreen/offscreen.factor | 47 ++++++++++++++++++++++
 extra/ui/offscreen/offscreen.factor      |  4 +-
 extra/ui/offscreen/tags.txt              |  1 -
 6 files changed, 67 insertions(+), 42 deletions(-)
 create mode 100644 basis/windows/offscreen/authors.txt
 create mode 100644 basis/windows/offscreen/offscreen.factor

diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index 80dd313e85..12ce2bed80 100755
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -1,16 +1,16 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! Portions copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs ui
-ui.private ui.gadgets ui.gadgets.private ui.backend
-ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
-kernel math math.vectors namespaces make sequences strings
-vectors words windows.kernel32 windows.gdi32 windows.user32
-windows.opengl32 windows.messages windows.types windows.nt
-windows threads libc combinators fry combinators.short-circuit
-continuations command-line shuffle opengl ui.render ascii
-math.bitwise locals accessors math.rectangles math.order ascii
-calendar io.encodings.utf16n ;
+USING: alien alien.c-types alien.strings arrays assocs ui ui.private
+ui.gadgets ui.gadgets.private ui.backend ui.clipboards
+ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
+math.vectors namespaces make sequences strings vectors words
+windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
+windows.messages windows.types windows.offscreen windows.nt windows
+threads libc combinators fry combinators.short-circuit continuations
+command-line shuffle opengl ui.render ascii math.bitwise locals
+accessors math.rectangles math.order ascii calendar
+io.encodings.utf16n ;
 IN: ui.backend.windows
 
 SINGLETON: windows-ui-backend
@@ -501,35 +501,12 @@ M: windows-ui-backend (open-window) ( world -- )
     hWnd>> show-window ;
 
 M: win-base select-gl-context ( handle -- )
-    [ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
+    [ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
     GdiFlush drop ;
 
 M: win-base flush-gl-context ( handle -- )
     hDC>> SwapBuffers win32-error=0/f ;
 
-: (bitmap-info) ( dim -- BITMAPINFO )
-    "BITMAPINFO" <c-object> [
-        BITMAPINFO-bmiHeader {
-            [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
-            [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
-            [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
-            [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
-            [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
-            [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
-            [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
-            [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
-            [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
-            [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
-            [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
-        } 2cleave
-    ] keep ;
-
-: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
-    f CreateCompatibleDC
-    dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
-    [ f 0 CreateDIBSection ] keep *void*
-    [ 2dup SelectObject drop ] dip ;
-
 : setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
     make-offscreen-dc-and-bitmap [
         [ dup offscreen-pfd-dwFlags setup-pixel-format ]
@@ -548,13 +525,12 @@ M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
 ! each pixel; it's left as zero
 
 : (make-opaque) ( byte-array -- byte-array' )
-    [ length 4 / ]
+    [ length 4 /i ]
     [ '[ 255 swap 4 * 3 + _ set-nth ] each ]
     [ ] tri ;
 
 : (opaque-pixels) ( world -- pixels )
-    [ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
-    memory>byte-array (make-opaque) ;
+    [ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ;
 
 M: windows-ui-backend offscreen-pixels ( world -- alien w h )
     [ (opaque-pixels) ] [ dim>> first2 ] bi ;
diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor
index 077adf1961..2281255a4f 100755
--- a/basis/windows/gdi32/gdi32.factor
+++ b/basis/windows/gdi32/gdi32.factor
@@ -1,7 +1,6 @@
-! FUNCTION: AbortDoc
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax kernel windows.types ;
+USING: alien alien.syntax alien.destructors kernel windows.types ;
 IN: windows.gdi32
 
 ! Stock Logical Objects
@@ -36,6 +35,7 @@ CONSTANT: DIB_PAL_COLORS 1
 
 LIBRARY: gdi32
 
+! FUNCTION: AbortDoc
 ! FUNCTION: AbortPath
 ! FUNCTION: AddFontMemResourceEx
 ! FUNCTION: AddFontResourceA
@@ -178,9 +178,11 @@ FUNCTION: HRGN CreateRectRgn ( int x, int y, int w, int h ) ;
 ! FUNCTION: DdEntry9
 ! FUNCTION: DeleteColorSpace
 FUNCTION: BOOL DeleteDC ( HDC hdc ) ;
+DESTRUCTOR: DeleteDC
 ! FUNCTION: DeleteEnhMetaFile
 ! FUNCTION: DeleteMetaFile
 FUNCTION: BOOL DeleteObject ( HGDIOBJ hObject ) ;
+DESTRUCTOR: DeleteObject
 ! FUNCTION: DescribePixelFormat
 ! FUNCTION: DeviceCapabilitiesExA
 ! FUNCTION: DeviceCapabilitiesExW
diff --git a/basis/windows/offscreen/authors.txt b/basis/windows/offscreen/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/windows/offscreen/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/windows/offscreen/offscreen.factor b/basis/windows/offscreen/offscreen.factor
new file mode 100644
index 0000000000..4eee68c37a
--- /dev/null
+++ b/basis/windows/offscreen/offscreen.factor
@@ -0,0 +1,47 @@
+! Copyright (C) 2009 Joe Groff, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types kernel combinators sequences
+math windows.gdi32 windows.types images destructors
+accessors fry ;
+IN: windows.offscreen
+
+: (bitmap-info) ( dim -- BITMAPINFO )
+    "BITMAPINFO" <c-object> [
+        BITMAPINFO-bmiHeader {
+            [ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
+            [ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
+            [ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
+            [ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
+            [ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
+            [ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
+            [ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
+            [ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
+            [ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
+            [ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
+            [ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
+        } 2cleave
+    ] keep ;
+
+: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
+    f CreateCompatibleDC
+    [ nip ]
+    [
+        swap (bitmap-info) DIB_RGB_COLORS f <void*>
+        [ f 0 CreateDIBSection ] keep *void*
+    ] 2bi
+    [ 2dup SelectObject drop ] dip ;
+
+: bitmap>byte-array ( bits dim -- byte-array )
+    product 4 * memory>byte-array ;
+
+: bitmap>image ( bits dim -- image )
+    [ bitmap>byte-array ] keep
+    <image> swap >>dim swap >>bitmap XBGR >>component-order ;
+
+: make-bitmap-image ( dim quot: ( hDC -- ) -- image )
+    '[
+        [
+            make-offscreen-dc-and-bitmap
+            [ &DeleteDC @ ] [ &DeleteObject drop ] [ ] tri*
+        ] keep bitmap>byte-array
+    ] with-destructors ; inline
\ No newline at end of file
diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor
index cf9370ed7f..f0b81ccacd 100755
--- a/extra/ui/offscreen/offscreen.factor
+++ b/extra/ui/offscreen/offscreen.factor
@@ -1,7 +1,7 @@
 ! (c) 2008 Joe Groff, see license for details
 USING: accessors continuations images.bitmap kernel math
-sequences ui.gadgets ui.gadgets.worlds ui ui.backend
-destructors ;
+sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
+ui.private ui ui.backend destructors ;
 IN: ui.offscreen
 
 TUPLE: offscreen-world < world ;
diff --git a/extra/ui/offscreen/tags.txt b/extra/ui/offscreen/tags.txt
index b796ebde91..46f6dcd8de 100644
--- a/extra/ui/offscreen/tags.txt
+++ b/extra/ui/offscreen/tags.txt
@@ -1,3 +1,2 @@
-unportable
 ui
 graphics

From cf87e20a30af3479fd0ce2e09b77701775f3699f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sat, 28 Mar 2009 22:27:37 -0500
Subject: [PATCH 006/135] Uniscribe text rendering work in progress

---
 basis/windows/uniscribe/authors.txt      |  1 +
 basis/windows/uniscribe/uniscribe.factor | 65 ++++++++++++++++++++++++
 basis/windows/usp10/usp10.factor         |  4 +-
 3 files changed, 69 insertions(+), 1 deletion(-)
 create mode 100644 basis/windows/uniscribe/authors.txt
 create mode 100644 basis/windows/uniscribe/uniscribe.factor

diff --git a/basis/windows/uniscribe/authors.txt b/basis/windows/uniscribe/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/windows/uniscribe/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
new file mode 100644
index 0000000000..5d24601555
--- /dev/null
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -0,0 +1,65 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel math sequences io.encodings.string io.encodings.utf16n
+accessors arrays destructors alien.c-types windows windows.usp10
+windows.offscreen ;
+IN: windows.uniscribe
+
+TUPLE: script-string pssa size image ;
+
+: make-script-string ( dc string -- script-string )
+    [ utf16n encode ] ! pString
+    [ length ] bi ! cString
+    dup 1.5 * 16 + ! cGlyphs -- MSDN says this is "recommended size"
+    -1 ! iCharset -- Unicode
+    SSA_GLYPHS ! dwFlags
+    ... ! iReqWidth
+    f ! psControl
+    f ! psState
+    f ! piDx
+    f ! pTabdef
+    ... ! pbInClass
+    f <void*> ! pssa
+    [ ScriptStringAnalyse ] keep
+    [ win32-error=0/f ] [ |ScriptStringFree ] bi* ;
+
+: draw-script-string ( script-string -- bitmap )
+    ! ssa
+    0 ! iX
+    0 ! iY
+    ETO_OPAQUE ! uOptions ... ????
+    f ! prc
+    0 ! iMinSel
+    0 ! iMaxSel
+    f ! fDisabled
+    ScriptStringOut ;
+
+: <script-string> ( string -- script-string )
+    [
+        ... dim ... [
+            make-script-string |ScriptStringFree
+            [ ]
+            [ draw-script-string ]
+            [
+                ScriptString_pSize
+                dup win32-error=0/f
+                [ SIZE-cx ] [ SIZE-cy ] bi 2array
+            ] tri
+        ] make-bitmap-image
+        script-string boa
+    ] with-destructors ;
+
+M: script-string dispose* pssa>> ScriptStringFree win32-error=0/f ;
+
+: line-offset>x ( offset script-string -- x )
+    pssa>> ! ssa
+    swap ! icp
+    ... ! fTrailing
+    0 <int> [ ScriptStringCPtoX win32-error=0/f ] keep *int ;
+
+: line-x>offset ( x script-string -- offset trailing )
+    pssa>> ! ssa
+    swap ! iX
+    0 <int> ! pCh
+    0 <int> ! piTrailing
+    [ ScriptStringXtoCP win32-error=0/f ] 2keep [ *int ] bi@ ;
\ No newline at end of file
diff --git a/basis/windows/usp10/usp10.factor b/basis/windows/usp10/usp10.factor
index 64e5a60019..50fa98996c 100755
--- a/basis/windows/usp10/usp10.factor
+++ b/basis/windows/usp10/usp10.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax alien.destructors ;
 IN: windows.usp10
 
 LIBRARY: usp10
@@ -262,6 +262,8 @@ FUNCTION: HRESULT ScriptStringFree (
     SCRIPT_STRING_ANALYSIS* pssa
 ) ;
 
+DESTRUCTOR: ScriptStringFree
+
 FUNCTION: SIZE* ScriptString_pSize ( SCRIPT_STRING_ANALYSIS ssa ) ;
 
 FUNCTION: int* ScriptString_pcOutChars ( SCRIPT_STRING_ANALYSIS ssa ) ;

From 2314af94fe9975bce65d8953a7a404f9bcee1bb3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 29 Mar 2009 16:38:12 -0500
Subject: [PATCH 007/135] Remove redundant flush_icache() call

---
 vm/code_block.c | 2 --
 1 file changed, 2 deletions(-)

diff --git a/vm/code_block.c b/vm/code_block.c
index a9b5277c84..c6ecb2f431 100644
--- a/vm/code_block.c
+++ b/vm/code_block.c
@@ -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)

From a40b4f6dfaf9ae333c669493f7660602ce9d49c5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 29 Mar 2009 19:07:01 -0500
Subject: [PATCH 008/135] Fix docs typo

---
 basis/ui/tools/browser/browser-docs.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

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" }

From 13f553b2846a213466cc1a8ffb09cd76ded00632 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-116-90.res.carleton.edu>
Date: Sun, 29 Mar 2009 20:29:38 -0500
Subject: [PATCH 009/135] Fixing farkup's parsing of [aaa]

---
 basis/farkup/farkup-tests.factor |  2 +-
 basis/farkup/farkup.factor       | 13 +++++++------
 2 files changed, 8 insertions(+), 7 deletions(-)

diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index 7cae523efb..abee7194a2 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -182,7 +182,7 @@ link-no-follow? off
 [ "<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
+[ "<p>[abc]</p>" ] [ "[abc]" convert-farkup ] unit-test
 
 : random-markup ( -- string )
     10 [
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index 41c6c4aa00..c400457c0b 100644
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -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,11 +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 )

From 82b6e32945f39e87a77a67234764676ce7c8100e Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 29 Mar 2009 21:35:57 -0500
Subject: [PATCH 010/135] fix a few compile errors

---
 basis/sorting/human/human.factor | 2 +-
 extra/bank/bank.factor           | 2 +-
 extra/irc/client/client.factor   | 2 +-
 3 files changed, 3 insertions(+), 3 deletions(-)

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/extra/bank/bank.factor b/extra/bank/bank.factor
index 0f8b5581df..2584335672 100644
--- a/extra/bank/bank.factor
+++ b/extra/bank/bank.factor
@@ -59,7 +59,7 @@ C: <transaction> transaction
         [ dup [ over [ swap call ] dip ] dip 1 days time+ ] dip each-day
     ] [
         3drop
-    ] if ;
+    ] if ; inline
 
 : process-to-date ( account date -- account )
     over interest-last-paid>> 1 days time+
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

From 95cda29b4435fbe1f74b651417ae0f9554b3e85c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sun, 29 Mar 2009 21:39:21 -0500
Subject: [PATCH 011/135] fix compile error

---
 extra/bank/bank.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/bank/bank.factor b/extra/bank/bank.factor
index 2584335672..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 ; inline
+    ] 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 ;

From 5a903d7bcd935efab6134f74e60a845ed13346cb Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 29 Mar 2009 22:46:27 -0500
Subject: [PATCH 012/135] Fix a bug in CONSTANT: -- it wasn't calling
 reset-word

---
 core/syntax/syntax.factor           | 2 +-
 core/words/alias/alias-tests.factor | 6 ++++++
 2 files changed, 7 insertions(+), 1 deletion(-)
 create mode 100644 core/words/alias/alias-tests.factor

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/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

From 5ecff284effd254bacd6498dc13cb7997de37d77 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-116-90.res.carleton.edu>
Date: Sun, 29 Mar 2009 22:57:13 -0500
Subject: [PATCH 013/135] Fixing regexp compiler's bounds checks

---
 basis/regexp/compiler/compiler.factor | 24 +++++++++++++++---------
 1 file changed, 15 insertions(+), 9 deletions(-)

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 )

From f657c60c4f3c235e193ce8f4931eb0f9a01fc843 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-116-90.res.carleton.edu>
Date: Sun, 29 Mar 2009 22:58:04 -0500
Subject: [PATCH 014/135] Some cleanup in documents.elements

---
 basis/documents/elements/elements.factor | 24 ++++++++++++------------
 1 file changed, 12 insertions(+), 12 deletions(-)

diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor
index adb498df13..9a8b82acac 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 combinators.short-circuit ;
 IN: documents.elements
 
 GENERIC: prev-elt ( loc document elt -- newloc )
@@ -20,14 +20,14 @@ 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 )
     {
         { [ 2over doc-end = ] [ 2drop ] }
         { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
@@ -37,10 +37,10 @@ SINGLETON: char-elt
 PRIVATE>
 
 M: char-elt prev-elt
-    drop [ drop -1 +col ] (prev-char) ;
+    drop [ drop -1 +col ] prev ;
 
 M: char-elt next-elt
-    drop [ drop 1 +col ] (next-char) ;
+    drop [ drop 1 +col ] next ;
 
 SINGLETON: one-char-elt
 
@@ -55,7 +55,7 @@ M: one-char-elt next-elt 2drop ;
         [ [ 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 )
@@ -65,7 +65,7 @@ M: one-char-elt next-elt 2drop ;
     break-detector find-last-from drop ?1+ ;
 
 : (next-word) ( col str ? -- col )
-    [ break-detector find-from drop ] [ drop length ] 2bi or ;
+    { [ break-detector find-from drop ] [ drop length ] } 2|| ;
 
 PRIVATE>
 
@@ -83,13 +83,13 @@ 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) ] (word-elt) ]
+    prev ;
 
 M: word-elt next-elt
     drop
-    [ [ ((word-elt)) (next-word) ] (word-elt) ]
-    (next-char) ;
+    [ [ blank-at? (next-word) ] (word-elt) ]
+    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 ;

From bd91ac56cebf4166cda3ba66728f4e697bfef9f4 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Sun, 29 Mar 2009 23:13:30 -0500
Subject: [PATCH 015/135] Fix model docs

---
 basis/models/models-docs.factor | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

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>

From c1297ec177589928d9de688d4130be9e721da0d8 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Mon, 30 Mar 2009 00:18:02 -0500
Subject: [PATCH 016/135] add unit tests for quoting

---
 basis/quoting/quoting-tests.factor | 11 +++++++++++
 1 file changed, 11 insertions(+)
 create mode 100644 basis/quoting/quoting-tests.factor

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

From 00c9cde8e2edaf806d31b7ef676e16219f53b06a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 30 Mar 2009 05:31:50 -0500
Subject: [PATCH 017/135] First checkin of extra/smalltalk

---
 extra/smalltalk/ast/ast.factor                |  18 ++
 extra/smalltalk/ast/authors.txt               |   1 +
 extra/smalltalk/authors.txt                   |   1 +
 extra/smalltalk/compiler/authors.txt          |   1 +
 .../smalltalk/compiler/compiler-tests.factor  |  45 ++++
 extra/smalltalk/compiler/compiler.factor      | 102 +++++++++
 extra/smalltalk/compiler/lexenv/authors.txt   |   1 +
 extra/smalltalk/compiler/lexenv/lexenv.factor |  14 ++
 extra/smalltalk/parser/authors.txt            |   1 +
 extra/smalltalk/parser/parser-tests.factor    | 137 ++++++++++++
 extra/smalltalk/parser/parser.factor          | 203 ++++++++++++++++++
 extra/smalltalk/parser/test.st                |  66 ++++++
 extra/smalltalk/selectors/authors.txt         |   1 +
 extra/smalltalk/selectors/selectors.factor    |  26 +++
 extra/smalltalk/smalltalk.factor              |   4 +
 15 files changed, 621 insertions(+)
 create mode 100644 extra/smalltalk/ast/ast.factor
 create mode 100644 extra/smalltalk/ast/authors.txt
 create mode 100644 extra/smalltalk/authors.txt
 create mode 100644 extra/smalltalk/compiler/authors.txt
 create mode 100644 extra/smalltalk/compiler/compiler-tests.factor
 create mode 100644 extra/smalltalk/compiler/compiler.factor
 create mode 100644 extra/smalltalk/compiler/lexenv/authors.txt
 create mode 100644 extra/smalltalk/compiler/lexenv/lexenv.factor
 create mode 100644 extra/smalltalk/parser/authors.txt
 create mode 100644 extra/smalltalk/parser/parser-tests.factor
 create mode 100644 extra/smalltalk/parser/parser.factor
 create mode 100644 extra/smalltalk/parser/test.st
 create mode 100644 extra/smalltalk/selectors/authors.txt
 create mode 100644 extra/smalltalk/selectors/selectors.factor
 create mode 100644 extra/smalltalk/smalltalk.factor

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
new file mode 100644
index 0000000000..83e6d0ae84
--- /dev/null
+++ b/extra/smalltalk/ast/ast.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: strings arrays memoize kernel ;
+IN: smalltalk.ast
+
+SINGLETONS: nil self super ;
+
+TUPLE: ast-comment { string string } ;
+TUPLE: ast-block { arguments array } { body array } ;
+TUPLE: ast-message-send receiver { selector string } { arguments array } ;
+TUPLE: ast-name { name string } ;
+TUPLE: ast-return value ;
+TUPLE: ast-assignment { name ast-name } value ;
+TUPLE: ast-local-variables { names array } ;
+TUPLE: ast-method { name string } { body ast-block } ;
+TUPLE: ast-class { name string } { superclass string } { ivars array } { methods array } ;
+TUPLE: symbol { name string } ;
+MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/ast/authors.txt b/extra/smalltalk/ast/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/ast/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/authors.txt b/extra/smalltalk/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/authors.txt b/extra/smalltalk/compiler/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
new file mode 100644
index 0000000000..ee944baf02
--- /dev/null
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -0,0 +1,45 @@
+USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
+stack-checker locals.rewrite.closures kernel accessors
+compiler.units sequences ;
+IN: smalltalk.compiler.tests
+
+[ 2 1 ] [
+    [
+        T{ ast-block f
+           { "a" "b" }
+           {
+               T{ ast-message-send f
+                  T{ ast-name f "a" }
+                  "+"
+                  { T{ ast-name f "b" } }
+               }
+           }
+        } compile-method
+        [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
+    ] with-compilation-unit
+] unit-test
+
+[ 3 1 ] [
+    [
+        T{ ast-block f
+           { "a" "b" "c" }
+           {
+               T{ ast-assignment f
+                  T{ ast-name f "a" }
+                  T{ ast-message-send f
+                     T{ ast-name f "a" }
+                     "+"
+                     { T{ ast-name f "b" } }
+                  }
+               }
+               T{ ast-message-send f
+                  T{ ast-name f "b" }
+                  "blah:"
+                  { 123.456 }
+               }
+               T{ ast-return f T{ ast-name f "c" } }
+           }
+        } compile-method
+        [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
+    ] with-compilation-unit
+] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
new file mode 100644
index 0000000000..1f3b0f94e5
--- /dev/null
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -0,0 +1,102 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators.short-circuit
+continuations fry kernel namespaces quotations sequences sets
+slots locals.types generalizations smalltalk.ast
+smalltalk.compiler.lexenv smalltalk.selectors ;
+IN: smalltalk.compiler
+
+SYMBOL: return-continuation
+
+GENERIC: need-return-continuation? ( ast -- ? )
+
+M: ast-return need-return-continuation? drop t ;
+
+M: ast-block need-return-continuation? body>> [ need-return-continuation? ] any? ;
+
+M: ast-message-send need-return-continuation?
+    {
+        [ receiver>> need-return-continuation? ]
+        [ arguments>> [ need-return-continuation? ] any? ]
+    } 1&& ;
+
+M: ast-assignment need-return-continuation?
+    value>> need-return-continuation? ;
+
+M: object need-return-continuation? drop f ;
+
+GENERIC: assigned-locals ( ast -- seq )
+
+M: ast-return assigned-locals value>> assigned-locals ;
+
+M: ast-block assigned-locals
+    [ body>> [ assigned-locals ] map concat ] [ arguments>> ] bi diff ;
+
+M: ast-message-send assigned-locals
+    [ receiver>> assigned-locals ]
+    [ arguments>> [ assigned-locals ] map ] bi append ;
+
+M: ast-assignment assigned-locals
+    [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
+    [ value>> assigned-locals ] bi append ;
+
+M: object assigned-locals drop f ;
+
+GENERIC: compile-ast ( lexenv ast -- quot )
+
+M: object compile-ast nip 1quotation ;
+
+ERROR: unbound-local name ;
+
+M: ast-name compile-ast
+    name>> swap local-readers>> at 1quotation ;
+
+M: ast-message-send compile-ast
+    [ receiver>> compile-ast ]
+    [ arguments>> [ compile-ast ] with map concat ]
+    [ nip selector>> selector>generic ]
+    2tri [ append ] dip suffix ;
+
+M: ast-return compile-ast
+    value>> compile-ast
+    [ return-continuation get continue-with ] append ;
+
+GENERIC: compile-assignment ( lexenv name -- quot )
+
+M: ast-name compile-assignment
+    name>> swap local-writers>> at 1quotation ;
+
+M: ast-assignment compile-ast
+    [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
+
+: block-lexenv ( block -- lexenv )
+    [ arguments>> ] [ body>> [ assigned-locals ] map concat unique ] bi
+    '[
+        dup dup _ key?
+        [ <local-reader> ]
+        [ <local> ]
+        if
+    ] { } map>assoc
+    dup
+    [ nip local-reader? ] assoc-filter
+    [ <local-writer> ] assoc-map
+    <lexenv> ;
+
+M: ast-block compile-ast
+    [
+        block-lexenv
+        [ nip local-readers>> values ]
+        [ lexenv-union ] 2bi
+    ] [ body>> ] bi
+    [ drop [ nil ] ] [
+        unclip-last
+        [ [ compile-ast [ drop ] append ] with map [ ] join ]
+        [ compile-ast ]
+        bi-curry* bi
+        append
+    ] if-empty
+    <lambda> '[ @ ] ;
+
+: compile-method ( block -- quot )
+    [ [ empty-lexenv ] dip compile-ast ] [ arguments>> length ] [ need-return-continuation? ] tri
+    [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/authors.txt b/extra/smalltalk/compiler/lexenv/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/lexenv/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
new file mode 100644
index 0000000000..2488a54c5f
--- /dev/null
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -0,0 +1,14 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs kernel accessors ;
+IN: smalltalk.compiler.lexenv
+
+TUPLE: lexenv local-readers local-writers ;
+
+C: <lexenv> lexenv
+
+CONSTANT: empty-lexenv T{ lexenv }
+
+: lexenv-union ( lexenv1 lexenv2 -- lexenv )
+    [ [ local-readers>> ] bi@ assoc-union ]
+    [ [ local-writers>> ] bi@ assoc-union ] 2bi <lexenv> ;
diff --git a/extra/smalltalk/parser/authors.txt b/extra/smalltalk/parser/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/parser/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
new file mode 100644
index 0000000000..9a6614aa07
--- /dev/null
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -0,0 +1,137 @@
+IN: smalltalk.parser.tests
+USING: smalltalk.parser smalltalk.ast peg.ebnf tools.test accessors
+io.files io.encodings.ascii kernel ;
+
+EBNF: test-Character
+test         = <foreign parse-smalltalk Character>
+;EBNF
+
+[ CHAR: a ] [ "a" test-Character ] unit-test
+
+EBNF: test-Comment
+test         = <foreign parse-smalltalk Comment>
+;EBNF
+
+[ T{ ast-comment f "Hello, this is a comment." } ]
+[ "\"Hello, this is a comment.\"" test-Comment ]
+unit-test
+
+[ T{ ast-comment f "Hello, \"this\" is a comment." } ]
+[ "\"Hello, \"\"this\"\" is a comment.\"" test-Comment ]
+unit-test
+
+EBNF: test-Identifier
+test         = <foreign parse-smalltalk Identifier>
+;EBNF
+
+[ "OrderedCollection" ] [ "OrderedCollection" test-Identifier ] unit-test
+
+EBNF: test-Literal
+test         = <foreign parse-smalltalk Literal>
+;EBNF
+
+[ nil ] [ "nil" test-Literal ] unit-test
+[ 123 ] [ "123" test-Literal ] unit-test
+[ HEX: deadbeef ] [ "16rdeadbeef" test-Literal ] unit-test
+[ -123 ] [ "-123" test-Literal ] unit-test
+[ 1.2 ] [ "1.2" test-Literal ] unit-test
+[ -1.24 ] [ "-1.24" test-Literal ] unit-test
+[ 12.4e7 ] [ "12.4e7" test-Literal ] unit-test
+[ 12.4e-7 ] [ "12.4e-7" test-Literal ] unit-test
+[ -12.4e7 ] [ "-12.4e7" test-Literal ] unit-test
+[ CHAR: x ] [ "$x" test-Literal ] unit-test
+[ "Hello, world" ] [ "'Hello, world'" test-Literal ] unit-test
+[ "Hello, 'funny' world" ] [ "'Hello, ''funny'' world'" test-Literal ] unit-test
+[ T{ symbol f "foo" } ] [ "#foo" test-Literal ] unit-test
+[ T{ symbol f "+" } ] [ "#+" test-Literal ] unit-test
+[ T{ symbol f "at:put:" } ] [ "#at:put:" test-Literal ] unit-test
+[ T{ symbol f "Hello world" } ] [ "#'Hello world'" test-Literal ] unit-test
+[ B{ 1 2 3 4 } ] [ "#[1 2 3 4]" test-Literal ] unit-test
+[ { nil t f } ] [ "#(nil true false)" test-Literal ] unit-test
+[ { nil { t f } } ] [ "#(nil (true false))" test-Literal ] unit-test
+[ T{ ast-block f { } { } } ] [ "[]" test-Literal ] unit-test
+[ T{ ast-block f { "x" } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
+[ T{ ast-block f { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
+
+EBNF: test-FormalBlockArgumentDeclarationList
+test         = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
+;EBNF
+
+[ V{ "x" "y" "elt" } ] [ ":x :y :elt" test-FormalBlockArgumentDeclarationList ] unit-test
+
+EBNF: test-Operand
+test         = <foreign parse-smalltalk Operand>
+;EBNF
+
+[ { 123 15.6 { t f } } ] [ "#(123 15.6 (true false))" test-Operand ] unit-test
+[ T{ ast-name f "x" } ] [ "x" test-Operand ] unit-test
+
+EBNF: test-Expression
+test         = <foreign parse-smalltalk Expression>
+;EBNF
+
+[ self ] [ "self" test-Expression ] unit-test
+[ { 123 15.6 { t f } } ] [ "#(123 15.6 (true false))" test-Expression ] unit-test
+[ T{ ast-name f "x" } ] [ "x" test-Expression ] unit-test
+[ T{ ast-message-send f 5 "print" { } } ] [ "5 print" test-Expression ] unit-test
+[ T{ ast-message-send f T{ ast-message-send f 5 "squared" { } } "print" { } } ] [ "5 squared print" test-Expression ] unit-test
+[ T{ ast-message-send f 2 "+" { 2 } } ] [ "2+2" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 3 "factorial" { } }
+        "+"
+        { T{ ast-message-send f 4 "factorial" { } } }
+    }
+]
+[ "3 factorial + 4 factorial" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f
+            T{ ast-message-send f 3 "factorial" { } }
+            "+"
+            { 4 }
+        }
+        "factorial"
+        { }
+    }
+]
+[ "(3 factorial + 4) factorial" test-Expression ] unit-test
+EBNF: test-FinalStatement
+test         = <foreign parse-smalltalk FinalStatement>
+;EBNF
+
+[ T{ ast-return f T{ ast-name f "value" } } ] [ "value" test-FinalStatement ] unit-test
+[ T{ ast-return f T{ ast-name f "value" } } ] [ "^value" test-FinalStatement ] unit-test
+[ T{ ast-return f T{ ast-assignment f T{ ast-name f "value" } 5 } } ] [ "value:=5" test-FinalStatement ] unit-test
+
+EBNF: test-LocalVariableDeclarationList
+test         = <foreign parse-smalltalk LocalVariableDeclarationList>
+;EBNF
+
+[ T{ ast-local-variables f { "i" "j" } } ] [ " |  i j   |" test-LocalVariableDeclarationList ] unit-test
+
+
+EBNF: test-KeywordMessageSend
+test         = <foreign parse-smalltalk KeywordMessageSend>
+;EBNF
+
+[ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
+[ "x foo:1 bar:2" test-KeywordMessageSend ] unit-test
+
+[
+    T{ ast-message-send
+        f
+        T{ ast-message-send f
+            T{ ast-message-send f 3 "factorial" { } }
+            "+"
+            { T{ ast-message-send f 4 "factorial" { } } }
+        }
+        "between:and:"
+        { 10 100 }
+    }
+]
+[ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
+
+[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
new file mode 100644
index 0000000000..2822165938
--- /dev/null
+++ b/extra/smalltalk/parser/parser.factor
@@ -0,0 +1,203 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
+math.parser kernel arrays byte-arrays math assocs ;
+IN: smalltalk.parser
+
+! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
+
+ERROR: bad-number str ;
+
+: check-number ( str -- n )
+    >string dup string>number [ ] [ bad-number ] ?if ;
+
+EBNF: parse-smalltalk
+
+Character = .
+WhitespaceCharacter = (" " | "\t" | "\n" | "\r" )
+DecimalDigit = [0-9]
+Letter = [A-Za-z]
+
+CommentCharacter = [^"] | '""' => [[ CHAR: " ]]
+Comment = '"' (CommentCharacter)*:s '"' => [[ s >string ast-comment boa ]]
+
+OptionalWhiteSpace = (WhitespaceCharacter | Comment)*
+Whitespace = (WhitespaceCharacter | Comment)+
+
+LetterOrDigit = DecimalDigit | Letter
+Identifier = (Letter | "_"):h (LetterOrDigit | "_")*:t => [[ { h t } flatten >string ]]
+Reference = Identifier => [[ ast-name boa ]]
+
+ConstantReference =   "nil" => [[ nil ]]
+                    | "false" => [[ f ]]
+                    | "true" => [[ t ]]
+PseudoVariableReference =   "self" => [[ self ]]
+                          | "super" => [[ super ]]
+ReservedIdentifier = PseudoVariableReference | ConstantReference
+
+BindableIdentifier = Identifier
+
+UnaryMessageSelector = Identifier
+
+Keyword = Identifier:i ":" => [[ i ":" append ]]
+
+KeywordMessageSelector = Keyword+ => [[ concat ]]
+BinarySelectorChar =   "~" | "!" | "@" | "%" | "&" | "*" | "-" | "+"
+                     | "=" | "|" | "\" | "<" | ">" | "," | "?" | "/"
+BinaryMessageSelector = BinarySelectorChar+ => [[ concat ]]
+
+OptionalMinus = ("-" => [[ CHAR: - ]])?
+IntegerLiteral = (OptionalMinus:m UnsignedIntegerLiteral:i) => [[ i m [ neg ] when ]]
+UnsignedIntegerLiteral =   Radix:r "r" BaseNIntegerLiteral:b => [[ b >string r base> ]]
+                         | DecimalIntegerLiteral => [[ check-number ]]
+DecimalIntegerLiteral = DecimalDigit+
+Radix = DecimalIntegerLiteral => [[ check-number ]]
+BaseNIntegerLiteral = LetterOrDigit+
+FloatingPointLiteral = (OptionalMinus
+                        DecimalIntegerLiteral
+                        ("." => [[ CHAR: . ]] DecimalIntegerLiteral Exponent? | Exponent))
+                        => [[ flatten check-number ]]
+Exponent = "e" => [[ CHAR: e ]] (OptionalMinus DecimalIntegerLiteral)?
+
+CharacterLiteral = "$" Character:c => [[ c ]]
+
+StringLiteral = "'" (StringLiteralCharacter | "''" => [[ CHAR: ' ]])*:s "'"
+                => [[ s >string ]]
+StringLiteralCharacter = [^']
+
+SymbolInArrayLiteral =   KeywordMessageSelector
+                       | UnaryMessageSelector
+                       | BinaryMessageSelector
+SymbolLiteral = "#" (SymbolInArrayLiteral | StringLiteral):s => [[ s intern ]]
+
+ArrayLiteral = (ObjectArrayLiteral | ByteArrayLiteral)
+ObjectArrayLiteral = "#" NestedObjectArrayLiteral:elts => [[ elts ]]
+NestedObjectArrayLiteral = "(" OptionalWhiteSpace
+                           (LiteralArrayElement:h
+                            (Whitespace LiteralArrayElement:e => [[ e ]])*:t
+                            => [[ t h prefix ]]
+                           )?:elts OptionalWhiteSpace ")" => [[ elts >array ]]
+
+LiteralArrayElement =   Literal
+                      | NestedObjectArrayLiteral
+                      | SymbolInArrayLiteral
+                      | ConstantReference
+
+ByteArrayLiteral = "#[" OptionalWhiteSpace
+                        (UnsignedIntegerLiteral:h
+                         (Whitespace UnsignedIntegerLiteral:i => [[ i ]])*:t
+                         => [[ t h prefix ]]
+                        )?:elts OptionalWhiteSpace "]" => [[ elts >byte-array ]]
+
+FormalBlockArgumentDeclaration = ":" BindableIdentifier:i => [[ i ]]
+FormalBlockArgumentDeclarationList =
+                FormalBlockArgumentDeclaration:h
+                (Whitespace FormalBlockArgumentDeclaration:v => [[ v ]])*:t
+                => [[ t h prefix ]]
+
+BlockLiteral = "["
+                (OptionalWhiteSpace
+                 FormalBlockArgumentDeclarationList:args
+                 OptionalWhiteSpace
+                 "|"
+                 => [[ args ]]
+                )?:args
+                ExecutableCode:body OptionalWhiteSpace
+                "]" => [[ args >array body ast-block boa ]]
+
+Literal = (ConstantReference
+                | FloatingPointLiteral
+                | IntegerLiteral
+                | CharacterLiteral
+                | StringLiteral
+                | ArrayLiteral
+                | SymbolLiteral
+                | BlockLiteral)
+
+NestedExpression = "(" Statement:s OptionalWhiteSpace ")" => [[ s ]]
+Operand =       Literal
+                | PseudoVariableReference
+                | Reference
+                | NestedExpression
+
+UnaryMessage = UnaryMessageSelector
+UnaryMessageOperand = UnaryMessageSend | Operand
+UnaryMessageSend = UnaryMessageOperand:receiver
+                   OptionalWhiteSpace UnaryMessageSelector:selector !(":")
+                   => [[ receiver selector { } ast-message-send boa ]]
+
+BinaryMessage = BinaryMessageSelector OptionalWhiteSpace BinaryMessageOperand
+BinaryMessageOperand = BinaryMessageSend | UnaryMessageSend | Operand
+BinaryMessageSend-1 = BinaryMessageOperand:lhs
+                    OptionalWhiteSpace
+                    BinaryMessageSelector:selector
+                    OptionalWhiteSpace
+                    UnaryMessageOperand:rhs
+                    => [[ lhs selector { rhs } ast-message-send boa ]]
+BinaryMessageSend = (BinaryMessageSend:lhs
+                    OptionalWhiteSpace
+                    BinaryMessageSelector:selector
+                    OptionalWhiteSpace
+                    UnaryMessageOperand:rhs
+                    => [[ lhs selector { rhs } ast-message-send boa ]])
+                    | BinaryMessageSend-1
+
+KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
+KeywordMessageSend = BinaryMessageOperand:receiver
+                     OptionalWhiteSpace
+                     KeywordMessageSegment:h
+                     (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
+                     => [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]]
+
+Expression = KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand
+
+AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
+                      OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
+AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment boa ]]
+Statement = AssignmentStatement | Expression
+
+MethodReturnOperator = OptionalWhiteSpace "^"
+FinalStatement = (MethodReturnOperator)? Statement:s => [[ s ast-return boa ]]
+
+LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
+                (BindableIdentifier:h
+                 (Whitespace BindableIdentifier:b => [[ b ]])*:t
+                 => [[ t h prefix ]]
+                )?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
+
+ExecutableCode = (LocalVariableDeclarationList)?
+                 ((Statement:s OptionalWhiteSpace "." => [[ s ]])*
+                 FinalStatement:f (".")? => [[ f ]])?
+                 => [[ sift >array ]]
+
+UnaryMethodHeader = UnaryMessageSelector:selector
+                  => [[ { selector { } } ]]
+BinaryMethodHeader = BinaryMessageSelector:selector OptionalWhiteSpace BindableIdentifier:identifier
+                   => [[ { selector { identifier } } ]]
+KeywordMethodHeaderSegment = Keyword:keyword
+                             OptionalWhiteSpace
+                             BindableIdentifier:identifier => [[ { keyword identifier } ]]
+KeywordMethodHeader = KeywordMethodHeaderSegment:h (Whitespace KeywordMethodHeaderSegment:s => [[ s ]])*:t
+                    => [[ t h prefix unzip [ concat ] dip 2array ]]
+MethodHeader =   KeywordMethodHeader
+               | BinaryMethodHeader
+               | UnaryMethodHeader
+MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:header
+        OptionalWhiteSpace "["
+        ExecutableCode:code
+        OptionalWhiteSpace "]"
+        => [[ header first2 "self" suffix code ast-block boa ast-method boa ]]
+
+ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
+        OptionalWhiteSpace
+        ("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
+        OptionalWhiteSpace "["
+        (OptionalWhiteSpace LocalVariableDeclarationList)?:ivars
+        (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix >array ]])?:methods
+        OptionalWhiteSpace "]"
+        => [[ name superclass "Object" or ivars methods ast-class boa ]]
+
+End = !(.)
+
+Program = ClassDeclaration* End
+;EBNF
\ No newline at end of file
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
new file mode 100644
index 0000000000..7771ee2b9c
--- /dev/null
+++ b/extra/smalltalk/parser/test.st
@@ -0,0 +1,66 @@
+class TreeNode extends Object [
+    |left right item|
+
+    method binarytrees: n to: output [
+        | minDepth maxDepth stretchDepth check longLivedTree iterations |
+        minDepth := 4.
+        maxDepth := minDepth + 2 max: n.
+        stretchDepth := maxDepth + 1.
+
+        check := (TreeNode bottomUpTree: 0 depth: stretchDepth) itemCheck.
+        output
+            nextPutAll: 'stretch tree of depth '; print: stretchDepth; tab;
+            nextPutAll: ' check: '; print: check; nl.
+
+        longLivedTree := TreeNode bottomUpTree: 0 depth: maxDepth.
+        minDepth to: maxDepth by: 2 do: [:depth|
+            iterations := 1 bitShift: maxDepth - depth + minDepth.
+
+            check := 0.
+            1 to: iterations do: [:i|
+                check := check + (TreeNode bottomUpTree: i depth: depth) itemCheck.
+                check := check + (TreeNode bottomUpTree: -1*i depth: depth) itemCheck
+            ].
+            output
+                print:  (2*iterations); tab;
+                nextPutAll: ' trees of depth '; print: depth; tab;
+                nextPutAll: ' check: '; print: check; nl
+            ].
+
+        output
+            nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
+            nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
+    ]
+
+    binarytrees [
+        self binarytrees: self arg to: self stdout.
+        ^''
+    ]
+
+    method left: leftChild right: rightChild item: anItem [
+        left := leftChild.
+        right := rightChild.
+        item := anItem
+    ]
+
+    method itemCheck [
+        ^left isNil
+            ifTrue: [item] ifFalse: [item + (left itemCheck - right itemCheck)]
+    ]
+
+    method bottomUpTree: anItem depth: anInteger [
+        ^(anInteger > 0)
+            ifTrue: [
+                self
+                    left: (self bottomUpTree: 2*anItem - 1 depth: anInteger - 1)
+                    right: (self bottomUpTree: 2*anItem depth: anInteger - 1)
+                    item: anItem
+            ] ifFalse: [self left: nil right: nil item: anItem]
+    ]
+
+    method left: leftChild right: rightChild item: anItem [
+        ^(super new) left: leftChild right: rightChild item: anItem
+    ]
+]
+
+Tests binarytrees.
diff --git a/extra/smalltalk/selectors/authors.txt b/extra/smalltalk/selectors/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/selectors/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/selectors/selectors.factor b/extra/smalltalk/selectors/selectors.factor
new file mode 100644
index 0000000000..51b2132dbe
--- /dev/null
+++ b/extra/smalltalk/selectors/selectors.factor
@@ -0,0 +1,26 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: combinators effects generic generic.standard
+kernel sequences words ;
+IN: smalltalk.selectors
+
+SYMBOLS: unary binary keyword ;
+
+: selector-type ( selector -- type )
+    {
+        { [ dup [ "+-*/%^&*|@" member? ] all? ] [ binary ] }
+        { [ CHAR: : over member? ] [ keyword ] }
+        [ unary ]
+    } cond nip ;
+
+: selector>effect ( selector -- effect )
+    dup selector-type {
+        { unary [ drop 0 ] }
+        { binary [ drop 1 ] }
+        { keyword [ [ CHAR: : = ] count ] }
+    } case "receiver" suffix { "result" } <effect> ;
+
+: selector>generic ( selector -- generic )
+    [ "selector-" prepend "smalltalk.selectors" create dup ]
+    [ selector>effect ]
+    bi define-simple-generic ;
diff --git a/extra/smalltalk/smalltalk.factor b/extra/smalltalk/smalltalk.factor
new file mode 100644
index 0000000000..27cd9912ed
--- /dev/null
+++ b/extra/smalltalk/smalltalk.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: ;
+IN: smalltalk

From 42d164db7709f8f0fa125fb17b95df1cd6e37425 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@oberon.local>
Date: Mon, 30 Mar 2009 07:19:14 -0500
Subject: [PATCH 018/135] Fix C99 complex number support in FFI on Mac OS X/PPC

---
 basis/cpu/ppc/ppc.factor | 39 ++++++++++++++++++++++++++++++++++-----
 vm/alien.c               | 13 ++++++++++++-
 vm/alien.h               |  1 +
 3 files changed, 47 insertions(+), 6 deletions(-)

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/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)
 

From 6b6de2b8aa36823ed00460cacbaced60fa5dfbd5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Mon, 30 Mar 2009 19:42:04 -0500
Subject: [PATCH 019/135] refactor some error handling in peg, more unit tests

---
 basis/peg/ebnf/ebnf-tests.factor | 12 +++++-
 basis/peg/ebnf/ebnf.factor       | 72 ++++++++++++++++++++------------
 2 files changed, 57 insertions(+), 27 deletions(-)

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 ;
-

From 381dbb957c44f8f17cd975329b1ca6f0277cc5dc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 30 Mar 2009 20:45:01 -0500
Subject: [PATCH 020/135] smalltalk: adding a small library, fix various bugs

---
 .../smalltalk/compiler/compiler-tests.factor  | 105 ++++++++++++------
 extra/smalltalk/compiler/compiler.factor      |  47 ++++++--
 extra/smalltalk/compiler/lexenv/lexenv.factor |  10 +-
 extra/smalltalk/library/authors.txt           |   1 +
 extra/smalltalk/library/library.factor        |  75 +++++++++++++
 extra/smalltalk/listener/authors.txt          |   1 +
 extra/smalltalk/listener/listener.factor      |  18 +++
 extra/smalltalk/parser/parser-tests.factor    |  77 ++++++++++++-
 extra/smalltalk/parser/parser.factor          |  19 +++-
 extra/smalltalk/printer/authors.txt           |   1 +
 extra/smalltalk/printer/printer.factor        |  34 ++++++
 extra/smalltalk/selectors/selectors.factor    |   6 +-
 12 files changed, 343 insertions(+), 51 deletions(-)
 create mode 100644 extra/smalltalk/library/authors.txt
 create mode 100644 extra/smalltalk/library/library.factor
 create mode 100644 extra/smalltalk/listener/authors.txt
 create mode 100644 extra/smalltalk/listener/listener.factor
 create mode 100644 extra/smalltalk/printer/authors.txt
 create mode 100644 extra/smalltalk/printer/printer.factor

diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
index ee944baf02..a8e918fcf4 100644
--- a/extra/smalltalk/compiler/compiler-tests.factor
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -3,43 +3,82 @@ stack-checker locals.rewrite.closures kernel accessors
 compiler.units sequences ;
 IN: smalltalk.compiler.tests
 
-[ 2 1 ] [
+: test-compilation ( ast -- quot )
     [
-        T{ ast-block f
-           { "a" "b" }
-           {
-               T{ ast-message-send f
-                  T{ ast-name f "a" }
-                  "+"
-                  { T{ ast-name f "b" } }
-               }
+        compile-method rewrite-closures first
+    ] with-compilation-unit ;
+
+: test-inference ( ast -- in# out# )
+    test-compilation infer [ in>> ] [ out>> ] bi ;
+
+[ 2 1 ] [
+    T{ ast-block f
+       { "a" "b" }
+       {
+           T{ ast-message-send f
+              T{ ast-name f "a" }
+              "+"
+              { T{ ast-name f "b" } }
            }
-        } compile-method
-        [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
-    ] with-compilation-unit
+       }
+    } test-inference
 ] unit-test
 
 [ 3 1 ] [
-    [
-        T{ ast-block f
-           { "a" "b" "c" }
-           {
-               T{ ast-assignment f
-                  T{ ast-name f "a" }
-                  T{ ast-message-send f
-                     T{ ast-name f "a" }
-                     "+"
-                     { T{ ast-name f "b" } }
-                  }
-               }
-               T{ ast-message-send f
-                  T{ ast-name f "b" }
-                  "blah:"
-                  { 123.456 }
-               }
-               T{ ast-return f T{ ast-name f "c" } }
+    T{ ast-block f
+       { "a" "b" "c" }
+       {
+           T{ ast-assignment f
+              T{ ast-name f "a" }
+              T{ ast-message-send f
+                 T{ ast-name f "asmal" }
+                 "+"
+                 { T{ ast-name f "b" } }
+              }
            }
-        } compile-method
-        [ . ] [ rewrite-closures first infer [ in>> ] [ out>> ] bi ] bi
-    ] with-compilation-unit
+           T{ ast-message-send f
+              T{ ast-name f "b" }
+              "blah:"
+              { 123.456 }
+           }
+           T{ ast-return f T{ ast-name f "c" } }
+       }
+    } test-inference
+] unit-test
+
+[ 0 1 ] [
+    T{ ast-block f
+       { }
+       {
+           T{ ast-message-send
+              { receiver 1 }
+              { selector "to:do:" }
+              { arguments
+                {
+                    10
+                    T{ ast-block
+                       { arguments { "i" } }
+                       { body
+                         {
+                             T{ ast-message-send
+                                { receiver
+                                  T{ ast-name { name "i" } }
+                                }
+                                { selector "print" }
+                             }
+                         }
+                       }
+                    }
+                }
+              }
+           }
+       }
+    } test-inference
+] unit-test
+
+[ "a" ] [
+    T{ ast-block f
+       { }
+       { { T{ ast-block { body { "a" } } } } }
+    } test-compilation call first call
 ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 1f3b0f94e5..b72b218f82 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators.short-circuit
 continuations fry kernel namespaces quotations sequences sets
-slots locals.types generalizations smalltalk.ast
+generalizations slots locals.types generalizations smalltalk.ast
 smalltalk.compiler.lexenv smalltalk.selectors ;
 IN: smalltalk.compiler
 
@@ -12,17 +12,19 @@ GENERIC: need-return-continuation? ( ast -- ? )
 
 M: ast-return need-return-continuation? drop t ;
 
-M: ast-block need-return-continuation? body>> [ need-return-continuation? ] any? ;
+M: ast-block need-return-continuation? body>> need-return-continuation? ;
 
 M: ast-message-send need-return-continuation?
     {
         [ receiver>> need-return-continuation? ]
-        [ arguments>> [ need-return-continuation? ] any? ]
+        [ arguments>> need-return-continuation? ]
     } 1&& ;
 
 M: ast-assignment need-return-continuation?
     value>> need-return-continuation? ;
 
+M: array need-return-continuation? [ need-return-continuation? ] any? ;
+
 M: object need-return-continuation? drop f ;
 
 GENERIC: assigned-locals ( ast -- seq )
@@ -30,16 +32,20 @@ GENERIC: assigned-locals ( ast -- seq )
 M: ast-return assigned-locals value>> assigned-locals ;
 
 M: ast-block assigned-locals
-    [ body>> [ assigned-locals ] map concat ] [ arguments>> ] bi diff ;
+    [ body>> assigned-locals ] [ arguments>> ] bi diff ;
 
 M: ast-message-send assigned-locals
+    [ arguments>> assigned-locals ]
     [ receiver>> assigned-locals ]
-    [ arguments>> [ assigned-locals ] map ] bi append ;
+    bi append ;
 
 M: ast-assignment assigned-locals
     [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
     [ value>> assigned-locals ] bi append ;
 
+M: array assigned-locals
+    [ assigned-locals ] map concat ;
+
 M: object assigned-locals drop f ;
 
 GENERIC: compile-ast ( lexenv ast -- quot )
@@ -52,8 +58,8 @@ M: ast-name compile-ast
     name>> swap local-readers>> at 1quotation ;
 
 M: ast-message-send compile-ast
+    [ arguments>> [ compile-ast ] with map [ ] join ]
     [ receiver>> compile-ast ]
-    [ arguments>> [ compile-ast ] with map concat ]
     [ nip selector>> selector>generic ]
     2tri [ append ] dip suffix ;
 
@@ -61,6 +67,22 @@ M: ast-return compile-ast
     value>> compile-ast
     [ return-continuation get continue-with ] append ;
 
+GENERIC: contains-blocks? ( obj -- ? )
+
+M: ast-block contains-blocks? drop t ;
+
+M: object contains-blocks? drop f ;
+
+M: array contains-blocks? [ contains-blocks? ] any? ;
+
+M: array compile-ast
+    dup contains-blocks? [
+        [ [ compile-ast ] with map [ ] join ] [ length ] bi
+        '[ @ _ narray ]
+    ] [
+        call-next-method
+    ] if ;
+
 GENERIC: compile-assignment ( lexenv name -- quot )
 
 M: ast-name compile-assignment
@@ -95,8 +117,15 @@ M: ast-block compile-ast
         bi-curry* bi
         append
     ] if-empty
-    <lambda> '[ @ ] ;
+    <lambda> '[ _ ] ;
 
 : compile-method ( block -- quot )
-    [ [ empty-lexenv ] dip compile-ast ] [ arguments>> length ] [ need-return-continuation? ] tri
-    [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
\ No newline at end of file
+    [ [ empty-lexenv ] dip compile-ast [ call ] compose ]
+    [ arguments>> length ]
+    [ need-return-continuation? ]
+    tri
+    [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
+
+: compile-statement ( statement -- quot )
+    [ [ empty-lexenv ] dip compile-ast ] [ need-return-continuation? ] bi
+    [ '[ [ [ return-continuation set @ ] callcc1 ] with-scope ] ] when ;
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index 2488a54c5f..2097dc8a50 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -3,9 +3,15 @@
 USING: assocs kernel accessors ;
 IN: smalltalk.compiler.lexenv
 
-TUPLE: lexenv local-readers local-writers ;
+! local-readers: assoc string => word
+! local-writers: assoc string => word
+! self: word or f for top-level forms
+! class: class word or f for top-level forms
+! method: generic word or f for top-level forms
+TUPLE: lexenv local-readers local-writers self class method ;
 
-C: <lexenv> lexenv
+: <lexenv> ( local-readers local-writers -- lexenv )
+    f f f lexenv boa ; inline
 
 CONSTANT: empty-lexenv T{ lexenv }
 
diff --git a/extra/smalltalk/library/authors.txt b/extra/smalltalk/library/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/library/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
new file mode 100644
index 0000000000..bf455c2c4a
--- /dev/null
+++ b/extra/smalltalk/library/library.factor
@@ -0,0 +1,75 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel present io math sequences assocs math.ranges
+locals smalltalk.selectors smalltalk.ast ;
+IN: smalltalk.library
+
+! Some unary selectors
+SELECTOR: print
+SELECTOR: asString
+
+M: object selector-print dup present print ;
+M: object selector-asString present ;
+
+! Some binary selectors
+SELECTOR: +
+SELECTOR: -
+SELECTOR: *
+SELECTOR: /
+SELECTOR: <
+SELECTOR: >
+SELECTOR: <=
+SELECTOR: >=
+SELECTOR: =
+
+M: object selector-+  swap +  ;
+M: object selector--  swap -  ;
+M: object selector-*  swap *  ;
+M: object selector-/  swap /  ;
+M: object selector-<  swap <  ;
+M: object selector->  swap >  ;
+M: object selector-<= swap <= ;
+M: object selector->= swap >= ;
+M: object selector-=  swap =  ;
+
+! Some keyword selectors
+SELECTOR: ifTrue:
+SELECTOR: ifFalse:
+SELECTOR: ifTrue:ifFalse:
+
+M: object selector-ifTrue: [ call( -- result ) ] [ drop nil ] if ;
+M: object selector-ifFalse: [ drop nil ] [ call( -- result ) ] if ;
+M: object selector-ifTrue:ifFalse: [ drop call( -- result ) ] [ nip call( -- result ) ] if ;
+
+SELECTOR: at:
+SELECTOR: at:put:
+
+M: sequence selector-at: nth ;
+M: sequence selector-at:put: ( key value receiver -- receiver ) [ swapd set-nth ] keep ;
+
+M: assoc selector-at: at ;
+M: assoc selector-at:put: ( key value receiver -- receiver ) [ swapd set-at ] keep ;
+
+SELECTOR: do:
+
+M:: object selector-do: ( quot receiver -- nil )
+    receiver [ quot call( elt -- result ) drop ] each nil ;
+
+SELECTOR: to:
+SELECTOR: to:do:
+
+M: object selector-to: swap [a,b] ;
+M:: object selector-to:do: ( to quot from -- nil )
+    from to [a,b] [ quot call( i -- result ) drop ] each nil ;
+
+SELECTOR: value
+SELECTOR: value:
+SELECTOR: value:value:
+SELECTOR: value:value:value:
+SELECTOR: value:value:value:value:
+
+M: object selector-value call( -- result ) ;
+M: object selector-value: call( input -- result ) ;
+M: object selector-value:value: call( input input -- result ) ;
+M: object selector-value:value:value: call( input input input -- result ) ;
+M: object selector-value:value:value:value: call( input input input input -- result ) ;
diff --git a/extra/smalltalk/listener/authors.txt b/extra/smalltalk/listener/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/listener/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
new file mode 100644
index 0000000000..e1bb6aca5e
--- /dev/null
+++ b/extra/smalltalk/listener/listener.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel prettyprint io io.styles colors.constants compiler.units
+fry debugger sequences locals.rewrite.closures smalltalk.ast
+smalltalk.parser smalltalk.compiler smalltalk.printer ;
+IN: smalltalk.listener
+
+: eval-smalltalk ( string -- )
+    [
+        parse-smalltalk-statement compile-statement rewrite-closures first
+    ] with-compilation-unit call( -- result )
+    dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ;
+
+: smalltalk-listener ( -- )
+    "Smalltalk>" { { background COLOR: light-blue } } format bl flush readln
+    [ '[ _ eval-smalltalk ] try smalltalk-listener ] when* ;
+
+MAIN: smalltalk-listener
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index 9a6614aa07..fa0fde51d6 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -53,6 +53,21 @@ test         = <foreign parse-smalltalk Literal>
 [ T{ ast-block f { "x" } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
 [ T{ ast-block f { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
 
+[
+    T{ ast-block
+       { arguments { "i" } }
+       { body
+         {
+             T{ ast-message-send
+                { receiver T{ ast-name { name "i" } } }
+                { selector "print" }
+             }
+         }
+       }
+    }
+]
+[ "[ :i | i print ]" test-Literal ] unit-test
+
 EBNF: test-FormalBlockArgumentDeclarationList
 test         = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
 ;EBNF
@@ -86,6 +101,24 @@ test         = <foreign parse-smalltalk Expression>
 ]
 [ "3 factorial + 4 factorial" test-Expression ] unit-test
 
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 3 "factorial" { } }
+        "+"
+        { T{ ast-message-send f 4 "factorial" { } } }
+    }
+]
+[ "   3 factorial + 4 factorial" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 3 "factorial" { } }
+        "+"
+        { T{ ast-message-send f 4 "factorial" { } } }
+    }
+]
+[ "   3 factorial + 4 factorial     " test-Expression ] unit-test
+
 [
     T{ ast-message-send f
         T{ ast-message-send f
@@ -98,13 +131,53 @@ test         = <foreign parse-smalltalk Expression>
     }
 ]
 [ "(3 factorial + 4) factorial" test-Expression ] unit-test
+
+[
+    T{ ast-message-send
+       { receiver
+         T{ ast-message-send
+            { receiver
+              T{ ast-message-send
+                 { receiver 1 }
+                 { selector "<" }
+                 { arguments { 10 } }
+              }
+            }
+            { selector "ifTrue:ifFalse:" }
+            { arguments
+              {
+                  T{ ast-block { body { "HI" } } }
+                  T{ ast-block { body { "BYE" } } }
+              }
+            }
+         }
+       }
+       { selector "print" }
+    }
+]
+[ "((1 < 10) ifTrue: [ 'HI' ] ifFalse: [ 'BYE' ]) print" test-Expression ] unit-test
+
+[
+    T{ ast-message-send
+       { receiver
+         T{ ast-message-send
+            { receiver { T{ ast-block { body { "a" } } } } }
+            { selector "at:" }
+            { arguments { 0 } }
+         }
+       }
+       { selector "value" }
+    }
+]
+[ "(#(['a']) at: 0) value" test-Expression ] unit-test
+
 EBNF: test-FinalStatement
 test         = <foreign parse-smalltalk FinalStatement>
 ;EBNF
 
-[ T{ ast-return f T{ ast-name f "value" } } ] [ "value" test-FinalStatement ] unit-test
+[ T{ ast-name f "value" } ] [ "value" test-FinalStatement ] unit-test
 [ T{ ast-return f T{ ast-name f "value" } } ] [ "^value" test-FinalStatement ] unit-test
-[ T{ ast-return f T{ ast-assignment f T{ ast-name f "value" } 5 } } ] [ "value:=5" test-FinalStatement ] unit-test
+[ T{ ast-assignment f T{ ast-name f "value" } 5 } ] [ "value:=5" test-FinalStatement ] unit-test
 
 EBNF: test-LocalVariableDeclarationList
 test         = <foreign parse-smalltalk LocalVariableDeclarationList>
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index 2822165938..e2fea234c8 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -143,13 +143,15 @@ BinaryMessageSend = (BinaryMessageSend:lhs
                     | BinaryMessageSend-1
 
 KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
-KeywordMessageSend = BinaryMessageOperand:receiver
+KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):receiver
                      OptionalWhiteSpace
                      KeywordMessageSegment:h
                      (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
                      => [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]]
 
-Expression = KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand
+Expression = OptionalWhiteSpace
+             (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
+             => [[ e ]]
 
 AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
                       OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
@@ -157,7 +159,8 @@ AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment
 Statement = AssignmentStatement | Expression
 
 MethodReturnOperator = OptionalWhiteSpace "^"
-FinalStatement = (MethodReturnOperator)? Statement:s => [[ s ast-return boa ]]
+FinalStatement = (MethodReturnOperator Statement:s => [[ s ast-return boa ]])
+                 | Statement
 
 LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
                 (BindableIdentifier:h
@@ -200,4 +203,14 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
 End = !(.)
 
 Program = ClassDeclaration* End
+;EBNF
+
+EBNF: parse-smalltalk-statement
+
+Statement = <foreign parse-smalltalk Statement>
+
+End = !(.)
+
+Program = Statement? => [[ nil or ]] End
+
 ;EBNF
\ No newline at end of file
diff --git a/extra/smalltalk/printer/authors.txt b/extra/smalltalk/printer/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/printer/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/printer/printer.factor b/extra/smalltalk/printer/printer.factor
new file mode 100644
index 0000000000..70055e8e77
--- /dev/null
+++ b/extra/smalltalk/printer/printer.factor
@@ -0,0 +1,34 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays byte-arrays kernel make math
+math.parser prettyprint sequences smalltalk.ast strings ;
+IN: smalltalk.printer
+
+GENERIC: smalltalk>string ( object -- string )
+
+M: real smalltalk>string number>string ;
+
+M: string smalltalk>string
+    [
+        "'" %
+        [ dup CHAR: ' = [ dup , , ] [ , ] if ] each
+        "'" %
+    ] "" make ;
+
+GENERIC: array-element>string ( object -- string )
+
+M: object array-element>string smalltalk>string ;
+
+M: array array-element>string
+    [ smalltalk>string ] map " " join "(" ")" surround ;
+
+M: array smalltalk>string
+    array-element>string "#" prepend ;
+
+M: byte-array smalltalk>string
+    [ number>string ] { } map-as " " join "#[" "]" surround ;
+
+M: symbol smalltalk>string
+    name>> smalltalk>string "#" prepend ;
+
+M: object smalltalk>string unparse-short ;
\ No newline at end of file
diff --git a/extra/smalltalk/selectors/selectors.factor b/extra/smalltalk/selectors/selectors.factor
index 51b2132dbe..2ea1e99afd 100644
--- a/extra/smalltalk/selectors/selectors.factor
+++ b/extra/smalltalk/selectors/selectors.factor
@@ -1,14 +1,14 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: combinators effects generic generic.standard
-kernel sequences words ;
+kernel sequences words lexer ;
 IN: smalltalk.selectors
 
 SYMBOLS: unary binary keyword ;
 
 : selector-type ( selector -- type )
     {
-        { [ dup [ "+-*/%^&*|@" member? ] all? ] [ binary ] }
+        { [ dup [ "~!@%&*-+=|\\<>,?/" member? ] all? ] [ binary ] }
         { [ CHAR: : over member? ] [ keyword ] }
         [ unary ]
     } cond nip ;
@@ -24,3 +24,5 @@ SYMBOLS: unary binary keyword ;
     [ "selector-" prepend "smalltalk.selectors" create dup ]
     [ selector>effect ]
     bi define-simple-generic ;
+
+SYNTAX: SELECTOR: scan selector>generic drop ;
\ No newline at end of file

From b32df2100a02c74df2948a16a2f4f53ed5fd4625 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Mon, 30 Mar 2009 20:45:55 -0500
Subject: [PATCH 021/135] Fix parse-feed for byte arrays

---
 basis/syndication/syndication-docs.factor  |  8 ++++----
 basis/syndication/syndication-tests.factor |  4 ++--
 basis/syndication/syndication.factor       | 21 ++++++++++++---------
 3 files changed, 18 insertions(+), 15 deletions(-)

diff --git a/basis/syndication/syndication-docs.factor b/basis/syndication/syndication-docs.factor
index 5604a94dbd..47bdc3bb36 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 { "sequence" "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..3bfc95fe3a 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 ( string -- 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
 

From 5b6948aaa5b4c652f0833fbbe74cb8a08d039515 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 01:24:38 -0500
Subject: [PATCH 022/135] smalltalk: working on lexical scoping for instance
 variables and class names

---
 extra/smalltalk/ast/ast.factor                |  2 +
 extra/smalltalk/classes/authors.txt           |  1 +
 extra/smalltalk/classes/classes.factor        | 25 ++++++
 .../smalltalk/compiler/compiler-tests.factor  | 10 +--
 extra/smalltalk/compiler/compiler.factor      | 88 +++++++++++++------
 .../compiler/lexenv/lexenv-tests.factor       | 24 +++++
 extra/smalltalk/compiler/lexenv/lexenv.factor | 54 ++++++++++--
 extra/smalltalk/library/library.factor        |  6 +-
 extra/smalltalk/listener/listener.factor      |  2 +-
 extra/smalltalk/parser/parser-tests.factor    | 18 ++++
 extra/smalltalk/parser/parser.factor          | 25 +++---
 11 files changed, 199 insertions(+), 56 deletions(-)
 create mode 100644 extra/smalltalk/classes/authors.txt
 create mode 100644 extra/smalltalk/classes/classes.factor
 create mode 100644 extra/smalltalk/compiler/lexenv/lexenv-tests.factor

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index 83e6d0ae84..f426789316 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -14,5 +14,7 @@ TUPLE: ast-assignment { name ast-name } value ;
 TUPLE: ast-local-variables { names array } ;
 TUPLE: ast-method { name string } { body ast-block } ;
 TUPLE: ast-class { name string } { superclass string } { ivars array } { methods array } ;
+TUPLE: ast-foreign { class string } { name string } ;
+
 TUPLE: symbol { name string } ;
 MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/classes/authors.txt b/extra/smalltalk/classes/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/classes/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/classes/classes.factor b/extra/smalltalk/classes/classes.factor
new file mode 100644
index 0000000000..1798aad961
--- /dev/null
+++ b/extra/smalltalk/classes/classes.factor
@@ -0,0 +1,25 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces assocs accessors words sequences classes.tuple ;
+IN: smalltalk.classes
+
+SYMBOL: classes
+
+classes [ H{ } clone ] initialize
+
+: create-class ( class -- class )
+    "smalltalk.classes" create ;
+
+ERROR: no-class name ;
+
+: lookup-class ( class -- class )
+    classes get ?at [ ] [ no-class ] if ;
+
+: define-class ( class superclass ivars -- class-word )
+    [ create-class ] [ lookup-class ] [ ] tri*
+    [ define-tuple-class ] [ 2drop dup dup name>> classes get set-at ] 3bi ;
+
+: define-foreign ( class name -- )
+    classes get set-at ;
+
+tuple "Object" define-foreign
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
index a8e918fcf4..c0b9507dd0 100644
--- a/extra/smalltalk/compiler/compiler-tests.factor
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -1,12 +1,10 @@
 USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
-stack-checker locals.rewrite.closures kernel accessors
-compiler.units sequences ;
+smalltalk.compiler.lexenv stack-checker locals.rewrite.closures
+kernel accessors compiler.units sequences ;
 IN: smalltalk.compiler.tests
 
 : test-compilation ( ast -- quot )
-    [
-        compile-method rewrite-closures first
-    ] with-compilation-unit ;
+    [ compile-smalltalk [ call ] append ] with-compilation-unit ;
 
 : test-inference ( ast -- in# out# )
     test-compilation infer [ in>> ] [ out>> ] bi ;
@@ -31,7 +29,7 @@ IN: smalltalk.compiler.tests
            T{ ast-assignment f
               T{ ast-name f "a" }
               T{ ast-message-send f
-                 T{ ast-name f "asmal" }
+                 T{ ast-name f "c" }
                  "+"
                  { T{ ast-name f "b" } }
               }
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index b72b218f82..9c3638ba6c 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -2,8 +2,10 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators.short-circuit
 continuations fry kernel namespaces quotations sequences sets
-generalizations slots locals.types generalizations smalltalk.ast
-smalltalk.compiler.lexenv smalltalk.selectors ;
+generalizations slots locals.types generalizations splitting math
+locals.rewrite.closures generic words smalltalk.ast
+smalltalk.compiler.lexenv smalltalk.selectors
+smalltalk.classes ;
 IN: smalltalk.compiler
 
 SYMBOL: return-continuation
@@ -52,10 +54,11 @@ GENERIC: compile-ast ( lexenv ast -- quot )
 
 M: object compile-ast nip 1quotation ;
 
+M: self compile-ast drop self>> 1quotation ;
+
 ERROR: unbound-local name ;
 
-M: ast-name compile-ast
-    name>> swap local-readers>> at 1quotation ;
+M: ast-name compile-ast name>> swap lookup-reader ;
 
 M: ast-message-send compile-ast
     [ arguments>> [ compile-ast ] with map [ ] join ]
@@ -79,14 +82,11 @@ M: array compile-ast
     dup contains-blocks? [
         [ [ compile-ast ] with map [ ] join ] [ length ] bi
         '[ @ _ narray ]
-    ] [
-        call-next-method
-    ] if ;
+    ] [ call-next-method ] if ;
 
 GENERIC: compile-assignment ( lexenv name -- quot )
 
-M: ast-name compile-assignment
-    name>> swap local-writers>> at 1quotation ;
+M: ast-name compile-assignment name>> swap lookup-writer ;
 
 M: ast-assignment compile-ast
     [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
@@ -102,30 +102,62 @@ M: ast-assignment compile-ast
     dup
     [ nip local-reader? ] assoc-filter
     [ <local-writer> ] assoc-map
-    <lexenv> ;
+    <lexenv> swap >>local-writers swap >>local-readers ;
 
-M: ast-block compile-ast
+: compile-block ( lexenv block -- vars body )
     [
         block-lexenv
         [ nip local-readers>> values ]
         [ lexenv-union ] 2bi
     ] [ body>> ] bi
-    [ drop [ nil ] ] [
-        unclip-last
-        [ [ compile-ast [ drop ] append ] with map [ ] join ]
-        [ compile-ast ]
-        bi-curry* bi
-        append
-    ] if-empty
-    <lambda> '[ _ ] ;
+    [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
 
-: compile-method ( block -- quot )
-    [ [ empty-lexenv ] dip compile-ast [ call ] compose ]
-    [ arguments>> length ]
-    [ need-return-continuation? ]
-    tri
-    [ '[ [ _ _ ncurry [ return-continuation set ] prepose callcc1 ] with-scope ] ] [ drop ] if ;
+M: ast-block compile-ast
+    compile-block <lambda> '[ _ ] ;
 
-: compile-statement ( statement -- quot )
-    [ [ empty-lexenv ] dip compile-ast ] [ need-return-continuation? ] bi
-    [ '[ [ [ return-continuation set @ ] callcc1 ] with-scope ] ] when ;
+: make-return ( quot n block -- quot )
+    need-return-continuation? [
+        '[
+            [
+                _ _ ncurry
+                [ return-continuation set ] prepose callcc1
+            ] with-scope
+        ]
+    ] [ drop ] if
+    rewrite-closures first ;
+
+GENERIC: compile-smalltalk ( ast -- quot )
+
+M: object compile-smalltalk ( statement -- quot )
+    [ [ empty-lexenv ] dip compile-ast 0 ] keep make-return ;
+
+: (compile-method-body) ( lexenv block -- lambda )
+    [ drop self>> ] [ compile-block ] 2bi [ swap suffix ] dip <lambda> ;
+
+: compile-method-body ( lexenv block -- quot )
+    [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep
+    make-return ;
+
+: compile-method ( lexenv ast-method -- )
+    [ [ class>> ] [ name>> selector>generic ] bi* create-method ]
+    [ body>> compile-method-body ]
+    2bi define ;
+
+: <class-lexenv> ( class -- lexenv )
+    <lexenv> swap >>class "self" <local-reader> >>self ;
+
+M: ast-class compile-smalltalk ( ast-class -- quot )
+    [
+        [ name>> ] [ superclass>> ] [ ivars>> ] tri
+        define-class <class-lexenv> 
+    ]
+    [ methods>> ] bi
+    [ compile-method ] with each
+    [ nil ] ;
+
+ERROR: no-word name ;
+
+M: ast-foreign compile-smalltalk
+    [ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
+    [ name>> ] bi define-foreign
+    [ nil ] ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv-tests.factor b/extra/smalltalk/compiler/lexenv/lexenv-tests.factor
new file mode 100644
index 0000000000..8f171f3eed
--- /dev/null
+++ b/extra/smalltalk/compiler/lexenv/lexenv-tests.factor
@@ -0,0 +1,24 @@
+USING: smalltalk.compiler.lexenv tools.test kernel namespaces accessors ;
+IN: smalltalk.compiler.lexenv.tests
+
+TUPLE: some-class x y z ;
+
+SYMBOL: fake-self
+
+SYMBOL: fake-local
+
+<lexenv>
+    some-class >>class
+    fake-self >>self
+    H{ { "mumble" fake-local } } >>local-readers
+    H{ { "jumble" fake-local } } >>local-writers
+lexenv set
+
+[ [ fake-local ] ] [ "mumble" lexenv get lookup-reader ] unit-test
+[ [ fake-self x>> ] ] [ "x" lexenv get lookup-reader ] unit-test
+[ [ \ tuple ] ] [ "Object" lexenv get lookup-reader ] unit-test
+
+[ [ fake-local ] ] [ "jumble" lexenv get lookup-writer ] unit-test
+[ [ fake-self (>>y) ] ] [ "y" lexenv get lookup-writer ] unit-test
+
+[ "blahblah" lexenv get lookup-writer ] must-fail
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index 2097dc8a50..b204b057b6 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -1,6 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: assocs kernel accessors ;
+USING: assocs kernel accessors quotations slots words
+sequences namespaces combinators combinators.short-circuit
+smalltalk.classes ;
 IN: smalltalk.compiler.lexenv
 
 ! local-readers: assoc string => word
@@ -10,11 +12,53 @@ IN: smalltalk.compiler.lexenv
 ! method: generic word or f for top-level forms
 TUPLE: lexenv local-readers local-writers self class method ;
 
-: <lexenv> ( local-readers local-writers -- lexenv )
-    f f f lexenv boa ; inline
+: <lexenv> ( -- lexenv ) lexenv new ; inline
 
 CONSTANT: empty-lexenv T{ lexenv }
 
 : lexenv-union ( lexenv1 lexenv2 -- lexenv )
-    [ [ local-readers>> ] bi@ assoc-union ]
-    [ [ local-writers>> ] bi@ assoc-union ] 2bi <lexenv> ;
+    [ <lexenv> ] 2dip {
+        [ [ local-readers>> ] bi@ assoc-union >>local-readers ]
+        [ [ local-writers>> ] bi@ assoc-union >>local-writers ]
+        [ [ self>> ] either? >>self ]
+        [ [ class>> ] either? >>class ]
+        [ [ method>> ] either? >>method ]
+    } 2cleave ;
+
+: local-reader ( name lexenv -- local )
+    local-readers>> at dup [ 1quotation ] when ;
+
+: ivar-reader ( name lexenv -- quot/f )
+    dup class>> [
+        [ class>> "slots" word-prop slot-named ] [ self>> ] bi
+        swap dup [ name>> reader-word [ ] 2sequence ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
+: class-name ( name -- quot/f )
+    classes get at dup [ [ ] curry ] when ;
+
+ERROR: bad-identifier name ;
+
+: lookup-reader ( name lexenv -- reader-quot )
+    {
+        [ local-reader ]
+        [ ivar-reader ]
+        [ drop class-name ]
+        [ drop bad-identifier ]
+    } 2|| ;
+
+: local-writer ( name lexenv -- local )
+    local-writers>> at dup [ 1quotation ] when ;
+
+: ivar-writer ( name lexenv -- quot/f )
+    dup class>> [
+        [ class>> "slots" word-prop slot-named ] [ self>> ] bi
+        swap dup [ name>> writer-word [ ] 2sequence ] [ 2drop f ] if
+    ] [ 2drop f ] if ;
+
+: lookup-writer ( name lexenv -- writer-quot )
+    {
+        [ local-writer ]
+        [ ivar-writer ]
+        [ drop bad-identifier ]
+    } 2|| ;
\ No newline at end of file
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
index bf455c2c4a..1b24db71e8 100644
--- a/extra/smalltalk/library/library.factor
+++ b/extra/smalltalk/library/library.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel present io math sequences assocs math.ranges
-locals smalltalk.selectors smalltalk.ast ;
+locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
 IN: smalltalk.library
 
 ! Some unary selectors
@@ -73,3 +73,7 @@ M: object selector-value: call( input -- result ) ;
 M: object selector-value:value: call( input input -- result ) ;
 M: object selector-value:value:value: call( input input input -- result ) ;
 M: object selector-value:value:value:value: call( input input input input -- result ) ;
+
+SELECTOR: new
+
+M: object selector-new new ;
\ No newline at end of file
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
index e1bb6aca5e..bef4adc196 100644
--- a/extra/smalltalk/listener/listener.factor
+++ b/extra/smalltalk/listener/listener.factor
@@ -7,7 +7,7 @@ IN: smalltalk.listener
 
 : eval-smalltalk ( string -- )
     [
-        parse-smalltalk-statement compile-statement rewrite-closures first
+        parse-smalltalk compile-smalltalk
     ] with-compilation-unit call( -- result )
     dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ;
 
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index fa0fde51d6..aa440f581e 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -68,6 +68,13 @@ test         = <foreign parse-smalltalk Literal>
 ]
 [ "[ :i | i print ]" test-Literal ] unit-test
 
+[
+    T{ ast-block
+       { body { 5 self } }
+    }
+]
+[ "[5. self]" test-Literal ] unit-test
+
 EBNF: test-FormalBlockArgumentDeclarationList
 test         = <foreign parse-smalltalk FormalBlockArgumentDeclarationList>
 ;EBNF
@@ -207,4 +214,15 @@ test         = <foreign parse-smalltalk KeywordMessageSend>
 ]
 [ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
 
+[ { 1 2 } ] [ "1. 2" parse-smalltalk ] unit-test
+
+[
+    T{ ast-class
+       { name "Test" }
+       { superclass "Object" }
+       { ivars { "a" } }
+    }
+]
+[ "class Test [|a|]" parse-smalltalk ] unit-test
+
 [ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index e2fea234c8..e153e1552d 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
-math.parser kernel arrays byte-arrays math assocs ;
+math.parser kernel arrays byte-arrays math assocs accessors ;
 IN: smalltalk.parser
 
 ! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
@@ -189,28 +189,23 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
         OptionalWhiteSpace "["
         ExecutableCode:code
         OptionalWhiteSpace "]"
-        => [[ header first2 "self" suffix code ast-block boa ast-method boa ]]
+        => [[ header first2 code ast-block boa ast-method boa ]]
 
 ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         OptionalWhiteSpace
         ("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
         OptionalWhiteSpace "["
-        (OptionalWhiteSpace LocalVariableDeclarationList)?:ivars
-        (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix >array ]])?:methods
+        (OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
+        (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix ]])?:methods
         OptionalWhiteSpace "]"
-        => [[ name superclass "Object" or ivars methods ast-class boa ]]
+        => [[ name superclass "Object" or ivars >array methods >array ast-class boa ]]
 
+ForeignClassDeclaration = OptionalWhiteSpace "foreign"
+                          OptionalWhiteSpace Identifier:name
+                          OptionalWhiteSpace Literal:class
+                          => [[ class name ast-foreign boa ]]
 End = !(.)
 
-Program = ClassDeclaration* End
-;EBNF
-
-EBNF: parse-smalltalk-statement
-
-Statement = <foreign parse-smalltalk Statement>
-
-End = !(.)
-
-Program = Statement? => [[ nil or ]] End
+Program = (ClassDeclaration|ForeignClassDeclaration|ExecutableCode) => [[ nil or ]] End
 
 ;EBNF
\ No newline at end of file

From 712b21b59e14c78e387b3e6cd17fb0471ed46960 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 01:37:05 -0500
Subject: [PATCH 023/135] Fix printing of nested arrays

---
 extra/smalltalk/printer/printer-tests.factor | 4 ++++
 extra/smalltalk/printer/printer.factor       | 2 +-
 2 files changed, 5 insertions(+), 1 deletion(-)
 create mode 100644 extra/smalltalk/printer/printer-tests.factor

diff --git a/extra/smalltalk/printer/printer-tests.factor b/extra/smalltalk/printer/printer-tests.factor
new file mode 100644
index 0000000000..e9f4bd9451
--- /dev/null
+++ b/extra/smalltalk/printer/printer-tests.factor
@@ -0,0 +1,4 @@
+IN: smalltalk.printer.tests
+USING: smalltalk.printer tools.test ;
+
+[ "#((1 2) 'hi')" ] [ { { 1 2 } "hi" } smalltalk>string ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/printer/printer.factor b/extra/smalltalk/printer/printer.factor
index 70055e8e77..9b6aa11114 100644
--- a/extra/smalltalk/printer/printer.factor
+++ b/extra/smalltalk/printer/printer.factor
@@ -20,7 +20,7 @@ GENERIC: array-element>string ( object -- string )
 M: object array-element>string smalltalk>string ;
 
 M: array array-element>string
-    [ smalltalk>string ] map " " join "(" ")" surround ;
+    [ array-element>string ] map " " join "(" ")" surround ;
 
 M: array smalltalk>string
     array-element>string "#" prepend ;

From 85fb4aab89d2d9940ba5e71f292f640629c7cb11 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 04:43:26 -0500
Subject: [PATCH 024/135] syndication: fix help lint

---
 basis/syndication/syndication-docs.factor | 2 +-
 basis/syndication/syndication.factor      | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/syndication/syndication-docs.factor b/basis/syndication/syndication-docs.factor
index 47bdc3bb36..bc9612f55c 100644
--- a/basis/syndication/syndication-docs.factor
+++ b/basis/syndication/syndication-docs.factor
@@ -36,7 +36,7 @@ HELP: download-feed
 { $description "Downloads a feed from a URL using the " { $link "http.client" } "." } ;
 
 HELP: parse-feed
-{ $values { "sequence" "a string or a byte array" } { "feed" feed } }
+{ $values { "seq" "a string or a byte array" } { "feed" feed } }
 { $description "Parses a feed." } ;
 
 HELP: xml>feed
diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor
index 3bfc95fe3a..e30cd6826c 100755
--- a/basis/syndication/syndication.factor
+++ b/basis/syndication/syndication.factor
@@ -106,7 +106,7 @@ TUPLE: entry title url description date ;
         { "feed" [ atom1.0 ] }
     } case ;
 
-GENERIC: parse-feed ( string -- feed )
+GENERIC: parse-feed ( seq -- feed )
 
 M: string parse-feed [ string>xml xml>feed ] with-html-entities ;
 

From 1dfa621f4db3ccb5dafbe10c69f9e2e17869612b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 08:03:27 -0500
Subject: [PATCH 025/135] Tweak some code to reduce deployed image size

---
 basis/cocoa/application/application.factor   | 2 +-
 basis/core-foundation/strings/strings.factor | 4 ++--
 basis/io/encodings/ascii/ascii.factor        | 6 ++----
 basis/io/encodings/iana/iana.factor          | 5 ++++-
 basis/tools/deploy/shaker/shaker.factor      | 1 +
 5 files changed, 10 insertions(+), 8 deletions(-)

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/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/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/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"

From 39b53817b948b69e8d61525a03fb20f78b970946 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 08:15:27 -0500
Subject: [PATCH 026/135] Small size reduction for deployed images

---
 basis/compiler/codegen/codegen.factor |  2 +-
 vm/callstack.c                        |  2 +-
 vm/code_block.c                       | 11 +++++------
 vm/code_block.h                       |  5 ++++-
 vm/debug.c                            | 11 +++++++----
 vm/quotations.c                       |  3 ++-
 6 files changed, 20 insertions(+), 14 deletions(-)

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/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 c6ecb2f431..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));
@@ -368,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]);
@@ -429,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));
 

From 932d44cab8d62f2add4187ac4c3d88f98009f00e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 08:16:04 -0500
Subject: [PATCH 027/135] Small speedup for code using H{ } clone and
 with-scope

---
 .../compiler/tree/propagation/known-words/known-words.factor  | 2 +-
 basis/hints/hints.factor                                      | 2 +-
 core/hashtables/hashtables.factor                             | 4 ++--
 core/namespaces/namespaces.factor                             | 2 +-
 4 files changed, 5 insertions(+), 5 deletions(-)

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/hints/hints.factor b/basis/hints/hints.factor
index 597367c353..804ef035f4 100644
--- a/basis/hints/hints.factor
+++ b/basis/hints/hints.factor
@@ -119,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/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/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

From 65cb08c3550962672a03d14ae76ae23da6d224c4 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Tue, 31 Mar 2009 11:12:05 -0500
Subject: [PATCH 028/135] fix help-lint for syndication

---
 basis/syndication/syndication.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/syndication/syndication.factor b/basis/syndication/syndication.factor
index 3bfc95fe3a..75c1824c78 100755
--- a/basis/syndication/syndication.factor
+++ b/basis/syndication/syndication.factor
@@ -106,7 +106,7 @@ TUPLE: entry title url description date ;
         { "feed" [ atom1.0 ] }
     } case ;
 
-GENERIC: parse-feed ( string -- feed )
+GENERIC: parse-feed ( sequence -- feed )
 
 M: string parse-feed [ string>xml xml>feed ] with-html-entities ;
 

From a07c17598efaaffee33c146464573d184042c53c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 16:04:39 -0500
Subject: [PATCH 029/135] redo state parser to avoid dynamic variables

---
 extra/html/parser/state/state-tests.factor | 34 +++++++---
 extra/html/parser/state/state.factor       | 73 ++++++++++++++--------
 2 files changed, 72 insertions(+), 35 deletions(-)

diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index da70d0fa12..f676649aa8 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -1,14 +1,30 @@
-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 ] string-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 ] string-parse
+] unit-test
+
+[ "foo" ";bar" ]
+[
+    "foo;bar" [
+        [ CHAR: ; take-until-char ] [ take-rest ] bi
+    ] string-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-string ] [ take-rest ] bi 
+    ] string-parse
+] unit-test
+
+[ 6 ]
+[
+    "      foo   " [ skip-whitespace i>> ] string-parse
+] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 1b3f188a78..c69fd76af5 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -1,41 +1,62 @@
 ! 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 string i ;
 
-: get-i ( -- i ) state get i>> ; inline
+: <state-parser> ( string -- state-parser )
+    state-parser new
+        swap >>string
+        0 >>i ;
 
-: get-char ( -- char )
-    state get [ i>> ] [ string>> ] bi ?nth ; inline
+: (get-char) ( i state -- char/f )
+    string>> ?nth ; inline
 
-: get-next ( -- char )
-    state get [ i>> 1+ ] [ string>> ] bi ?nth ; inline
+: get-char ( state -- char/f )
+    [ i>> ] keep (get-char) ; inline
 
-: next ( -- )
-    state get [ 1+ ] change-i drop ; inline
+: get-next ( state -- char/f )
+    [ i>> 1+ ] keep (get-char) ; inline
+
+: next ( state -- state )
+    [ 1+ ] change-i ; inline
+
+: get+increment ( state -- char/f )
+    [ get-char ] [ next drop ] bi ; inline
 
 : string-parse ( string quot -- )
-    [ 0 state boa state ] dip with-variable ; inline
+    [ <state-parser> ] dip call ; inline
 
-: short* ( n seq -- n' seq )
-    over [ nip dup length swap ] unless ; inline
+:: skip-until ( state quot: ( obj -- ? ) -- )
+    state get-char [
+        quot call [ state next quot skip-until ] unless
+    ] when* ; inline recursive
 
-: skip-until ( quot: ( -- ? ) -- )
-    get-char [
-        [ call ] keep swap
-        [ drop ] [ next skip-until ] if
-    ] [ drop ] if ; inline recursive
+: take-until ( state quot: ( obj -- ? ) -- string )
+    [ drop i>> ]
+    [ skip-until ]
+    [ drop [ i>> ] [ string>> ] bi ] 2tri subseq ; inline
 
-: take-until ( quot: ( -- ? ) -- )
-    get-i [ skip-until ] dip get-i
-    state get string>> subseq ; inline
+:: take-until-string ( state-parser string -- string' )
+    string length <growing-circular> :> growing
+    state-parser
+    [
+        growing push-growing-circular
+        string 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 ;
 
-: string-matches? ( string circular -- ? )
-    get-char over push-growing-circular sequence= ; inline
+: take-rest ( state -- string )
+    [ drop f ] take-until ; inline
 
-: take-string ( match -- string )
-    dup length <growing-circular>
-    [ 2dup string-matches? ] take-until nip
-    dup length rot length 1- - head next ; inline
+: take-until-char ( state ch -- string )
+    '[ _ = ] take-until ;
+
+: string-parse-end? ( state -- ? ) get-next not ;

From ebddd32677f92efda0715e9b1817288a4dc3d447 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 16:05:11 -0500
Subject: [PATCH 030/135] remove duplication, refactor html.parser to use new
 state parser

---
 extra/html/parser/parser.factor            | 145 ++++++++++-----------
 extra/html/parser/utils/utils-tests.factor |   9 +-
 extra/html/parser/utils/utils.factor       |  16 +--
 3 files changed, 69 insertions(+), 101 deletions(-)

diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 60e5ddbf54..677737618b 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,113 +30,100 @@ 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-string make-comment-tag push-tag ;
 
-: read-dtd ( -- )
-    ">" take-string make-dtd-tag push-tag ;
+: read-dtd ( state-parser -- )
+    ">" take-until-string 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 string-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
+        [ read-token >lower ] [ parse-attributes ] bi
     ] string-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
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 ;

From ce04d1dfa96f0cfaf37155b8b8095c8122a172c0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 18:21:15 -0500
Subject: [PATCH 031/135] redo spider without dynamic variables

---
 extra/spider/spider-docs.factor |   5 --
 extra/spider/spider.factor      | 114 ++++++++++++++++++++------------
 2 files changed, 73 insertions(+), 46 deletions(-)

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..42f2485ebe 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -3,22 +3,44 @@
 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
-filters spidered todo nonmatching quiet ;
+filters spidered todo nonmatching filtered 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 ;
+
+: store-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> [ store-url ] keep >>todo
+        <unique-deque> >>nonmatching
+        <unique-deque> >>filtered
         0 >>max-depth
         0 >>count
         1/0. >>max-count
@@ -27,10 +49,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 -- )
+    '[ _ _ store-url ] each ;
 
 : add-todo ( links level spider -- )
     todo>> push-links ;
@@ -38,64 +60,74 @@ links processing-time timestamp ;
 : add-nonmatching ( links level spider -- )
     nonmatching>> push-links ;
 
-: filter-base ( spider spider-result -- base-links nonmatching-links )
+: add-filtered ( links level spider -- )
+    filtered>> push-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 < ]
+    } 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 ;

From e22823f2c44ba8769664178b66c2ea9f69d73705 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 18:23:02 -0500
Subject: [PATCH 032/135] rename word

---
 extra/spider/spider.factor | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index 42f2485ebe..0287d50692 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -25,7 +25,7 @@ TUPLE: unique-deque assoc deque ;
 : <unique-deque> ( -- unique-deque )
     H{ } clone <dlist> unique-deque boa ;
 
-: store-url ( url depth unique-deque -- )
+: push-url ( url depth unique-deque -- )
     [ <todo-url> ] dip
     [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
     [ deque>> push-back ] 2bi ;
@@ -38,7 +38,7 @@ TUPLE: unique-deque assoc deque ;
     >url
     spider new
         over >>base
-        swap 0 <unique-deque> [ store-url ] keep >>todo
+        swap 0 <unique-deque> [ push-url ] keep >>todo
         <unique-deque> >>nonmatching
         <unique-deque> >>filtered
         0 >>max-depth
@@ -52,7 +52,7 @@ TUPLE: unique-deque assoc deque ;
     filters>> [ '[ [ _ 1&& ] filter ] call( seq -- seq' ) ] when* ;
 
 : push-links ( links level unique-deque -- )
-    '[ _ _ store-url ] each ;
+    '[ _ _ push-url ] each ;
 
 : add-todo ( links level spider -- )
     todo>> push-links ;

From 8e26b19cc0aa008af012af16f2f1055a10faa251 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 18:49:41 -0500
Subject: [PATCH 033/135] state-parser works with sequences, not strings fix
 bug with take-until

---
 extra/html/parser/parser.factor            | 10 ++---
 extra/html/parser/state/state-tests.factor | 20 +++++----
 extra/html/parser/state/state.factor       | 47 ++++++++++++----------
 3 files changed, 44 insertions(+), 33 deletions(-)

diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 677737618b..94ef59bdfd 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -68,10 +68,10 @@ SYMBOL: tagstack
     [ blank? ] trim ;
 
 : read-comment ( state-parser -- )
-    "-->" take-until-string make-comment-tag push-tag ;
+    "-->" take-until-sequence make-comment-tag push-tag ;
 
 : read-dtd ( state-parser -- )
-    ">" take-until-string make-dtd-tag push-tag ;
+    ">" take-until-sequence make-dtd-tag push-tag ;
 
 : read-bang ( state-parser -- )
     next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [
@@ -93,7 +93,7 @@ SYMBOL: tagstack
 
 : (parse-attributes) ( state-parser -- )
     skip-whitespace
-    dup string-parse-end? [
+    dup state-parse-end? [
         drop
     ] [
         [
@@ -108,7 +108,7 @@ SYMBOL: tagstack
 : (parse-tag) ( string -- string' hashtable )
     [
         [ read-token >lower ] [ parse-attributes ] bi
-    ] string-parse ;
+    ] state-parse ;
 
 : read-< ( state-parser -- string/f )
     next dup get-char [
@@ -126,7 +126,7 @@ SYMBOL: tagstack
     ] [ 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 f676649aa8..f9862e1e69 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -2,29 +2,35 @@ USING: tools.test html.parser.state ascii kernel accessors ;
 IN: html.parser.state.tests
 
 [ "hello" ]
-[ "hello" [ take-rest ] string-parse ] unit-test
+[ "hello" [ take-rest ] state-parse ] unit-test
 
 [ "hi" " how are you?" ]
 [
     "hi how are you?"
-    [ [ [ blank? ] take-until ] [ take-rest ] bi ] string-parse
+    [ [ [ blank? ] take-until ] [ take-rest ] bi ] state-parse
 ] unit-test
 
 [ "foo" ";bar" ]
 [
     "foo;bar" [
-        [ CHAR: ; take-until-char ] [ take-rest ] bi
-    ] string-parse
+        [ CHAR: ; take-until-object ] [ take-rest ] bi
+    ] state-parse
 ] unit-test
 
 [ "foo " " bar" ]
 [
     "foo and bar" [
-        [ "and" take-until-string ] [ take-rest ] bi 
-    ] string-parse
+        [ "and" take-until-sequence ] [ take-rest ] bi 
+    ] state-parse
 ] unit-test
 
 [ 6 ]
 [
-    "      foo   " [ skip-whitespace i>> ] string-parse
+    "      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 c69fd76af5..2369b1d750 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -2,31 +2,32 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math kernel sequences accessors fry circular
 unicode.case unicode.categories locals ;
+
 IN: html.parser.state
 
-TUPLE: state-parser string i ;
+TUPLE: state-parser sequence n ;
 
-: <state-parser> ( string -- state-parser )
+: <state-parser> ( sequence -- state-parser )
     state-parser new
-        swap >>string
-        0 >>i ;
+        swap >>sequence
+        0 >>n ;
 
-: (get-char) ( i state -- char/f )
-    string>> ?nth ; inline
+: (get-char) ( n state -- char/f )
+    sequence>> ?nth ; inline
 
 : get-char ( state -- char/f )
-    [ i>> ] keep (get-char) ; inline
+    [ n>> ] keep (get-char) ; inline
 
 : get-next ( state -- char/f )
-    [ i>> 1+ ] keep (get-char) ; inline
+    [ n>> 1 + ] keep (get-char) ; inline
 
 : next ( state -- state )
-    [ 1+ ] change-i ; inline
+    [ 1 + ] change-n ; inline
 
 : get+increment ( state -- char/f )
     [ get-char ] [ next drop ] bi ; inline
 
-: string-parse ( string quot -- )
+: state-parse ( sequence quot -- )
     [ <state-parser> ] dip call ; inline
 
 :: skip-until ( state quot: ( obj -- ? ) -- )
@@ -34,17 +35,23 @@ TUPLE: state-parser string i ;
         quot call [ state next quot skip-until ] unless
     ] when* ; inline recursive
 
-: take-until ( state quot: ( obj -- ? ) -- string )
-    [ drop i>> ]
-    [ skip-until ]
-    [ drop [ i>> ] [ string>> ] bi ] 2tri subseq ; inline
+: state-parse-end? ( state -- ? ) get-next not ;
 
-:: take-until-string ( state-parser string -- string' )
-    string length <growing-circular> :> growing
+: 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
-        string growing sequence=
+        sequence growing sequence=
     ] take-until :> found
     found dup length
     growing length 1- - head
@@ -53,10 +60,8 @@ TUPLE: state-parser string i ;
 : skip-whitespace ( state -- state )
     [ [ blank? not ] take-until drop ] keep ;
 
-: take-rest ( state -- string )
+: take-rest ( state -- sequence )
     [ drop f ] take-until ; inline
 
-: take-until-char ( state ch -- string )
+: take-until-object ( state obj -- sequence )
     '[ _ = ] take-until ;
-
-: string-parse-end? ( state -- ? ) get-next not ;

From 15cb926afb6504bb24095f2788df3fdf0d2612ba Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 21:23:09 -0500
Subject: [PATCH 034/135] smalltalk: Working on message cascade syntax

---
 extra/smalltalk/ast/ast.factor                | 11 ++-
 extra/smalltalk/compiler/compiler.factor      | 52 ++++++++++++--
 extra/smalltalk/compiler/lexenv/lexenv.factor |  4 +-
 extra/smalltalk/eval/authors.txt              |  1 +
 extra/smalltalk/eval/eval-tests.factor        |  5 ++
 extra/smalltalk/eval/eval.factor              |  8 +++
 extra/smalltalk/library/library.factor        | 13 ++--
 extra/smalltalk/listener/listener.factor      | 14 ++--
 extra/smalltalk/parser/parser-tests.factor    | 68 +++++++++++++++++--
 extra/smalltalk/parser/parser.factor          | 67 ++++++++++--------
 extra/smalltalk/parser/test.st                |  4 +-
 11 files changed, 194 insertions(+), 53 deletions(-)
 create mode 100644 extra/smalltalk/eval/authors.txt
 create mode 100644 extra/smalltalk/eval/eval-tests.factor
 create mode 100644 extra/smalltalk/eval/eval.factor

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index f426789316..69bfc3dbf6 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: strings arrays memoize kernel ;
+USING: strings arrays memoize kernel sequences accessors ;
 IN: smalltalk.ast
 
 SINGLETONS: nil self super ;
@@ -8,6 +8,8 @@ SINGLETONS: nil self super ;
 TUPLE: ast-comment { string string } ;
 TUPLE: ast-block { arguments array } { body array } ;
 TUPLE: ast-message-send receiver { selector string } { arguments array } ;
+TUPLE: ast-message { selector string } { arguments array } ;
+TUPLE: ast-cascade receiver { messages array } ;
 TUPLE: ast-name { name string } ;
 TUPLE: ast-return value ;
 TUPLE: ast-assignment { name ast-name } value ;
@@ -15,6 +17,13 @@ TUPLE: ast-local-variables { names array } ;
 TUPLE: ast-method { name string } { body ast-block } ;
 TUPLE: ast-class { name string } { superclass string } { ivars array } { methods array } ;
 TUPLE: ast-foreign { class string } { name string } ;
+TUPLE: ast-sequence { statements array } ;
+
+: <ast-cascade> ( receiver messages -- ast )
+    dup length 1 =
+    [ first [ selector>> ] [ arguments>> ] bi ast-message-send boa ]
+    [ ast-cascade boa ]
+    if ;
 
 TUPLE: symbol { name string } ;
 MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 9c3638ba6c..4a2417e91d 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -3,7 +3,7 @@
 USING: accessors arrays assocs combinators.short-circuit
 continuations fry kernel namespaces quotations sequences sets
 generalizations slots locals.types generalizations splitting math
-locals.rewrite.closures generic words smalltalk.ast
+locals.rewrite.closures generic words combinators smalltalk.ast
 smalltalk.compiler.lexenv smalltalk.selectors
 smalltalk.classes ;
 IN: smalltalk.compiler
@@ -22,9 +22,21 @@ M: ast-message-send need-return-continuation?
         [ arguments>> need-return-continuation? ]
     } 1&& ;
 
+M: ast-cascade need-return-continuation?
+    {
+        [ receiver>> need-return-continuation? ]
+        [ messages>> need-return-continuation? ]
+    } 1&& ;
+
+M: ast-message need-return-continuation?
+    arguments>> need-return-continuation? ;
+
 M: ast-assignment need-return-continuation?
     value>> need-return-continuation? ;
 
+M: ast-sequence need-return-continuation?
+    statements>> need-return-continuation? ;
+
 M: array need-return-continuation? [ need-return-continuation? ] any? ;
 
 M: object need-return-continuation? drop f ;
@@ -37,14 +49,25 @@ M: ast-block assigned-locals
     [ body>> assigned-locals ] [ arguments>> ] bi diff ;
 
 M: ast-message-send assigned-locals
-    [ arguments>> assigned-locals ]
     [ receiver>> assigned-locals ]
+    [ arguments>> assigned-locals ]
     bi append ;
 
+M: ast-cascade assigned-locals
+    [ arguments>> assigned-locals ]
+    [ messages>> assigned-locals ]
+    bi append ;
+
+M: ast-message assigned-locals
+    arguments>> assigned-locals ;
+
 M: ast-assignment assigned-locals
     [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
     [ value>> assigned-locals ] bi append ;
 
+M: ast-sequence assigned-locals
+    statements>> assigned-locals ;
+
 M: array assigned-locals
     [ assigned-locals ] map concat ;
 
@@ -60,16 +83,37 @@ ERROR: unbound-local name ;
 
 M: ast-name compile-ast name>> swap lookup-reader ;
 
+: compile-arguments ( lexenv ast -- quot )
+    arguments>> [ compile-ast ] with map [ ] join ;
+
 M: ast-message-send compile-ast
-    [ arguments>> [ compile-ast ] with map [ ] join ]
+    [ compile-arguments ]
     [ receiver>> compile-ast ]
     [ nip selector>> selector>generic ]
     2tri [ append ] dip suffix ;
 
+M: ast-cascade compile-ast
+    [ receiver>> compile-ast ]
+    [
+        messages>> [
+            [ compile-arguments \ dip ]
+            [ selector>> selector>generic ] bi
+            [ ] 3sequence
+        ] with map
+        unclip-last [ [ [ drop ] append ] map ] dip suffix
+        cleave>quot
+    ] 2bi append ;
+
 M: ast-return compile-ast
     value>> compile-ast
     [ return-continuation get continue-with ] append ;
 
+: compile-sequence ( lexenv asts -- quot )
+    [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+
+M: ast-sequence compile-ast
+    statements>> compile-sequence ;
+
 GENERIC: contains-blocks? ( obj -- ? )
 
 M: ast-block contains-blocks? drop t ;
@@ -110,7 +154,7 @@ M: ast-assignment compile-ast
         [ nip local-readers>> values ]
         [ lexenv-union ] 2bi
     ] [ body>> ] bi
-    [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+    compile-sequence ;
 
 M: ast-block compile-ast
     compile-block <lambda> '[ _ ] ;
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index b204b057b6..6b6d283761 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs kernel accessors quotations slots words
 sequences namespaces combinators combinators.short-circuit
-smalltalk.classes ;
+summary smalltalk.classes ;
 IN: smalltalk.compiler.lexenv
 
 ! local-readers: assoc string => word
@@ -39,6 +39,8 @@ CONSTANT: empty-lexenv T{ lexenv }
 
 ERROR: bad-identifier name ;
 
+M: bad-identifier summary drop "Unknown identifier" ;
+
 : lookup-reader ( name lexenv -- reader-quot )
     {
         [ local-reader ]
diff --git a/extra/smalltalk/eval/authors.txt b/extra/smalltalk/eval/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/eval/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
new file mode 100644
index 0000000000..33f28a2bd8
--- /dev/null
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -0,0 +1,5 @@
+IN: smalltalk.eval.tests
+USING: smalltalk.eval tools.test ;
+
+[ 3 ] [ "1+2" eval-smalltalk ] unit-test
+[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor
new file mode 100644
index 0000000000..60f0d9cce2
--- /dev/null
+++ b/extra/smalltalk/eval/eval.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: compiler.units smalltalk.parser smalltalk.compiler ;
+IN: smalltalk.eval
+
+: eval-smalltalk ( string -- result )
+    [ parse-smalltalk compile-smalltalk ] with-compilation-unit
+    call( -- result ) ;
\ No newline at end of file
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
index 1b24db71e8..1a8cb8d177 100644
--- a/extra/smalltalk/library/library.factor
+++ b/extra/smalltalk/library/library.factor
@@ -1,17 +1,15 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel present io math sequences assocs math.ranges
-locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
+USING: kernel present io math sequences assocs math.ranges fry
+tools.time locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
 IN: smalltalk.library
 
-! Some unary selectors
 SELECTOR: print
 SELECTOR: asString
 
 M: object selector-print dup present print ;
 M: object selector-asString present ;
 
-! Some binary selectors
 SELECTOR: +
 SELECTOR: -
 SELECTOR: *
@@ -32,7 +30,6 @@ M: object selector-<= swap <= ;
 M: object selector->= swap >= ;
 M: object selector-=  swap =  ;
 
-! Some keyword selectors
 SELECTOR: ifTrue:
 SELECTOR: ifFalse:
 SELECTOR: ifTrue:ifFalse:
@@ -76,4 +73,8 @@ M: object selector-value:value:value:value: call( input input input input -- res
 
 SELECTOR: new
 
-M: object selector-new new ;
\ No newline at end of file
+M: object selector-new new ;
+
+SELECTOR: time
+
+M: object selector-time '[ _ call( -- result ) ] time ;
\ No newline at end of file
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
index bef4adc196..e052f0c629 100644
--- a/extra/smalltalk/listener/listener.factor
+++ b/extra/smalltalk/listener/listener.factor
@@ -2,17 +2,17 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel prettyprint io io.styles colors.constants compiler.units
 fry debugger sequences locals.rewrite.closures smalltalk.ast
-smalltalk.parser smalltalk.compiler smalltalk.printer ;
+smalltalk.eval smalltalk.printer ;
 IN: smalltalk.listener
 
-: eval-smalltalk ( string -- )
-    [
-        parse-smalltalk compile-smalltalk
-    ] with-compilation-unit call( -- result )
-    dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if ;
+: eval-interactively ( string -- )
+    '[
+        _ eval-smalltalk
+        dup nil? [ drop ] [ "Result: " write smalltalk>string print ] if
+    ] try ;
 
 : smalltalk-listener ( -- )
     "Smalltalk>" { { background COLOR: light-blue } } format bl flush readln
-    [ '[ _ eval-smalltalk ] try smalltalk-listener ] when* ;
+    [ eval-interactively smalltalk-listener ] when* ;
 
 MAIN: smalltalk-listener
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index aa440f581e..1ed6108376 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -164,6 +164,41 @@ test         = <foreign parse-smalltalk Expression>
 ]
 [ "((1 < 10) ifTrue: [ 'HI' ] ifFalse: [ 'BYE' ]) print" test-Expression ] unit-test
 
+[
+    T{ ast-cascade
+       { receiver 12 }
+       { messages
+         {
+           T{ ast-message f "sqrt" }
+           T{ ast-message f "+" { 2 } }
+         }
+       }
+    }
+]
+[ "12 sqrt; + 2" test-Expression ] unit-test
+
+[
+    T{ ast-cascade
+       { receiver T{ ast-message-send f 12 "sqrt" } }
+       { messages
+         {
+           T{ ast-message f "+" { 1 } }
+           T{ ast-message f "+" { 2 } }
+         }
+       }
+    }
+]
+[ "12 sqrt + 1; + 2" test-Expression ] unit-test
+
+[
+    T{ ast-message-send f
+        T{ ast-message-send f 1 "+" { 2 } }
+        "*"
+        { 3 }
+    }
+]
+[ "1+2*3" test-Expression ] unit-test
+
 [
     T{ ast-message-send
        { receiver
@@ -214,15 +249,38 @@ test         = <foreign parse-smalltalk KeywordMessageSend>
 ]
 [ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
 
-[ { 1 2 } ] [ "1. 2" parse-smalltalk ] unit-test
+[ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
 
 [
-    T{ ast-class
-       { name "Test" }
-       { superclass "Object" }
-       { ivars { "a" } }
+    T{ ast-sequence f
+        {
+            T{ ast-class
+               { name "Test" }
+               { superclass "Object" }
+               { ivars { "a" } }
+            }
+        }
     }
 ]
 [ "class Test [|a|]" parse-smalltalk ] unit-test
 
+[
+    T{ ast-sequence f
+        {
+            T{ ast-class
+               { name "Test1" }
+               { superclass "Object" }
+               { ivars { "a" } }
+            }
+
+            T{ ast-class
+               { name "Test2" }
+               { superclass "Test1" }
+               { ivars { "b" } }
+            }
+        }
+    }
+]
+[ "class Test1 [|a|]. class Test2 extends Test1 [|b|]" parse-smalltalk ] unit-test
+
 [ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index e153e1552d..d6194a9637 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -4,6 +4,8 @@ USING: peg peg.ebnf smalltalk.ast sequences sequences.deep strings
 math.parser kernel arrays byte-arrays math assocs accessors ;
 IN: smalltalk.parser
 
+! :mode=text:noTabs=true:
+
 ! Based on http://chronos-st.blogspot.com/2007/12/smalltalk-in-one-page.html
 
 ERROR: bad-number str ;
@@ -120,43 +122,52 @@ Operand =       Literal
                 | Reference
                 | NestedExpression
 
-UnaryMessage = UnaryMessageSelector
+UnaryMessage = OptionalWhiteSpace
+               UnaryMessageSelector:s !(":")
+               => [[ s { } ast-message boa ]]
 UnaryMessageOperand = UnaryMessageSend | Operand
 UnaryMessageSend = UnaryMessageOperand:receiver
-                   OptionalWhiteSpace UnaryMessageSelector:selector !(":")
-                   => [[ receiver selector { } ast-message-send boa ]]
+                   UnaryMessage:h
+                   (OptionalWhiteSpace ";" UnaryMessage:m => [[ m ]])*:t
+                   => [[ receiver t h prefix >array <ast-cascade> ]]
 
-BinaryMessage = BinaryMessageSelector OptionalWhiteSpace BinaryMessageOperand
+BinaryMessage = OptionalWhiteSpace
+                BinaryMessageSelector:selector
+                OptionalWhiteSpace
+                BinaryMessageOperand:rhs
+                => [[ selector { rhs } ast-message boa ]]
+                                   
 BinaryMessageOperand = BinaryMessageSend | UnaryMessageSend | Operand
-BinaryMessageSend-1 = BinaryMessageOperand:lhs
-                    OptionalWhiteSpace
-                    BinaryMessageSelector:selector
-                    OptionalWhiteSpace
-                    UnaryMessageOperand:rhs
-                    => [[ lhs selector { rhs } ast-message-send boa ]]
-BinaryMessageSend = (BinaryMessageSend:lhs
-                    OptionalWhiteSpace
-                    BinaryMessageSelector:selector
-                    OptionalWhiteSpace
-                    UnaryMessageOperand:rhs
-                    => [[ lhs selector { rhs } ast-message-send boa ]])
-                    | BinaryMessageSend-1
+BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+                    BinaryMessage:h
+                   (OptionalWhiteSpace ";" BinaryMessage:m => [[ m ]])*:t
+                   => [[ lhs t h prefix >array <ast-cascade> ]]
 
 KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
+KeywordMessage = OptionalWhiteSpace
+                 KeywordMessageSegment:h
+                 (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
+                 => [[ t h prefix unzip [ concat ] dip ast-message boa ]]
 KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):receiver
                      OptionalWhiteSpace
-                     KeywordMessageSegment:h
-                     (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
-                     => [[ receiver t h prefix unzip [ concat ] dip ast-message-send boa ]]
+                     KeywordMessage:m
+                     => [[ receiver m 1array <ast-cascade> ]]
+
+Message = BinaryMessage | UnaryMessage | KeywordMessage
+
+MessageSend = (MessageSend | Operand):lhs
+              Message:h
+              (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+              => [[ lhs t h prefix >array <ast-cascade> ]]
 
 Expression = OptionalWhiteSpace
-             (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
+             (MessageSend | Operand):e
              => [[ e ]]
 
 AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
                       OptionalWhiteSpace ":=" OptionalWhiteSpace => [[ i ast-name boa ]]
 AssignmentStatement = AssignmentOperation:a Statement:s => [[ a s ast-assignment boa ]]
-Statement = AssignmentStatement | Expression
+Statement = ClassDeclaration | ForeignClassDeclaration | AssignmentStatement | Expression
 
 MethodReturnOperator = OptionalWhiteSpace "^"
 FinalStatement = (MethodReturnOperator Statement:s => [[ s ast-return boa ]])
@@ -168,10 +179,12 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
                  => [[ t h prefix ]]
                 )?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
 
-ExecutableCode = (LocalVariableDeclarationList)?
-                 ((Statement:s OptionalWhiteSpace "." => [[ s ]])*
-                 FinalStatement:f (".")? => [[ f ]])?
-                 => [[ sift >array ]]
+ExecutableCode = (LocalVariableDeclarationList)?:locals
+                 ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
+                 FinalStatement:t (".")? => [[ h t suffix ]])?:body
+                 => [[ body locals [ suffix ] when* >array ]]
+
+TopLevelForm = ExecutableCode => [[ ast-sequence boa ]]
 
 UnaryMethodHeader = UnaryMessageSelector:selector
                   => [[ { selector { } } ]]
@@ -206,6 +219,6 @@ ForeignClassDeclaration = OptionalWhiteSpace "foreign"
                           => [[ class name ast-foreign boa ]]
 End = !(.)
 
-Program = (ClassDeclaration|ForeignClassDeclaration|ExecutableCode) => [[ nil or ]] End
+Program = TopLevelForm End
 
 ;EBNF
\ No newline at end of file
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
index 7771ee2b9c..493d270f9b 100644
--- a/extra/smalltalk/parser/test.st
+++ b/extra/smalltalk/parser/test.st
@@ -32,7 +32,7 @@ class TreeNode extends Object [
             nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
     ]
 
-    binarytrees [
+    method binarytrees [
         self binarytrees: self arg to: self stdout.
         ^''
     ]
@@ -63,4 +63,4 @@ class TreeNode extends Object [
     ]
 ]
 
-Tests binarytrees.
+Tests binarytrees

From 95d9b3a417ef8e18fd3615dfb34880f680cb4213 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Tue, 31 Mar 2009 21:48:43 -0500
Subject: [PATCH 035/135] Adding functionality to unicode breaks API for future
 UI changes

---
 basis/unicode/breaks/breaks-tests.factor |  3 +++
 basis/unicode/breaks/breaks.factor       | 14 ++++++++++----
 2 files changed, 13 insertions(+), 4 deletions(-)

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 12314505d9..1b1d9434f8 100644
--- a/basis/unicode/breaks/breaks.factor
+++ b/basis/unicode/breaks/breaks.factor
@@ -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

From 3211270d5bc0c5900db88470b59ada4e9daee076 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@Macintosh-122.local>
Date: Tue, 31 Mar 2009 21:49:14 -0500
Subject: [PATCH 036/135] left and right arrow keys move between graphemes in
 UI

---
 .../documents/elements/elements-tests.factor  | 84 ++++++++++---------
 basis/documents/elements/elements.factor      | 32 +++----
 2 files changed, 60 insertions(+), 56 deletions(-)

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 9a8b82acac..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
-accessors unicode.categories combinators.short-circuit ;
+accessors unicode.categories unicode.breaks combinators.short-circuit ;
 IN: documents.elements
 
 GENERIC: prev-elt ( loc document elt -- newloc )
@@ -27,20 +27,25 @@ SINGLETON: char-elt
         [ call ]
     } cond ; inline
 
-: next ( loc document quot: ( loc document -- 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 ;
+    drop [ [ last-grapheme-from ] modify-col ] prev ;
 
 M: char-elt next-elt
-    drop [ drop 1 +col ] next ;
+    drop [ [ first-grapheme-from ] modify-col ] next ;
 
 SINGLETON: one-char-elt
 
@@ -50,22 +55,17 @@ 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
-
 : 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 )
-    { [ break-detector find-from drop ] [ drop length ] } 2|| ;
+: next-word ( col str ? -- col )
+    [ break-detector find-from drop ] [ drop length ] 2bi or ;
 
 PRIVATE>
 
@@ -73,22 +73,22 @@ 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 blank-at? (prev-word) ] (word-elt) ]
+    [ [ [ 1- ] dip blank-at? prev-word ] modify-col ]
     prev ;
 
 M: word-elt next-elt
     drop
-    [ [ blank-at? (next-word) ] (word-elt) ]
+    [ [ blank-at? next-word ] modify-col ]
     next ;
 
 SINGLETON: one-line-elt

From 408d592c3e267743f6ded0b37c5eb72ef92c2ae6 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Wed, 1 Apr 2009 05:03:28 +0200
Subject: [PATCH 037/135] FUEL: Font lock and no indentation for EBNF: ...
 ;EBNF forms.

---
 extra/peg/pl0/pl0.factor    | 22 +++++++++++-----------
 misc/fuel/fuel-font-lock.el |  7 ++++++-
 misc/fuel/fuel-syntax.el    |  4 +++-
 3 files changed, 20 insertions(+), 13 deletions(-)

diff --git a/extra/peg/pl0/pl0.factor b/extra/peg/pl0/pl0.factor
index eff923dc01..179e03f1cf 100644
--- a/extra/peg/pl0/pl0.factor
+++ b/extra/peg/pl0/pl0.factor
@@ -6,20 +6,20 @@ IN: peg.pl0
 
 #! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
 
-EBNF: pl0 
+EBNF: pl0
 
-block       =  { "CONST" ident "=" number { "," ident "=" number }* ";" }? 
-               { "VAR" ident { "," ident }* ";" }? 
-               { "PROCEDURE" ident ";" { block ";" }? }* statement 
-statement   =  {  ident ":=" expression 
-                | "CALL" ident 
-                | "BEGIN" statement { ";" statement }* "END" 
-                | "IF" condition "THEN" statement 
-                | "WHILE" condition "DO" statement }?  
+block       =  { "CONST" ident "=" number { "," ident "=" number }* ";" }?
+               { "VAR" ident { "," ident }* ";" }?
+               { "PROCEDURE" ident ";" { block ";" }? }* statement
+statement   =  {  ident ":=" expression
+                | "CALL" ident
+                | "BEGIN" statement { ";" statement }* "END"
+                | "IF" condition "THEN" statement
+                | "WHILE" condition "DO" statement }?
 condition   =  { "ODD" expression }
              | { expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression }
-expression  = {"+" | "-"}? term { {"+" | "-"} term }* 
-term        = factor { {"*" | "/"} factor }* 
+expression  = {"+" | "-"}? term { {"+" | "-"} term }*
+term        = factor { {"*" | "/"} factor }*
 factor      = ident | number | "(" expression ")"
 ident       = (([a-zA-Z])+)   => [[ >string ]]
 digit       = ([0-9])         => [[ digit> ]]
diff --git a/misc/fuel/fuel-font-lock.el b/misc/fuel/fuel-font-lock.el
index 5961d9e86f..bc1bb900ce 100644
--- a/misc/fuel/fuel-font-lock.el
+++ b/misc/fuel/fuel-font-lock.el
@@ -58,6 +58,7 @@
   (number constant  "integers and floats")
   (ratio constant  "ratios")
   (declaration keyword "declaration words")
+  (ebnf-form constant "EBNF: ... ;EBNF form")
   (parsing-word keyword  "parsing words")
   (setter-word function-name "setter words (>>foo)")
   (getter-word function-name "getter words (foo>>)")
@@ -75,7 +76,9 @@
 (defun fuel-font-lock--syntactic-face (state)
   (if (nth 3 state) 'factor-font-lock-string
     (let ((c (char-after (nth 8 state))))
-      (cond ((or (char-equal c ?\ ) (char-equal c ?\n))
+      (cond ((or (char-equal c ?\ )
+                 (char-equal c ?\n)
+                 (char-equal c ?E))
              (save-excursion
                (goto-char (nth 8 state))
                (beginning-of-line)
@@ -85,6 +88,8 @@
                       'factor-font-lock-symbol)
                      ((looking-at-p "C-ENUM:\\( \\|\n\\)")
                       'factor-font-lock-constant)
+                     ((looking-at-p "E")
+                      'factor-font-lock-ebnf-form)
                      (t 'default))))
             ((or (char-equal c ?U) (char-equal c ?C))
              'factor-font-lock-parsing-word)
diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el
index 4cff58ae3b..7aba6282d6 100644
--- a/misc/fuel/fuel-syntax.el
+++ b/misc/fuel/fuel-syntax.el
@@ -48,7 +48,7 @@
     "B" "BIN:"
     "C:" "C-ENUM:" "C-STRUCT:" "C-UNION:" "CHAR:" "CONSTANT:" "call-next-method"
     "DEFER:"
-    "ERROR:" "EXCLUDE:"
+    "EBNF:" ";EBNF" "ERROR:" "EXCLUDE:"
     "f" "FORGET:" "FROM:" "FUNCTION:"
     "GENERIC#" "GENERIC:"
     "HELP:" "HEX:" "HOOK:"
@@ -254,6 +254,8 @@
     ("\\_<<\\(\"\\)\\_>" (1 "<b"))
     ("\\_<\\(\"\\)>\\_>" (1 ">b"))
     ;; Multiline constructs
+    ("\\_<\\(E\\)BNF:\\( \\|\n\\)" (1 "<b"))
+    ("\\_<;EBN\\(F\\)\\_>" (1 ">b"))
     ("\\_<\\(U\\)SING: \\(;\\)" (1 "<b") (2 ">b"))
     ("\\_<USING:\\( \\)" (1 "<b"))
     ("\\_<\\(C\\)-ENUM: \\(;\\)" (1 "<b") (2 ">b"))

From d0921b1d2d9b7b965c7a47e09e11aed79de1ddd6 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 22:30:13 -0500
Subject: [PATCH 038/135] Smalltalk parser work in progress

---
 extra/smalltalk/eval/eval-tests.factor     |  6 ++-
 extra/smalltalk/parser/parser-tests.factor | 10 +++--
 extra/smalltalk/parser/parser.factor       | 46 ++++++++++++----------
 extra/smalltalk/parser/test.st             | 12 +++---
 4 files changed, 41 insertions(+), 33 deletions(-)

diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
index 33f28a2bd8..1dbbd054a8 100644
--- a/extra/smalltalk/eval/eval-tests.factor
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -1,5 +1,7 @@
 IN: smalltalk.eval.tests
-USING: smalltalk.eval tools.test ;
+USING: smalltalk.eval tools.test io.streams.string ;
 
 [ 3 ] [ "1+2" eval-smalltalk ] unit-test
-[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
\ No newline at end of file
+[ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
+[ 7 ] [ "1+2+3;+4" eval-smalltalk ] unit-test
+[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index 1ed6108376..9ba1c38ede 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -228,12 +228,12 @@ test         = <foreign parse-smalltalk LocalVariableDeclarationList>
 [ T{ ast-local-variables f { "i" "j" } } ] [ " |  i j   |" test-LocalVariableDeclarationList ] unit-test
 
 
-EBNF: test-KeywordMessageSend
-test         = <foreign parse-smalltalk KeywordMessageSend>
+EBNF: test-MessageSend
+test         = <foreign parse-smalltalk MessageSend>
 ;EBNF
 
 [ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
-[ "x foo:1 bar:2" test-KeywordMessageSend ] unit-test
+[ "x foo:1 bar:2" test-MessageSend ] unit-test
 
 [
     T{ ast-message-send
@@ -247,7 +247,7 @@ test         = <foreign parse-smalltalk KeywordMessageSend>
         { 10 100 }
     }
 ]
-[ "3 factorial + 4 factorial between: 10 and: 100" test-KeywordMessageSend ] unit-test
+[ "3 factorial + 4 factorial between: 10 and: 100" test-MessageSend ] unit-test
 
 [ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
 
@@ -283,4 +283,6 @@ test         = <foreign parse-smalltalk KeywordMessageSend>
 ]
 [ "class Test1 [|a|]. class Test2 extends Test1 [|b|]" parse-smalltalk ] unit-test
 
+[ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
+
 [ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index d6194a9637..c80171e025 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -104,7 +104,7 @@ BlockLiteral = "["
                  "|"
                  => [[ args ]]
                 )?:args
-                ExecutableCode:body OptionalWhiteSpace
+                ExecutableCode:body
                 "]" => [[ args >array body ast-block boa ]]
 
 Literal = (ConstantReference
@@ -125,41 +125,38 @@ Operand =       Literal
 UnaryMessage = OptionalWhiteSpace
                UnaryMessageSelector:s !(":")
                => [[ s { } ast-message boa ]]
-UnaryMessageOperand = UnaryMessageSend | Operand
-UnaryMessageSend = UnaryMessageOperand:receiver
-                   UnaryMessage:h
-                   (OptionalWhiteSpace ";" UnaryMessage:m => [[ m ]])*:t
-                   => [[ receiver t h prefix >array <ast-cascade> ]]
 
 BinaryMessage = OptionalWhiteSpace
                 BinaryMessageSelector:selector
                 OptionalWhiteSpace
-                BinaryMessageOperand:rhs
+                (MessageSend | Operand):rhs
                 => [[ selector { rhs } ast-message boa ]]
                                    
-BinaryMessageOperand = BinaryMessageSend | UnaryMessageSend | Operand
-BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
-                    BinaryMessage:h
-                   (OptionalWhiteSpace ";" BinaryMessage:m => [[ m ]])*:t
-                   => [[ lhs t h prefix >array <ast-cascade> ]]
-
-KeywordMessageSegment = Keyword:k OptionalWhiteSpace BinaryMessageOperand:arg => [[ { k arg } ]]
+KeywordMessageSegment = Keyword:k OptionalWhiteSpace (BinaryMessageSend | UnaryMessageSend | Operand):arg => [[ { k arg } ]]
 KeywordMessage = OptionalWhiteSpace
                  KeywordMessageSegment:h
                  (OptionalWhiteSpace KeywordMessageSegment:s => [[ s ]])*:t
                  => [[ t h prefix unzip [ concat ] dip ast-message boa ]]
-KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):receiver
-                     OptionalWhiteSpace
-                     KeywordMessage:m
-                     => [[ receiver m 1array <ast-cascade> ]]
 
 Message = BinaryMessage | UnaryMessage | KeywordMessage
 
-MessageSend = (MessageSend | Operand):lhs
+UnaryMessageSend = (MessageSend | Operand):lhs
               Message:h
               (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
               => [[ lhs t h prefix >array <ast-cascade> ]]
 
+BinaryMessageSend = (MessageSend | Operand):lhs
+              Message:h
+              (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+              => [[ lhs t h prefix >array <ast-cascade> ]]
+
+KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+              KeywordMessage:h
+              (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
+              => [[ lhs t h prefix >array <ast-cascade> ]]
+
+MessageSend = BinaryMessageSend | UnaryMessageSend | KeywordMessageSend
+
 Expression = OptionalWhiteSpace
              (MessageSend | Operand):e
              => [[ e ]]
@@ -182,6 +179,7 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
 ExecutableCode = (LocalVariableDeclarationList)?:locals
                  ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
                  FinalStatement:t (".")? => [[ h t suffix ]])?:body
+                 OptionalWhiteSpace
                  => [[ body locals [ suffix ] when* >array ]]
 
 TopLevelForm = ExecutableCode => [[ ast-sequence boa ]]
@@ -201,7 +199,7 @@ MethodHeader =   KeywordMethodHeader
 MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:header
         OptionalWhiteSpace "["
         ExecutableCode:code
-        OptionalWhiteSpace "]"
+        "]"
         => [[ header first2 code ast-block boa ast-method boa ]]
 
 ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
@@ -209,7 +207,13 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         ("extends" OptionalWhiteSpace Identifier:superclass OptionalWhiteSpace => [[ superclass ]])?:superclass
         OptionalWhiteSpace "["
         (OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
-        (MethodDeclaration:h (OptionalWhiteSpace MethodDeclaration:m => [[ m ]])*:t => [[ t h prefix ]])?:methods
+        (MethodDeclaration:h
+         (OptionalWhiteSpace
+          "."
+          OptionalWhiteSpace
+          MethodDeclaration:m => [[ m ]])*:t (".")?
+          => [[ t h prefix ]]
+         )?:methods
         OptionalWhiteSpace "]"
         => [[ name superclass "Object" or ivars >array methods >array ast-class boa ]]
 
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
index 493d270f9b..8a1ae12145 100644
--- a/extra/smalltalk/parser/test.st
+++ b/extra/smalltalk/parser/test.st
@@ -30,23 +30,23 @@ class TreeNode extends Object [
         output
             nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
             nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
-    ]
+    ].
 
     method binarytrees [
         self binarytrees: self arg to: self stdout.
         ^''
-    ]
+    ].
 
     method left: leftChild right: rightChild item: anItem [
         left := leftChild.
         right := rightChild.
         item := anItem
-    ]
+    ].
 
     method itemCheck [
         ^left isNil
             ifTrue: [item] ifFalse: [item + (left itemCheck - right itemCheck)]
-    ]
+    ].
 
     method bottomUpTree: anItem depth: anInteger [
         ^(anInteger > 0)
@@ -56,11 +56,11 @@ class TreeNode extends Object [
                     right: (self bottomUpTree: 2*anItem depth: anInteger - 1)
                     item: anItem
             ] ifFalse: [self left: nil right: nil item: anItem]
-    ]
+    ].
 
     method left: leftChild right: rightChild item: anItem [
         ^(super new) left: leftChild right: rightChild item: anItem
     ]
-]
+].
 
 Tests binarytrees

From 19d8a6a552d30964f8d5a684fc9f1b99f96641bb Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Tue, 31 Mar 2009 23:04:59 -0500
Subject: [PATCH 039/135] remove some dead code, make spider use count and
 max-count again

---
 extra/spider/spider.factor | 7 ++-----
 1 file changed, 2 insertions(+), 5 deletions(-)

diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index 0287d50692..d08276a9bb 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -8,7 +8,7 @@ continuations calendar prettyprint dlists deques locals ;
 IN: spider
 
 TUPLE: spider base count max-count sleep max-depth initial-links
-filters spidered todo nonmatching filtered quiet ;
+filters spidered todo nonmatching quiet ;
 
 TUPLE: spider-result url depth headers fetch-time parsed-html
 links processing-time timestamp ;
@@ -40,7 +40,6 @@ TUPLE: unique-deque assoc deque ;
         over >>base
         swap 0 <unique-deque> [ push-url ] keep >>todo
         <unique-deque> >>nonmatching
-        <unique-deque> >>filtered
         0 >>max-depth
         0 >>count
         1/0. >>max-count
@@ -60,9 +59,6 @@ TUPLE: unique-deque assoc deque ;
 : add-nonmatching ( links level spider -- )
     nonmatching>> push-links ;
 
-: add-filtered ( links level spider -- )
-    filtered>> push-links ;
-
 : filter-base-links ( spider spider-result -- base-links nonmatching-links )
     [ base>> host>> ] [ links>> prune ] bi*
     [ host>> = ] with partition ;
@@ -110,6 +106,7 @@ TUPLE: unique-deque assoc deque ;
     {
         [ todo>> deque>> deque-empty? not ]
         [ [ todo>> peek-url depth>> ] [ max-depth>> ] bi < ]
+        [ [ count>> ] [ max-count>> ] bi < ]
     } 1&& ;
 
 : setup-next-url ( spider -- spider url depth )

From 9e9116f0eacd11f8daa5c4475472310f6b641615 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-116-90.res.carleton.edu>
Date: Tue, 31 Mar 2009 23:18:52 -0500
Subject: [PATCH 040/135] Better error message for syntax error in : foo ( :
 bar

---
 core/effects/parser/parser.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

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 ;

From ab7f433aa2dc175e5ac656052092b6cee855ebd7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 23:39:11 -0500
Subject: [PATCH 041/135] Fix stack effect declarations for (>>foo) words

---
 core/slots/slots.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/core/slots/slots.factor b/core/slots/slots.factor
index 46fd325fa5..a353f50947 100755
--- a/core/slots/slots.factor
+++ b/core/slots/slots.factor
@@ -97,7 +97,7 @@ ERROR: bad-slot-value value class ;
     "writing" associate ;
 
 : define-writer-generic ( name -- )
-    writer-word (( object value -- )) define-simple-generic ;
+    writer-word (( value object -- )) define-simple-generic ;
 
 : define-writer ( class slot-spec -- )
     [ nip name>> define-writer-generic ] [

From 474e74a23208760456406ea679639b328518679c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Tue, 31 Mar 2009 23:44:38 -0500
Subject: [PATCH 042/135] Re-organize things so that bootstrap.ui doesn't load
 ui.text

---
 basis/bootstrap/ui/ui.factor             |  8 --------
 basis/ui/gadgets/worlds/worlds.factor    | 13 ++++++++-----
 basis/ui/text/core-text/core-text.factor |  5 ++---
 basis/ui/text/pango/pango.factor         |  5 ++---
 basis/ui/text/text.factor                | 22 ++++++++++++++++++----
 basis/ui/ui.factor                       |  8 +++-----
 6 files changed, 33 insertions(+), 28 deletions(-)

diff --git a/basis/bootstrap/ui/ui.factor b/basis/bootstrap/ui/ui.factor
index 4f7f82a067..271a99c223 100755
--- a/basis/bootstrap/ui/ui.factor
+++ b/basis/bootstrap/ui/ui.factor
@@ -10,12 +10,4 @@ IN: bootstrap.ui
             { [ os unix? ] [ "x11" ] }
         } cond
     ] unless* "ui.backend." prepend require
-
-    "ui-text-backend" get [
-        {
-            { [ os macosx? ] [ "core-text" ] }
-            { [ os windows? ] [ "pango" ] }
-            { [ os unix? ] [ "pango" ] }
-        } cond
-    ] unless* "ui.text." prepend require
 ] when
diff --git a/basis/ui/gadgets/worlds/worlds.factor b/basis/ui/gadgets/worlds/worlds.factor
index 163dbff514..655c9ba49d 100644
--- a/basis/ui/gadgets/worlds/worlds.factor
+++ b/basis/ui/gadgets/worlds/worlds.factor
@@ -3,8 +3,7 @@
 USING: accessors arrays assocs continuations kernel math models
 namespaces opengl sequences io combinators combinators.short-circuit
 fry math.vectors math.rectangles cache ui.gadgets ui.gestures
-ui.render ui.text ui.text.private ui.backend ui.gadgets.tracks
-ui.commands ;
+ui.render ui.backend ui.gadgets.tracks ui.commands ;
 IN: ui.gadgets.worlds
 
 TUPLE: world < track
@@ -53,7 +52,6 @@ M: world request-focus-on ( child gadget -- )
         swap >>status
         swap >>title
         swap 1 track-add
-    dup init-text-rendering
     dup request-focus ;
 
 : <world> ( gadget title status -- world )
@@ -74,15 +72,20 @@ M: world remove-gadget
     2dup layers>> memq?
     [ layers>> delq ] [ call-next-method ] if ;
 
+SYMBOL: flush-layout-cache-hook
+
+flush-layout-cache-hook [ [ ] ] initialize
+
 : (draw-world) ( world -- )
     dup handle>> [
         {
             [ init-gl ]
             [ draw-gadget ]
-            [ finish-text-rendering ]
+            [ text-handle>> [ purge-cache ] when* ]
             [ images>> [ purge-cache ] when* ]
         } cleave
-    ] with-gl-context ;
+    ] with-gl-context
+    flush-layout-cache-hook get call( -- ) ;
 
 : draw-world? ( world -- ? )
     #! We don't draw deactivated worlds, or those with 0 size.
diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor
index 785a9366cb..3704189e48 100644
--- a/basis/ui/text/core-text/core-text.factor
+++ b/basis/ui/text/core-text/core-text.factor
@@ -18,12 +18,11 @@ M: core-text-renderer string-dim
     [ cached-line dim>> ]
     if-empty ;
 
-M: core-text-renderer finish-text-rendering
-    text-handle>> purge-cache
+M: core-text-renderer flush-layout-cache
     cached-lines get purge-cache ;
 
 : rendered-line ( font string -- texture )
-    world get text-handle>>
+    world get world-text-handle
     [ cached-line [ image>> ] [ loc>> ] bi <texture> ]
     2cache ;
 
diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor
index 8b644be469..017a4b2cf2 100755
--- a/basis/ui/text/pango/pango.factor
+++ b/basis/ui/text/pango/pango.factor
@@ -14,12 +14,11 @@ M: pango-renderer string-dim
     [ " " string-dim { 0 1 } v* ]
     [ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;
 
-M: pango-renderer finish-text-rendering
-    text-handle>> purge-cache
+M: pango-renderer flush-layout-cache
     cached-layouts get purge-cache ;
 
 : rendered-layout ( font string -- texture )
-    world get text-handle>>
+    world get world-text-handle
     [ cached-layout [ image>> ] [ text-position vneg ] bi <texture> ]
     2cache ;
 
diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor
index d0766e9ee6..ebf4b9cce0 100644
--- a/basis/ui/text/text.factor
+++ b/basis/ui/text/text.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel arrays sequences math math.order opengl opengl.gl
-strings fonts colors accessors ;
+strings fonts colors accessors namespaces ui.gadgets.worlds ;
 IN: ui.text
 
 <PRIVATE
@@ -10,9 +10,13 @@ SYMBOL: font-renderer
 
 HOOK: init-text-rendering font-renderer ( world -- )
 
-HOOK: finish-text-rendering font-renderer ( world -- )
+: world-text-handle ( world -- handle )
+    dup text-handle>> [ dup init-text-rendering ] unless
+    text-handle>> ;
 
-M: object finish-text-rendering drop ;
+HOOK: flush-layout-cache font-renderer ( -- )
+
+[ flush-layout-cache ] flush-layout-cache-hook set-global
 
 HOOK: string-dim font-renderer ( font string -- dim )
 
@@ -68,4 +72,14 @@ M: array draw-text
             [ draw-string ]
             [ [ 0.0 ] 2dip string-height 0.0 glTranslated ] 2bi
         ] with each
-    ] do-matrix ;
\ No newline at end of file
+    ] do-matrix ;
+
+USING: vocabs.loader namespaces system combinators ;
+
+"ui-backend" get [
+    {
+        { [ os macosx? ] [ "core-text" ] }
+        { [ os windows? ] [ "pango" ] }
+        { [ os unix? ] [ "pango" ] }
+    } cond
+] unless* "ui.text." prepend require
\ No newline at end of file
diff --git a/basis/ui/ui.factor b/basis/ui/ui.factor
index 8ce8f57cf0..bf17e455f8 100644
--- a/basis/ui/ui.factor
+++ b/basis/ui/ui.factor
@@ -4,8 +4,7 @@ USING: arrays assocs io kernel math models namespaces make dlists
 deques sequences threads sequences words continuations init
 combinators hashtables concurrency.flags sets accessors calendar fry
 destructors ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.gadgets.tracks ui.gestures ui.backend ui.render ui.text
-ui.text.private ;
+ui.gadgets.tracks ui.gestures ui.backend ui.render ;
 IN: ui
 
 <PRIVATE
@@ -63,7 +62,7 @@ M: world graft*
 : (ungraft-world) ( world -- )
     {
         [ handle>> select-gl-context ]
-        [ text-handle>> dispose ]
+        [ text-handle>> [ dispose ] when* ]
         [ images>> [ dispose ] when* ]
         [ hand-clicked close-global ]
         [ hand-gadget close-global ]
@@ -95,8 +94,7 @@ M: world ungraft*
 : restore-world ( world -- )
     {
         [ reset-world ]
-        [ init-text-rendering ]
-        [ f >>images drop ]
+        [ f >>text-handle f >>images drop ]
         [ restore-gadget ]
     } cleave ;
 

From 087a7acfba477a5a5c9b90d8de3a2ece5aead5d3 Mon Sep 17 00:00:00 2001
From: Chris Double <chris.double@double.co.nz>
Date: Wed, 1 Apr 2009 17:55:15 +1300
Subject: [PATCH 043/135] Fix peg left recursion handling

---
 basis/peg/peg.factor | 23 ++++++++++++++---------
 1 file changed, 14 insertions(+), 9 deletions(-)

diff --git a/basis/peg/peg.factor b/basis/peg/peg.factor
index ce34beb725..dda36432e7 100644
--- a/basis/peg/peg.factor
+++ b/basis/peg/peg.factor
@@ -155,18 +155,21 @@ TUPLE: peg-head rule-id involved-set eval-set ;
   dup pos>> pos set ans>>
   ; inline
 
-:: (setup-lr) ( r l s -- )
-  s head>> l head>> eq? [
-    l head>> s (>>head)
-    l head>> [ s rule-id>> suffix ] change-involved-set drop
-    r l s next>> (setup-lr)
-  ] unless ;
+:: (setup-lr) ( l s -- )
+  s [ 
+    s left-recursion? [ s throw ] unless
+    s head>> l head>> eq? [
+      l head>> s (>>head)
+      l head>> [ s rule-id>> suffix ] change-involved-set drop
+      l s next>> (setup-lr)
+    ] unless 
+  ] when ;
 
 :: setup-lr ( r l -- )
   l head>> [
     r rule-id V{ } clone V{ } clone peg-head boa l (>>head)
   ] unless
-  r l lrstack get (setup-lr) ;
+  l lrstack get (setup-lr) ;
 
 :: lr-answer ( r p m -- ast )
   [let* |
@@ -216,8 +219,10 @@ TUPLE: peg-head rule-id involved-set eval-set ;
     lrstack get next>> lrstack set
     pos get m (>>pos)
     lr head>> [
-      ans lr (>>seed)
-      r p m lr-answer
+      m ans>> left-recursion? [
+        ans lr (>>seed)
+        r p m lr-answer
+     ] [ ans ] if 
     ] [
       ans m (>>ans)
       ans

From 9f01e819e841056d38ef9618f8a581bb8ddd1047 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:06:57 -0500
Subject: [PATCH 044/135] smalltalk: fix various things in the parser, add
 temporary variable support, clean up compiler

---
 extra/smalltalk/ast/ast.factor                |  26 ++-
 .../smalltalk/compiler/compiler-tests.factor  |   9 +-
 extra/smalltalk/compiler/compiler.factor      | 163 ++++++------------
 extra/smalltalk/eval/eval-tests.factor        |   4 +-
 extra/smalltalk/eval/eval.factor              |   8 +-
 extra/smalltalk/library/library.factor        |  25 ++-
 extra/smalltalk/listener/listener.factor      |   2 +-
 extra/smalltalk/parser/parser-tests.factor    |  35 ++--
 extra/smalltalk/parser/parser.factor          |  36 ++--
 extra/smalltalk/parser/test.st                |   7 +-
 10 files changed, 155 insertions(+), 160 deletions(-)

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index 69bfc3dbf6..e9759b2197 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -1,12 +1,12 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: strings arrays memoize kernel sequences accessors ;
+USING: strings arrays memoize kernel sequences accessors combinators ;
 IN: smalltalk.ast
 
 SINGLETONS: nil self super ;
 
 TUPLE: ast-comment { string string } ;
-TUPLE: ast-block { arguments array } { body array } ;
+TUPLE: ast-block { arguments array } { temporaries array } { body array } ;
 TUPLE: ast-message-send receiver { selector string } { arguments array } ;
 TUPLE: ast-message { selector string } { arguments array } ;
 TUPLE: ast-cascade receiver { messages array } ;
@@ -17,8 +17,28 @@ TUPLE: ast-local-variables { names array } ;
 TUPLE: ast-method { name string } { body ast-block } ;
 TUPLE: ast-class { name string } { superclass string } { ivars array } { methods array } ;
 TUPLE: ast-foreign { class string } { name string } ;
-TUPLE: ast-sequence { statements array } ;
+TUPLE: ast-sequence { temporaries array } { body array } ;
 
+! We treat a sequence of statements like a block in a few places to
+! simplify handling of top-level forms
+M: ast-sequence arguments>> drop { } ;
+
+: unclip-temporaries ( statements -- temporaries statements' )
+    {
+        { [ dup empty? ] [ { } ] }
+        { [ dup first ast-local-variables? not ] [ { } ] }
+        [ unclip names>> ]
+    } cond swap ;
+
+: <ast-block> ( arguments body -- block )
+    unclip-temporaries ast-block boa ;
+
+: <ast-sequence> ( body -- block )
+    unclip-temporaries ast-sequence boa ;
+
+! The parser parses normal message sends as cascades with one message, but
+! we represent them differently in the AST to simplify generated code in
+! the common case
 : <ast-cascade> ( receiver messages -- ast )
     dup length 1 =
     [ first [ selector>> ] [ arguments>> ] bi ast-message-send boa ]
diff --git a/extra/smalltalk/compiler/compiler-tests.factor b/extra/smalltalk/compiler/compiler-tests.factor
index c0b9507dd0..81b38f2c14 100644
--- a/extra/smalltalk/compiler/compiler-tests.factor
+++ b/extra/smalltalk/compiler/compiler-tests.factor
@@ -1,10 +1,13 @@
 USING: smalltalk.compiler tools.test prettyprint smalltalk.ast
 smalltalk.compiler.lexenv stack-checker locals.rewrite.closures
-kernel accessors compiler.units sequences ;
+kernel accessors compiler.units sequences arrays ;
 IN: smalltalk.compiler.tests
 
 : test-compilation ( ast -- quot )
-    [ compile-smalltalk [ call ] append ] with-compilation-unit ;
+    [
+        1array ast-sequence new swap >>body
+        compile-smalltalk [ call ] append
+    ] with-compilation-unit ;
 
 : test-inference ( ast -- in# out# )
     test-compilation infer [ in>> ] [ out>> ] bi ;
@@ -46,6 +49,7 @@ IN: smalltalk.compiler.tests
 
 [ 0 1 ] [
     T{ ast-block f
+       { }
        { }
        {
            T{ ast-message-send
@@ -76,6 +80,7 @@ IN: smalltalk.compiler.tests
 
 [ "a" ] [
     T{ ast-block f
+       { }
        { }
        { { T{ ast-block { body { "a" } } } } }
     } test-compilation call first call
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 4a2417e91d..e61b44ffae 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -2,77 +2,12 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays assocs combinators.short-circuit
 continuations fry kernel namespaces quotations sequences sets
-generalizations slots locals.types generalizations splitting math
-locals.rewrite.closures generic words combinators smalltalk.ast
-smalltalk.compiler.lexenv smalltalk.selectors
-smalltalk.classes ;
+generalizations slots locals.types splitting math
+locals.rewrite.closures generic words combinators locals smalltalk.ast
+smalltalk.compiler.lexenv smalltalk.compiler.assignment
+smalltalk.compiler.return smalltalk.selectors smalltalk.classes ;
 IN: smalltalk.compiler
 
-SYMBOL: return-continuation
-
-GENERIC: need-return-continuation? ( ast -- ? )
-
-M: ast-return need-return-continuation? drop t ;
-
-M: ast-block need-return-continuation? body>> need-return-continuation? ;
-
-M: ast-message-send need-return-continuation?
-    {
-        [ receiver>> need-return-continuation? ]
-        [ arguments>> need-return-continuation? ]
-    } 1&& ;
-
-M: ast-cascade need-return-continuation?
-    {
-        [ receiver>> need-return-continuation? ]
-        [ messages>> need-return-continuation? ]
-    } 1&& ;
-
-M: ast-message need-return-continuation?
-    arguments>> need-return-continuation? ;
-
-M: ast-assignment need-return-continuation?
-    value>> need-return-continuation? ;
-
-M: ast-sequence need-return-continuation?
-    statements>> need-return-continuation? ;
-
-M: array need-return-continuation? [ need-return-continuation? ] any? ;
-
-M: object need-return-continuation? drop f ;
-
-GENERIC: assigned-locals ( ast -- seq )
-
-M: ast-return assigned-locals value>> assigned-locals ;
-
-M: ast-block assigned-locals
-    [ body>> assigned-locals ] [ arguments>> ] bi diff ;
-
-M: ast-message-send assigned-locals
-    [ receiver>> assigned-locals ]
-    [ arguments>> assigned-locals ]
-    bi append ;
-
-M: ast-cascade assigned-locals
-    [ arguments>> assigned-locals ]
-    [ messages>> assigned-locals ]
-    bi append ;
-
-M: ast-message assigned-locals
-    arguments>> assigned-locals ;
-
-M: ast-assignment assigned-locals
-    [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
-    [ value>> assigned-locals ] bi append ;
-
-M: ast-sequence assigned-locals
-    statements>> assigned-locals ;
-
-M: array assigned-locals
-    [ assigned-locals ] map concat ;
-
-M: object assigned-locals drop f ;
-
 GENERIC: compile-ast ( lexenv ast -- quot )
 
 M: object compile-ast nip 1quotation ;
@@ -108,11 +43,39 @@ M: ast-return compile-ast
     value>> compile-ast
     [ return-continuation get continue-with ] append ;
 
-: compile-sequence ( lexenv asts -- quot )
-    [ drop [ nil ] ] [ [ compile-ast ] with map [ drop ] join ] if-empty ;
+: (compile-sequence) ( lexenv asts -- quot )
+    [ drop [ nil ] ] [
+        [ compile-ast ] with map [ drop ] join
+    ] if-empty ;
+
+: block-lexenv ( block -- lexenv )
+    [ [ arguments>> ] [ temporaries>> ] bi append ]
+    [ body>> [ assigned-locals ] map concat unique ] bi
+    '[
+        dup dup _ key?
+        [ <local-reader> ]
+        [ <local> ]
+        if
+    ] H{ } map>assoc
+    dup
+    [ nip local-reader? ] assoc-filter
+    [ <local-writer> ] assoc-map
+    <lexenv> swap >>local-writers swap >>local-readers ;
+
+: lookup-block-vars ( vars lexenv -- seq )
+    local-readers>> '[ _ at ] map ;
+
+: make-temporaries ( block lexenv -- quot )
+    [ temporaries>> ] dip lookup-block-vars
+    [ <def> [ f ] swap suffix ] map [ ] join ;
+
+:: compile-sequence ( lexenv block -- vars quot )
+    lexenv block block-lexenv lexenv-union :> lexenv
+    block arguments>> lexenv lookup-block-vars
+    lexenv block body>> (compile-sequence) block lexenv make-temporaries prepend ;
 
 M: ast-sequence compile-ast
-    statements>> compile-sequence ;
+    compile-sequence nip ;
 
 GENERIC: contains-blocks? ( obj -- ? )
 
@@ -135,48 +98,12 @@ M: ast-name compile-assignment name>> swap lookup-writer ;
 M: ast-assignment compile-ast
     [ value>> compile-ast [ dup ] ] [ name>> compile-assignment ] 2bi 3append ;
 
-: block-lexenv ( block -- lexenv )
-    [ arguments>> ] [ body>> [ assigned-locals ] map concat unique ] bi
-    '[
-        dup dup _ key?
-        [ <local-reader> ]
-        [ <local> ]
-        if
-    ] { } map>assoc
-    dup
-    [ nip local-reader? ] assoc-filter
-    [ <local-writer> ] assoc-map
-    <lexenv> swap >>local-writers swap >>local-readers ;
-
-: compile-block ( lexenv block -- vars body )
-    [
-        block-lexenv
-        [ nip local-readers>> values ]
-        [ lexenv-union ] 2bi
-    ] [ body>> ] bi
-    compile-sequence ;
-
 M: ast-block compile-ast
-    compile-block <lambda> '[ _ ] ;
+    compile-sequence <lambda> '[ _ ] ;
 
-: make-return ( quot n block -- quot )
-    need-return-continuation? [
-        '[
-            [
-                _ _ ncurry
-                [ return-continuation set ] prepose callcc1
-            ] with-scope
-        ]
-    ] [ drop ] if
-    rewrite-closures first ;
-
-GENERIC: compile-smalltalk ( ast -- quot )
-
-M: object compile-smalltalk ( statement -- quot )
-    [ [ empty-lexenv ] dip compile-ast 0 ] keep make-return ;
-
-: (compile-method-body) ( lexenv block -- lambda )
-    [ drop self>> ] [ compile-block ] 2bi [ swap suffix ] dip <lambda> ;
+:: (compile-method-body) ( lexenv block -- lambda )
+    lexenv block compile-sequence
+    [ lexenv self>> suffix ] dip <lambda> ;
 
 : compile-method-body ( lexenv block -- quot )
     [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep
@@ -190,7 +117,8 @@ M: object compile-smalltalk ( statement -- quot )
 : <class-lexenv> ( class -- lexenv )
     <lexenv> swap >>class "self" <local-reader> >>self ;
 
-M: ast-class compile-smalltalk ( ast-class -- quot )
+M: ast-class compile-ast
+    nip
     [
         [ name>> ] [ superclass>> ] [ ivars>> ] tri
         define-class <class-lexenv> 
@@ -201,7 +129,12 @@ M: ast-class compile-smalltalk ( ast-class -- quot )
 
 ERROR: no-word name ;
 
-M: ast-foreign compile-smalltalk
+M: ast-foreign compile-ast
+    nip
     [ class>> dup ":" split1 lookup [ ] [ no-word ] ?if ]
     [ name>> ] bi define-foreign
-    [ nil ] ;
\ No newline at end of file
+    [ nil ] ;
+
+: compile-smalltalk ( statement -- quot )
+    [ [ empty-lexenv ] dip compile-sequence nip 0 ]
+    keep make-return ;
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
index 1dbbd054a8..8a7756054a 100644
--- a/extra/smalltalk/eval/eval-tests.factor
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -4,4 +4,6 @@ USING: smalltalk.eval tools.test io.streams.string ;
 [ 3 ] [ "1+2" eval-smalltalk ] unit-test
 [ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
 [ 7 ] [ "1+2+3;+4" eval-smalltalk ] unit-test
-[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test
\ No newline at end of file
+[ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test
+[ 5 ] [ "|x| x:=5. x" eval-smalltalk ] unit-test
+[ 11 ] [ "[:i| |x| x:=5. i+x] value: 6" eval-smalltalk ] unit-test
diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor
index 60f0d9cce2..d874000a0f 100644
--- a/extra/smalltalk/eval/eval.factor
+++ b/extra/smalltalk/eval/eval.factor
@@ -1,8 +1,12 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: compiler.units smalltalk.parser smalltalk.compiler ;
+USING: io.files io.encodings.utf8
+compiler.units smalltalk.parser smalltalk.compiler ;
 IN: smalltalk.eval
 
 : eval-smalltalk ( string -- result )
     [ parse-smalltalk compile-smalltalk ] with-compilation-unit
-    call( -- result ) ;
\ No newline at end of file
+    call( -- result ) ;
+
+: eval-smalltalk-file ( path -- result )
+    utf8 file-contents eval-smalltalk ;
diff --git a/extra/smalltalk/library/library.factor b/extra/smalltalk/library/library.factor
index 1a8cb8d177..28acf98dff 100644
--- a/extra/smalltalk/library/library.factor
+++ b/extra/smalltalk/library/library.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel present io math sequences assocs math.ranges fry
-tools.time locals smalltalk.selectors smalltalk.ast smalltalk.classes ;
+USING: kernel present io math sequences assocs math.ranges
+math.order fry tools.time locals smalltalk.selectors
+smalltalk.ast smalltalk.classes ;
 IN: smalltalk.library
 
 SELECTOR: print
@@ -10,6 +11,16 @@ SELECTOR: asString
 M: object selector-print dup present print ;
 M: object selector-asString present ;
 
+SELECTOR: print:
+SELECTOR: nextPutAll:
+SELECTOR: tab
+SELECTOR: nl
+
+M: object selector-print: [ present ] dip stream-print nil ;
+M: object selector-nextPutAll: selector-print: ;
+M: object selector-tab "    " swap selector-print: ;
+M: object selector-nl stream-nl nil ;
+
 SELECTOR: +
 SELECTOR: -
 SELECTOR: *
@@ -30,6 +41,12 @@ M: object selector-<= swap <= ;
 M: object selector->= swap >= ;
 M: object selector-=  swap =  ;
 
+SELECTOR: min:
+SELECTOR: max:
+
+M: object selector-min: min ;
+M: object selector-max: max ;
+
 SELECTOR: ifTrue:
 SELECTOR: ifFalse:
 SELECTOR: ifTrue:ifFalse:
@@ -38,6 +55,10 @@ M: object selector-ifTrue: [ call( -- result ) ] [ drop nil ] if ;
 M: object selector-ifFalse: [ drop nil ] [ call( -- result ) ] if ;
 M: object selector-ifTrue:ifFalse: [ drop call( -- result ) ] [ nip call( -- result ) ] if ;
 
+SELECTOR: isNil
+
+M: object selector-isNil nil eq? ;
+
 SELECTOR: at:
 SELECTOR: at:put:
 
diff --git a/extra/smalltalk/listener/listener.factor b/extra/smalltalk/listener/listener.factor
index e052f0c629..dc84fd90fb 100644
--- a/extra/smalltalk/listener/listener.factor
+++ b/extra/smalltalk/listener/listener.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel prettyprint io io.styles colors.constants compiler.units
 fry debugger sequences locals.rewrite.closures smalltalk.ast
-smalltalk.eval smalltalk.printer ;
+smalltalk.eval smalltalk.printer smalltalk.listener ;
 IN: smalltalk.listener
 
 : eval-interactively ( string -- )
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index 9ba1c38ede..ff9cbc208b 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -49,9 +49,9 @@ test         = <foreign parse-smalltalk Literal>
 [ B{ 1 2 3 4 } ] [ "#[1 2 3 4]" test-Literal ] unit-test
 [ { nil t f } ] [ "#(nil true false)" test-Literal ] unit-test
 [ { nil { t f } } ] [ "#(nil (true false))" test-Literal ] unit-test
-[ T{ ast-block f { } { } } ] [ "[]" test-Literal ] unit-test
-[ T{ ast-block f { "x" } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
-[ T{ ast-block f { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
+[ T{ ast-block f { } { } { } } ] [ "[]" test-Literal ] unit-test
+[ T{ ast-block f { "x" } { } { T{ ast-return f T{ ast-name f "x" } } } } ] [ "[ :x|^x]" test-Literal ] unit-test
+[ T{ ast-block f { } { } { T{ ast-return f self } } } ] [ "[^self]" test-Literal ] unit-test
 
 [
     T{ ast-block
@@ -190,6 +190,19 @@ test         = <foreign parse-smalltalk Expression>
 ]
 [ "12 sqrt + 1; + 2" test-Expression ] unit-test
 
+[
+    T{ ast-cascade
+       { receiver T{ ast-message-send f 12 "squared" } }
+       { messages
+         {
+           T{ ast-message f "to:" { 100 } }
+           T{ ast-message f "sqrt" }
+         }
+       }
+    }
+]
+[ "12 squared to: 100; sqrt" test-Expression ] unit-test
+
 [
     T{ ast-message-send f
         T{ ast-message-send f 1 "+" { 2 } }
@@ -228,12 +241,8 @@ test         = <foreign parse-smalltalk LocalVariableDeclarationList>
 [ T{ ast-local-variables f { "i" "j" } } ] [ " |  i j   |" test-LocalVariableDeclarationList ] unit-test
 
 
-EBNF: test-MessageSend
-test         = <foreign parse-smalltalk MessageSend>
-;EBNF
-
 [ T{ ast-message-send f T{ ast-name f "x" } "foo:bar:" { 1 2 } } ]
-[ "x foo:1 bar:2" test-MessageSend ] unit-test
+[ "x foo:1 bar:2" test-Expression ] unit-test
 
 [
     T{ ast-message-send
@@ -247,12 +256,14 @@ test         = <foreign parse-smalltalk MessageSend>
         { 10 100 }
     }
 ]
-[ "3 factorial + 4 factorial between: 10 and: 100" test-MessageSend ] unit-test
+[ "3 factorial + 4 factorial between: 10 and: 100" test-Expression ] unit-test
 
-[ T{ ast-sequence f { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
+[ T{ ast-sequence f { } { 1 2 } } ] [ "1. 2" parse-smalltalk ] unit-test
+
+[ T{ ast-sequence f { } { 1 2 } } ] [ "1. 2." parse-smalltalk ] unit-test
 
 [
-    T{ ast-sequence f
+    T{ ast-sequence f { }
         {
             T{ ast-class
                { name "Test" }
@@ -265,7 +276,7 @@ test         = <foreign parse-smalltalk MessageSend>
 [ "class Test [|a|]" parse-smalltalk ] unit-test
 
 [
-    T{ ast-sequence f
+    T{ ast-sequence f { }
         {
             T{ ast-class
                { name "Test1" }
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index c80171e025..1958861606 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -105,7 +105,7 @@ BlockLiteral = "["
                  => [[ args ]]
                 )?:args
                 ExecutableCode:body
-                "]" => [[ args >array body ast-block boa ]]
+                "]" => [[ args >array body <ast-block> ]]
 
 Literal = (ConstantReference
                 | FloatingPointLiteral
@@ -129,7 +129,7 @@ UnaryMessage = OptionalWhiteSpace
 BinaryMessage = OptionalWhiteSpace
                 BinaryMessageSelector:selector
                 OptionalWhiteSpace
-                (MessageSend | Operand):rhs
+                (UnaryMessageSend | Operand):rhs
                 => [[ selector { rhs } ast-message boa ]]
                                    
 KeywordMessageSegment = Keyword:k OptionalWhiteSpace (BinaryMessageSend | UnaryMessageSend | Operand):arg => [[ { k arg } ]]
@@ -140,13 +140,13 @@ KeywordMessage = OptionalWhiteSpace
 
 Message = BinaryMessage | UnaryMessage | KeywordMessage
 
-UnaryMessageSend = (MessageSend | Operand):lhs
-              Message:h
+UnaryMessageSend = (UnaryMessageSend | Operand):lhs
+              UnaryMessage:h
               (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
               => [[ lhs t h prefix >array <ast-cascade> ]]
 
-BinaryMessageSend = (MessageSend | Operand):lhs
-              Message:h
+BinaryMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
+              BinaryMessage:h
               (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
               => [[ lhs t h prefix >array <ast-cascade> ]]
 
@@ -155,10 +155,8 @@ KeywordMessageSend = (BinaryMessageSend | UnaryMessageSend | Operand):lhs
               (OptionalWhiteSpace ";" Message:m => [[ m ]])*:t
               => [[ lhs t h prefix >array <ast-cascade> ]]
 
-MessageSend = BinaryMessageSend | UnaryMessageSend | KeywordMessageSend
-
 Expression = OptionalWhiteSpace
-             (MessageSend | Operand):e
+             (KeywordMessageSend | BinaryMessageSend | UnaryMessageSend | Operand):e
              => [[ e ]]
 
 AssignmentOperation = OptionalWhiteSpace BindableIdentifier:i
@@ -176,13 +174,15 @@ LocalVariableDeclarationList = OptionalWhiteSpace "|" OptionalWhiteSpace
                  => [[ t h prefix ]]
                 )?:b OptionalWhiteSpace "|" => [[ b >array ast-local-variables boa ]]
 
-ExecutableCode = (LocalVariableDeclarationList)?:locals
-                 ((Statement:s OptionalWhiteSpace "." => [[ s ]])*:h
-                 FinalStatement:t (".")? => [[ h t suffix ]])?:body
-                 OptionalWhiteSpace
-                 => [[ body locals [ suffix ] when* >array ]]
+EndStatement = "."
 
-TopLevelForm = ExecutableCode => [[ ast-sequence boa ]]
+ExecutableCode = (LocalVariableDeclarationList)?:locals
+                 (Statement:s OptionalWhiteSpace EndStatement => [[ s ]])*:h
+                 (FinalStatement:t (EndStatement)? => [[ t ]])?:t
+                 OptionalWhiteSpace
+                 => [[ h t [ suffix ] when* locals [ prefix ] when* >array ]]
+
+TopLevelForm = ExecutableCode => [[ <ast-sequence> ]]
 
 UnaryMethodHeader = UnaryMessageSelector:selector
                   => [[ { selector { } } ]]
@@ -200,7 +200,7 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
         OptionalWhiteSpace "["
         ExecutableCode:code
         "]"
-        => [[ header first2 code ast-block boa ast-method boa ]]
+        => [[ header first2 code <ast-block> ast-method boa ]]
 
 ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         OptionalWhiteSpace
@@ -209,9 +209,9 @@ ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         (OptionalWhiteSpace LocalVariableDeclarationList:l => [[ l names>> ]])?:ivars
         (MethodDeclaration:h
          (OptionalWhiteSpace
-          "."
+          EndStatement
           OptionalWhiteSpace
-          MethodDeclaration:m => [[ m ]])*:t (".")?
+          MethodDeclaration:m => [[ m ]])*:t (EndStatement)?
           => [[ t h prefix ]]
          )?:methods
         OptionalWhiteSpace "]"
diff --git a/extra/smalltalk/parser/test.st b/extra/smalltalk/parser/test.st
index 8a1ae12145..063f20882a 100644
--- a/extra/smalltalk/parser/test.st
+++ b/extra/smalltalk/parser/test.st
@@ -31,9 +31,9 @@ class TreeNode extends Object [
             nextPutAll: 'long lived tree of depth '; print: maxDepth; tab;
             nextPutAll: ' check: '; print: longLivedTree itemCheck; nl
     ].
-
-    method binarytrees [
-        self binarytrees: self arg to: self stdout.
+    
+    method binarytrees: arg [
+        self binarytrees: arg to: self stdout.
         ^''
     ].
 
@@ -63,4 +63,3 @@ class TreeNode extends Object [
     ]
 ].
 
-Tests binarytrees

From 0ff66788503d96999b4b273a5bfe8c5fda8aab5f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:08:49 -0500
Subject: [PATCH 045/135] Load smalltalk.library by default and remove useless
 smalltalk.factor

---
 extra/smalltalk/eval/eval.factor | 3 ++-
 extra/smalltalk/smalltalk.factor | 4 ----
 2 files changed, 2 insertions(+), 5 deletions(-)
 delete mode 100644 extra/smalltalk/smalltalk.factor

diff --git a/extra/smalltalk/eval/eval.factor b/extra/smalltalk/eval/eval.factor
index d874000a0f..56841beafd 100644
--- a/extra/smalltalk/eval/eval.factor
+++ b/extra/smalltalk/eval/eval.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: io.files io.encodings.utf8
-compiler.units smalltalk.parser smalltalk.compiler ;
+compiler.units smalltalk.parser smalltalk.compiler
+smalltalk.library ;
 IN: smalltalk.eval
 
 : eval-smalltalk ( string -- result )
diff --git a/extra/smalltalk/smalltalk.factor b/extra/smalltalk/smalltalk.factor
deleted file mode 100644
index 27cd9912ed..0000000000
--- a/extra/smalltalk/smalltalk.factor
+++ /dev/null
@@ -1,4 +0,0 @@
-! Copyright (C) 2009 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: ;
-IN: smalltalk

From 8ab7328899458ad12c391272a7e0018bddbca742 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:09:49 -0500
Subject: [PATCH 046/135] Add new vocabs

---
 .../compiler/assignment/assignment.factor     | 36 +++++++++++++
 .../smalltalk/compiler/assignment/authors.txt |  1 +
 extra/smalltalk/compiler/return/authors.txt   |  1 +
 extra/smalltalk/compiler/return/return.factor | 50 +++++++++++++++++++
 4 files changed, 88 insertions(+)
 create mode 100644 extra/smalltalk/compiler/assignment/assignment.factor
 create mode 100644 extra/smalltalk/compiler/assignment/authors.txt
 create mode 100644 extra/smalltalk/compiler/return/authors.txt
 create mode 100644 extra/smalltalk/compiler/return/return.factor

diff --git a/extra/smalltalk/compiler/assignment/assignment.factor b/extra/smalltalk/compiler/assignment/assignment.factor
new file mode 100644
index 0000000000..3a0a769f86
--- /dev/null
+++ b/extra/smalltalk/compiler/assignment/assignment.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel sequences sets smalltalk.ast ;
+IN: smalltalk.compiler.assignment
+
+GENERIC: assigned-locals ( ast -- seq )
+
+M: ast-return assigned-locals value>> assigned-locals ;
+
+M: ast-block assigned-locals
+    [ body>> assigned-locals ] [ arguments>> ] bi diff ;
+
+M: ast-message-send assigned-locals
+    [ receiver>> assigned-locals ]
+    [ arguments>> assigned-locals ]
+    bi append ;
+
+M: ast-cascade assigned-locals
+    [ receiver>> assigned-locals ]
+    [ messages>> assigned-locals ]
+    bi append ;
+
+M: ast-message assigned-locals
+    arguments>> assigned-locals ;
+
+M: ast-assignment assigned-locals
+    [ name>> dup ast-name? [ name>> 1array ] [ drop { } ] if ]
+    [ value>> assigned-locals ] bi append ;
+
+M: ast-sequence assigned-locals
+    body>> assigned-locals ;
+
+M: array assigned-locals
+    [ assigned-locals ] map concat ;
+
+M: object assigned-locals drop f ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/assignment/authors.txt b/extra/smalltalk/compiler/assignment/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/assignment/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/return/authors.txt b/extra/smalltalk/compiler/return/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/smalltalk/compiler/return/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/return/return.factor b/extra/smalltalk/compiler/return/return.factor
new file mode 100644
index 0000000000..31b4a1511b
--- /dev/null
+++ b/extra/smalltalk/compiler/return/return.factor
@@ -0,0 +1,50 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays combinators.short-circuit continuations
+fry generalizations kernel locals.rewrite.closures namespaces
+sequences smalltalk.ast ;
+IN: smalltalk.compiler.return
+
+SYMBOL: return-continuation
+
+GENERIC: need-return-continuation? ( ast -- ? )
+
+M: ast-return need-return-continuation? drop t ;
+
+M: ast-block need-return-continuation? body>> need-return-continuation? ;
+
+M: ast-message-send need-return-continuation?
+    {
+        [ receiver>> need-return-continuation? ]
+        [ arguments>> need-return-continuation? ]
+    } 1&& ;
+
+M: ast-cascade need-return-continuation?
+    {
+        [ receiver>> need-return-continuation? ]
+        [ messages>> need-return-continuation? ]
+    } 1&& ;
+
+M: ast-message need-return-continuation?
+    arguments>> need-return-continuation? ;
+
+M: ast-assignment need-return-continuation?
+    value>> need-return-continuation? ;
+
+M: ast-sequence need-return-continuation?
+    body>> need-return-continuation? ;
+
+M: array need-return-continuation? [ need-return-continuation? ] any? ;
+
+M: object need-return-continuation? drop f ;
+
+: make-return ( quot n block -- quot )
+    need-return-continuation? [
+        '[
+            [
+                _ _ ncurry
+                [ return-continuation set ] prepose callcc1
+            ] with-scope
+        ]
+    ] [ drop ] if
+    rewrite-closures first ;
\ No newline at end of file

From aa37871ff9681750013da1b6e3d9f631db878293 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 02:32:48 -0500
Subject: [PATCH 047/135] rename get-next to peek-next, get-char to current

---
 extra/html/parser/state/state.factor | 20 ++++++++++++--------
 1 file changed, 12 insertions(+), 8 deletions(-)

diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 2369b1d750..177a427716 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -12,30 +12,30 @@ TUPLE: state-parser sequence n ;
         swap >>sequence
         0 >>n ;
 
-: (get-char) ( n state -- char/f )
+: state-parser-nth ( n state -- char/f )
     sequence>> ?nth ; inline
 
-: get-char ( state -- char/f )
-    [ n>> ] keep (get-char) ; inline
+: current ( state -- char/f )
+    [ n>> ] keep state-parser-nth ; inline
 
-: get-next ( state -- char/f )
-    [ n>> 1 + ] keep (get-char) ; inline
+: peek-next ( state -- char/f )
+    [ n>> 1 + ] keep state-parser-nth ; inline
 
 : next ( state -- state )
     [ 1 + ] change-n ; inline
 
 : get+increment ( state -- char/f )
-    [ get-char ] [ next drop ] bi ; inline
+    [ current ] [ next drop ] bi ; inline
 
 : state-parse ( sequence quot -- )
     [ <state-parser> ] dip call ; inline
 
 :: skip-until ( state quot: ( obj -- ? ) -- )
-    state get-char [
+    state current [
         quot call [ state next quot skip-until ] unless
     ] when* ; inline recursive
 
-: state-parse-end? ( state -- ? ) get-next not ;
+: state-parse-end? ( state -- ? ) peek-next not ;
 
 : take-until ( state quot: ( obj -- ? ) -- sequence/f )
     over state-parse-end? [
@@ -65,3 +65,7 @@ TUPLE: state-parser sequence n ;
 
 : take-until-object ( state obj -- sequence )
     '[ _ = ] take-until ;
+
+: take-stuff ( state delimiter -- sequence )
+    
+    ;

From 99c3cd95174041e8b3bb82d8fbf57e6059960984 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 02:33:38 -0500
Subject: [PATCH 048/135] more renaing get-char to current

---
 extra/html/parser/analyzer/analyzer.factor | 12 ++++++++++--
 extra/html/parser/parser.factor            | 10 +++++-----
 2 files changed, 15 insertions(+), 7 deletions(-)

diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor
index b344ce160f..54b8c8fc69 100755
--- a/extra/html/parser/analyzer/analyzer.factor
+++ b/extra/html/parser/analyzer/analyzer.factor
@@ -3,7 +3,7 @@
 USING: assocs html.parser kernel math sequences strings ascii
 arrays generalizations shuffle unicode.case namespaces make
 splitting http accessors io combinators http.client urls
-urls.encoding fry prettyprint ;
+urls.encoding fry prettyprint sets ;
 IN: html.parser.analyzer
 
 TUPLE: link attributes clickable ;
@@ -126,7 +126,15 @@ TUPLE: link attributes clickable ;
     [ [
         [ name>> "a" = ]
         [ attributes>> "href" swap key? ] bi and ] filter
-    ] map sift [ [ attributes>> "href" swap at ] map ] map concat ;
+    ] map sift
+    [ [ attributes>> "href" swap at ] map ] map concat ;
+
+: find-frame-links ( vector -- vector' )
+    [ name>> "frame" = ] find-between-all
+    [ [ attributes>> "src" swap at ] map sift ] map concat sift ;
+
+: find-all-links ( vector -- vector' )
+    [ find-hrefs ] [ find-frame-links ] bi append prune ;
 
 : find-forms ( vector -- vector' )
     "form" over find-opening-tags-by-name
diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 94ef59bdfd..9209e2dbc8 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -64,7 +64,7 @@ SYMBOL: tagstack
 
 : read-value ( state-parser -- string )
     skip-whitespace
-    dup get-char quote? [ read-quote ] [ read-token ] if
+    dup current quote? [ read-quote ] [ read-token ] if
     [ blank? ] trim ;
 
 : read-comment ( state-parser -- )
@@ -74,7 +74,7 @@ SYMBOL: tagstack
     ">" take-until-sequence make-dtd-tag push-tag ;
 
 : read-bang ( state-parser -- )
-    next dup { [ get-char CHAR: - = ] [ get-next CHAR: - = ] } 1&& [
+    next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& [
         next next
         read-comment
     ] [
@@ -83,7 +83,7 @@ SYMBOL: tagstack
 
 : read-tag ( state-parser -- string )
     [ [ "><" member? ] take-until ]
-    [ dup get-char CHAR: < = [ next ] unless drop ] bi ;
+    [ dup current CHAR: < = [ next ] unless drop ] bi ;
 
 : read-until-< ( state-parser -- string )
     [ CHAR: < = ] take-until ;
@@ -111,7 +111,7 @@ SYMBOL: tagstack
     ] state-parse ;
 
 : read-< ( state-parser -- string/f )
-    next dup get-char [
+    next dup current [
         CHAR: ! = [ read-bang f ] [ read-tag ] if
     ] [
         drop f
@@ -121,7 +121,7 @@ SYMBOL: tagstack
     read-< [ (parse-tag) make-tag push-tag ] unless-empty ;
 
 : (parse-html) ( state-parser -- )
-    dup get-next [
+    dup peek-next [
         [ parse-text ] [ parse-tag ] [ (parse-html) ] tri
     ] [ drop ] if ;
 

From f994654af31bcabe23a695fb6ddaffd10c5cc992 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 02:45:20 -0500
Subject: [PATCH 049/135] add take-while to state parser

---
 extra/html/parser/state/state.factor | 14 ++++++++------
 1 file changed, 8 insertions(+), 6 deletions(-)

diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 177a427716..e1951fbd7c 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -18,6 +18,9 @@ TUPLE: state-parser sequence n ;
 : current ( state -- char/f )
     [ n>> ] keep state-parser-nth ; inline
 
+: previous ( state -- char/f )
+    [ n>> 1 - ] keep state-parser-nth ; inline
+
 : peek-next ( state -- char/f )
     [ n>> 1 + ] keep state-parser-nth ; inline
 
@@ -27,9 +30,6 @@ TUPLE: state-parser sequence n ;
 : get+increment ( state -- char/f )
     [ current ] [ next drop ] bi ; inline
 
-: state-parse ( sequence quot -- )
-    [ <state-parser> ] dip call ; inline
-
 :: skip-until ( state quot: ( obj -- ? ) -- )
     state current [
         quot call [ state next quot skip-until ] unless
@@ -46,6 +46,9 @@ TUPLE: state-parser sequence n ;
         [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
     ] if ; inline
 
+: take-while ( state quot: ( obj -- ? ) -- sequence/f )
+    [ not ] compose take-until ; inline
+
 :: take-until-sequence ( state-parser sequence -- sequence' )
     sequence length <growing-circular> :> growing
     state-parser
@@ -66,6 +69,5 @@ TUPLE: state-parser sequence n ;
 : take-until-object ( state obj -- sequence )
     '[ _ = ] take-until ;
 
-: take-stuff ( state delimiter -- sequence )
-    
-    ;
+: state-parse ( sequence quot -- )
+    [ <state-parser> ] dip call ; inline

From 3885ba02a6cdf78682f06d75d3865e5183084987 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:47:51 -0500
Subject: [PATCH 050/135] Fixing up smalltalk to the point where it can run
 fib, slowly

---
 extra/smalltalk/ast/ast.factor                |  4 +++
 extra/smalltalk/compiler/compiler.factor      | 31 +++++++++++++------
 extra/smalltalk/compiler/lexenv/lexenv.factor |  3 +-
 .../compiler/return/return-tests.factor       |  3 ++
 extra/smalltalk/compiler/return/return.factor | 23 ++++++--------
 extra/smalltalk/eval/eval-tests.factor        |  4 ++-
 extra/smalltalk/eval/fib.st                   | 11 +++++++
 extra/smalltalk/parser/parser-tests.factor    |  5 +--
 extra/smalltalk/parser/parser.factor          |  2 +-
 9 files changed, 57 insertions(+), 29 deletions(-)
 create mode 100644 extra/smalltalk/compiler/return/return-tests.factor
 create mode 100644 extra/smalltalk/eval/fib.st

diff --git a/extra/smalltalk/ast/ast.factor b/extra/smalltalk/ast/ast.factor
index e9759b2197..fc415aa361 100644
--- a/extra/smalltalk/ast/ast.factor
+++ b/extra/smalltalk/ast/ast.factor
@@ -45,5 +45,9 @@ M: ast-sequence arguments>> drop { } ;
     [ ast-cascade boa ]
     if ;
 
+! Methods return self by default
+: <ast-method> ( class arguments body -- method )
+    self suffix <ast-block> ast-method boa ;
+
 TUPLE: symbol { name string } ;
 MEMO: intern ( name -- symbol ) symbol boa ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index e61b44ffae..0b6f17e3fa 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -21,11 +21,22 @@ M: ast-name compile-ast name>> swap lookup-reader ;
 : compile-arguments ( lexenv ast -- quot )
     arguments>> [ compile-ast ] with map [ ] join ;
 
-M: ast-message-send compile-ast
-    [ compile-arguments ]
+: compile-ifTrue:ifFalse: ( lexenv ast -- quot )
     [ receiver>> compile-ast ]
-    [ nip selector>> selector>generic ]
-    2tri [ append ] dip suffix ;
+    [ compile-arguments ] 2bi
+    [ if ] 3append ;
+
+M: ast-message-send compile-ast
+    dup selector>> {
+        { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
+        [
+            drop
+            [ compile-arguments ]
+            [ receiver>> compile-ast ]
+            [ nip selector>> selector>generic ]
+            2tri [ append ] dip suffix
+        ]
+    } case ;
 
 M: ast-cascade compile-ast
     [ receiver>> compile-ast ]
@@ -40,8 +51,8 @@ M: ast-cascade compile-ast
     ] 2bi append ;
 
 M: ast-return compile-ast
-    value>> compile-ast
-    [ return-continuation get continue-with ] append ;
+    [ value>> compile-ast ] [ drop return>> 1quotation ] 2bi
+    [ continue-with ] 3append ;
 
 : (compile-sequence) ( lexenv asts -- quot )
     [ drop [ nil ] ] [
@@ -106,7 +117,7 @@ M: ast-block compile-ast
     [ lexenv self>> suffix ] dip <lambda> ;
 
 : compile-method-body ( lexenv block -- quot )
-    [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] keep
+    [ [ (compile-method-body) ] [ arguments>> length 1+ ] bi ] 2keep
     make-return ;
 
 : compile-method ( lexenv ast-method -- )
@@ -115,7 +126,7 @@ M: ast-block compile-ast
     2bi define ;
 
 : <class-lexenv> ( class -- lexenv )
-    <lexenv> swap >>class "self" <local-reader> >>self ;
+    <lexenv> swap >>class "self" <local> >>self "^" <local> >>return ;
 
 M: ast-class compile-ast
     nip
@@ -136,5 +147,5 @@ M: ast-foreign compile-ast
     [ nil ] ;
 
 : compile-smalltalk ( statement -- quot )
-    [ [ empty-lexenv ] dip compile-sequence nip 0 ]
-    keep make-return ;
\ No newline at end of file
+    [ empty-lexenv ] dip [ compile-sequence nip 0 ]
+    2keep make-return ;
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/lexenv/lexenv.factor b/extra/smalltalk/compiler/lexenv/lexenv.factor
index 6b6d283761..cd06314fd9 100644
--- a/extra/smalltalk/compiler/lexenv/lexenv.factor
+++ b/extra/smalltalk/compiler/lexenv/lexenv.factor
@@ -10,7 +10,7 @@ IN: smalltalk.compiler.lexenv
 ! self: word or f for top-level forms
 ! class: class word or f for top-level forms
 ! method: generic word or f for top-level forms
-TUPLE: lexenv local-readers local-writers self class method ;
+TUPLE: lexenv local-readers local-writers self return class method ;
 
 : <lexenv> ( -- lexenv ) lexenv new ; inline
 
@@ -21,6 +21,7 @@ CONSTANT: empty-lexenv T{ lexenv }
         [ [ local-readers>> ] bi@ assoc-union >>local-readers ]
         [ [ local-writers>> ] bi@ assoc-union >>local-writers ]
         [ [ self>> ] either? >>self ]
+        [ [ return>> ] either? >>return ]
         [ [ class>> ] either? >>class ]
         [ [ method>> ] either? >>method ]
     } 2cleave ;
diff --git a/extra/smalltalk/compiler/return/return-tests.factor b/extra/smalltalk/compiler/return/return-tests.factor
new file mode 100644
index 0000000000..15a3406ffc
--- /dev/null
+++ b/extra/smalltalk/compiler/return/return-tests.factor
@@ -0,0 +1,3 @@
+USING: smalltalk.parser smalltalk.compiler.return tools.test ;
+
+[ t ] [ "(i <= 1) ifTrue: [^1] ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]" parse-smalltalk need-return-continuation? ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/compiler/return/return.factor b/extra/smalltalk/compiler/return/return.factor
index 31b4a1511b..8c36bdac64 100644
--- a/extra/smalltalk/compiler/return/return.factor
+++ b/extra/smalltalk/compiler/return/return.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays combinators.short-circuit continuations
-fry generalizations kernel locals.rewrite.closures namespaces
-sequences smalltalk.ast ;
+fry generalizations kernel locals locals.types locals.rewrite.closures
+namespaces make sequences smalltalk.ast ;
 IN: smalltalk.compiler.return
 
 SYMBOL: return-continuation
@@ -17,13 +17,13 @@ M: ast-message-send need-return-continuation?
     {
         [ receiver>> need-return-continuation? ]
         [ arguments>> need-return-continuation? ]
-    } 1&& ;
+    } 1|| ;
 
 M: ast-cascade need-return-continuation?
     {
         [ receiver>> need-return-continuation? ]
         [ messages>> need-return-continuation? ]
-    } 1&& ;
+    } 1|| ;
 
 M: ast-message need-return-continuation?
     arguments>> need-return-continuation? ;
@@ -38,13 +38,8 @@ M: array need-return-continuation? [ need-return-continuation? ] any? ;
 
 M: object need-return-continuation? drop f ;
 
-: make-return ( quot n block -- quot )
-    need-return-continuation? [
-        '[
-            [
-                _ _ ncurry
-                [ return-continuation set ] prepose callcc1
-            ] with-scope
-        ]
-    ] [ drop ] if
-    rewrite-closures first ;
\ No newline at end of file
+:: make-return ( quot n lexenv block -- quot )
+    block need-return-continuation? [
+        quot clone [ lexenv return>> <def> '[ _ ] prepend ] change-body
+        n '[ _ _ ncurry callcc1 ]
+    ] [ quot ] if rewrite-closures first ;
\ No newline at end of file
diff --git a/extra/smalltalk/eval/eval-tests.factor b/extra/smalltalk/eval/eval-tests.factor
index 8a7756054a..95366d65b9 100644
--- a/extra/smalltalk/eval/eval-tests.factor
+++ b/extra/smalltalk/eval/eval-tests.factor
@@ -1,5 +1,5 @@
 IN: smalltalk.eval.tests
-USING: smalltalk.eval tools.test io.streams.string ;
+USING: smalltalk.eval tools.test io.streams.string kernel ;
 
 [ 3 ] [ "1+2" eval-smalltalk ] unit-test
 [ "HAI" ] [ "(1<10) ifTrue:['HAI'] ifFalse:['BAI']" eval-smalltalk ] unit-test
@@ -7,3 +7,5 @@ USING: smalltalk.eval tools.test io.streams.string ;
 [ 6 "5\n6\n" ] [ [ "[:x|x print] value: 5; value: 6" eval-smalltalk ] with-string-writer ] unit-test
 [ 5 ] [ "|x| x:=5. x" eval-smalltalk ] unit-test
 [ 11 ] [ "[:i| |x| x:=5. i+x] value: 6" eval-smalltalk ] unit-test
+[ t ] [ "class Blah [method foo [5]]. Blah new foo" eval-smalltalk tuple? ] unit-test
+[ 196418 ] [ "vocab:smalltalk/eval/fib.st" eval-smalltalk-file ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/eval/fib.st b/extra/smalltalk/eval/fib.st
new file mode 100644
index 0000000000..41ab8f56cc
--- /dev/null
+++ b/extra/smalltalk/eval/fib.st
@@ -0,0 +1,11 @@
+class Fib [
+    |i|
+    method i: newI [i:=newI].
+    method compute [
+        (i <= 1)
+          ifTrue: [^1]
+          ifFalse: [^((Fib new i:(i-1)) compute + (Fib new i:(i-2)) compute)]
+    ].
+].
+
+[(Fib new i: 26) compute] time
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser-tests.factor b/extra/smalltalk/parser/parser-tests.factor
index ff9cbc208b..9027290e6a 100644
--- a/extra/smalltalk/parser/parser-tests.factor
+++ b/extra/smalltalk/parser/parser-tests.factor
@@ -1,5 +1,6 @@
 IN: smalltalk.parser.tests
-USING: smalltalk.parser smalltalk.ast peg.ebnf tools.test accessors
+USING: smalltalk.parser smalltalk.ast
+peg.ebnf tools.test accessors
 io.files io.encodings.ascii kernel ;
 
 EBNF: test-Character
@@ -296,4 +297,4 @@ test         = <foreign parse-smalltalk LocalVariableDeclarationList>
 
 [ ] [ "class Foo []. Tests blah " parse-smalltalk drop ] unit-test
 
-[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
+[ ] [ "vocab:smalltalk/parser/test.st" ascii file-contents parse-smalltalk drop ] unit-test
\ No newline at end of file
diff --git a/extra/smalltalk/parser/parser.factor b/extra/smalltalk/parser/parser.factor
index 1958861606..c7cafe94dd 100644
--- a/extra/smalltalk/parser/parser.factor
+++ b/extra/smalltalk/parser/parser.factor
@@ -200,7 +200,7 @@ MethodDeclaration = OptionalWhiteSpace "method" OptionalWhiteSpace MethodHeader:
         OptionalWhiteSpace "["
         ExecutableCode:code
         "]"
-        => [[ header first2 code <ast-block> ast-method boa ]]
+        => [[ header first2 code <ast-method> ]]
 
 ClassDeclaration = OptionalWhiteSpace "class" OptionalWhiteSpace Identifier:name
         OptionalWhiteSpace

From 11eff11fb753cc2b97ed73e5e1698bde60efc359 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 02:53:30 -0500
Subject: [PATCH 051/135] Add silly optimization for 'new'; this will be
 removed when compiler improves

---
 extra/smalltalk/compiler/compiler.factor | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/extra/smalltalk/compiler/compiler.factor b/extra/smalltalk/compiler/compiler.factor
index 0b6f17e3fa..2eeee30692 100644
--- a/extra/smalltalk/compiler/compiler.factor
+++ b/extra/smalltalk/compiler/compiler.factor
@@ -21,6 +21,11 @@ M: ast-name compile-ast name>> swap lookup-reader ;
 : compile-arguments ( lexenv ast -- quot )
     arguments>> [ compile-ast ] with map [ ] join ;
 
+: compile-new ( lexenv ast -- quot )
+    [ receiver>> compile-ast ]
+    [ compile-arguments ] 2bi
+    [ new ] 3append ;
+
 : compile-ifTrue:ifFalse: ( lexenv ast -- quot )
     [ receiver>> compile-ast ]
     [ compile-arguments ] 2bi
@@ -29,6 +34,7 @@ M: ast-name compile-ast name>> swap lookup-reader ;
 M: ast-message-send compile-ast
     dup selector>> {
         { "ifTrue:ifFalse:" [ compile-ifTrue:ifFalse: ] }
+        { "new" [ compile-new ] }
         [
             drop
             [ compile-arguments ]

From 20df429a506770e1fc05e02865297c6c352ee5f2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 03:13:38 -0500
Subject: [PATCH 052/135] take-until doesnt pass the element to the quotation
 anymore

---
 extra/html/parser/parser.factor            | 14 +++++++-------
 extra/html/parser/state/state-tests.factor |  4 ++--
 extra/html/parser/state/state.factor       | 10 +++++-----
 3 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 9209e2dbc8..61088d1b5e 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -42,10 +42,10 @@ SYMBOL: tagstack
 : make-dtd-tag ( string -- tag ) dtd new-tag ; inline
 
 : read-single-quote ( state-parser -- string )
-    [ [ CHAR: ' = ] take-until ] [ next drop ] bi ;
+    [ [ current CHAR: ' = ] take-until ] [ next drop ] bi ;
 
 : read-double-quote ( state-parser -- string )
-    [ [ CHAR: " = ] take-until ] [ next drop ] bi ;
+    [ [ current CHAR: " = ] take-until ] [ next drop ] bi ;
 
 : read-quote ( state-parser -- string )
     dup get+increment CHAR: ' =
@@ -53,14 +53,14 @@ SYMBOL: tagstack
 
 : read-key ( state-parser -- string )
     skip-whitespace
-    [ { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
+    [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
 
 : read-= ( state-parser -- )
     skip-whitespace
-    [ [ CHAR: = = ] take-until drop ] [ next drop ] bi ;
+    [ [ current CHAR: = = ] take-until drop ] [ next drop ] bi ;
 
 : read-token ( state-parser -- string )
-    [ blank? ] take-until ;
+    [ current blank? ] take-until ;
 
 : read-value ( state-parser -- string )
     skip-whitespace
@@ -82,11 +82,11 @@ SYMBOL: tagstack
     ] if ;
 
 : read-tag ( state-parser -- string )
-    [ [ "><" member? ] take-until ]
+    [ [ current "><" member? ] take-until ]
     [ dup current CHAR: < = [ next ] unless drop ] bi ;
 
 : read-until-< ( state-parser -- string )
-    [ CHAR: < = ] take-until ;
+    [ current CHAR: < = ] take-until ;
 
 : parse-text ( state-parser -- )
     read-until-< [ make-text-tag push-tag ] unless-empty ;
diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index f9862e1e69..835b54d0d3 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -7,7 +7,7 @@ IN: html.parser.state.tests
 [ "hi" " how are you?" ]
 [
     "hi how are you?"
-    [ [ [ blank? ] take-until ] [ take-rest ] bi ] state-parse
+    [ [ [ current blank? ] take-until ] [ take-rest ] bi ] state-parse
 ] unit-test
 
 [ "foo" ";bar" ]
@@ -30,7 +30,7 @@ IN: html.parser.state.tests
 ] unit-test
 
 [ { 1 2 } ]
-[ { 1 2 3 } <state-parser> [ 3 = ] take-until ] unit-test
+[ { 1 2 3 } <state-parser> [ current 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 e1951fbd7c..3f899446c0 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -32,8 +32,8 @@ TUPLE: state-parser sequence n ;
 
 :: skip-until ( state quot: ( obj -- ? ) -- )
     state current [
-        quot call [ state next quot skip-until ] unless
-    ] when* ; inline recursive
+        state quot call [ state next quot skip-until ] unless
+    ] when ; inline recursive
 
 : state-parse-end? ( state -- ? ) peek-next not ;
 
@@ -53,7 +53,7 @@ TUPLE: state-parser sequence n ;
     sequence length <growing-circular> :> growing
     state-parser
     [
-        growing push-growing-circular
+        current growing push-growing-circular
         sequence growing sequence=
     ] take-until :> found
     found dup length
@@ -61,13 +61,13 @@ TUPLE: state-parser sequence n ;
     state-parser next drop ;
     
 : skip-whitespace ( state -- state )
-    [ [ blank? not ] take-until drop ] keep ;
+    [ [ current blank? not ] take-until drop ] keep ;
 
 : take-rest ( state -- sequence )
     [ drop f ] take-until ; inline
 
 : take-until-object ( state obj -- sequence )
-    '[ _ = ] take-until ;
+    '[ current _ = ] take-until ;
 
 : state-parse ( sequence quot -- )
     [ <state-parser> ] dip call ; inline

From e37627fa8f3441f7cb552193702022b2f7c0634e Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Wed, 1 Apr 2009 04:28:53 -0500
Subject: [PATCH 053/135] fix linux64 blas

---
 basis/math/blas/ffi/ffi.factor | 1 -
 1 file changed, 1 deletion(-)

diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor
index 0603a91370..bc98f72d8b 100644
--- a/basis/math/blas/ffi/ffi.factor
+++ b/basis/math/blas/ffi/ffi.factor
@@ -11,7 +11,6 @@ IN: math.blas.ffi
         [ 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
 >>

From 393df94d38c49b5ec29172f034151f889b81728a Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 11:03:10 -0500
Subject: [PATCH 054/135] add chicago-talk to demos

---
 extra/chicago-talk/tags.txt | 1 +
 1 file changed, 1 insertion(+)
 create mode 100644 extra/chicago-talk/tags.txt

diff --git a/extra/chicago-talk/tags.txt b/extra/chicago-talk/tags.txt
new file mode 100644
index 0000000000..cb5fc203e1
--- /dev/null
+++ b/extra/chicago-talk/tags.txt
@@ -0,0 +1 @@
+demos

From b35bb10123a1a7b334b8ddad30c61baeb63e7c4a Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 11:08:19 -0500
Subject: [PATCH 055/135] spider - better handling of relative links for
 frames, dont spider things twice

---
 extra/spider/spider.factor | 30 +++++++++++++++++++++---------
 1 file changed, 21 insertions(+), 9 deletions(-)

diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index d08276a9bb..aeb4676767 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -4,11 +4,12 @@ USING: accessors fry html.parser html.parser.analyzer
 http.client kernel tools.time sets assocs sequences
 concurrency.combinators io threads namespaces math multiline
 math.parser inspector urls logging combinators.short-circuit
-continuations calendar prettyprint dlists deques locals ;
+continuations calendar prettyprint dlists deques locals
+present ;
 IN: spider
 
 TUPLE: spider base count max-count sleep max-depth initial-links
-filters spidered todo nonmatching quiet ;
+filters spidered todo nonmatching quiet currently-spidering ;
 
 TUPLE: spider-result url depth headers fetch-time parsed-html
 links processing-time timestamp ;
@@ -25,10 +26,16 @@ TUPLE: unique-deque assoc deque ;
 : <unique-deque> ( -- unique-deque )
     H{ } clone <dlist> unique-deque boa ;
 
+: url-exists? ( url unique-deque -- ? )
+    [ url>> ] [ assoc>> ] bi* key? ;
+
 : push-url ( url depth unique-deque -- )
-    [ <todo-url> ] dip
-    [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
-    [ deque>> push-back ] 2bi ;
+    [ <todo-url> ] dip 2dup url-exists? [
+        2drop
+    ] [
+        [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
+        [ deque>> push-back ] 2bi
+    ] if ;
 
 : pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
 
@@ -38,6 +45,7 @@ TUPLE: unique-deque assoc deque ;
     >url
     spider new
         over >>base
+        over >>currently-spidering
         swap 0 <unique-deque> [ push-url ] keep >>todo
         <unique-deque> >>nonmatching
         0 >>max-depth
@@ -71,9 +79,12 @@ TUPLE: unique-deque assoc deque ;
     [ add-nonmatching ]
     [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
 
+: url-absolute? ( url -- ? )
+    present "http://" head? ;
+
 : normalize-hrefs ( links spider -- links' )
-    [ [ >url ] map ] dip
-    base>> swap [ derive-url ] with map ;
+    currently-spidering>> present swap
+    [ dup url-absolute? [ derive-url ] [ url-append-path >url ] if ] with map ;
 
 : print-spidering ( url depth -- )
     "depth: " write number>string write
@@ -83,7 +94,7 @@ TUPLE: unique-deque assoc deque ;
     f url spider spidered>> set-at
     [ url http-get ] benchmark :> fetch-time :> html :> headers
     [
-        html parse-html [ ] [ find-hrefs spider normalize-hrefs ] bi
+        html parse-html [ ] [ find-all-links spider normalize-hrefs ] bi
     ] benchmark :> processing-time :> links :> parsed-html
     url depth headers fetch-time parsed-html links processing-time
     now spider-result boa ;
@@ -110,6 +121,7 @@ TUPLE: unique-deque assoc deque ;
     } 1&& ;
 
 : setup-next-url ( spider -- spider url depth )
+    dup todo>> peek-url url>> present >>currently-spidering
     dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
 
 : spider-next-page ( spider -- )
@@ -119,7 +131,7 @@ PRIVATE>
 
 : run-spider-loop ( spider -- )
     dup spider-page? [
-        [ spider-next-page ] [ run-spider-loop ] bi
+        [ spider-next-page ] [ spider-sleep ] [ run-spider-loop ] tri
     ] [
         drop
     ] if ;

From a172d61f2e908d51113133950270056af6a59f4e Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 11:11:15 -0500
Subject: [PATCH 056/135] fix deployed name in minneapolis-talk, add
 summary/deploy to chicago talk

---
 extra/chicago-talk/deploy.factor     | 12 ++++++++++++
 extra/chicago-talk/summary.txt       |  1 +
 extra/minneapolis-talk/deploy.factor |  2 +-
 extra/minneapolis-talk/summary.txt   |  2 +-
 4 files changed, 15 insertions(+), 2 deletions(-)
 create mode 100755 extra/chicago-talk/deploy.factor
 create mode 100755 extra/chicago-talk/summary.txt

diff --git a/extra/chicago-talk/deploy.factor b/extra/chicago-talk/deploy.factor
new file mode 100755
index 0000000000..8f8adc18d8
--- /dev/null
+++ b/extra/chicago-talk/deploy.factor
@@ -0,0 +1,12 @@
+USING: tools.deploy.config ;
+V{
+    { deploy-ui? t }
+    { deploy-io 1 }
+    { deploy-reflection 1 }
+    { deploy-compiler? t }
+    { deploy-math? t }
+    { deploy-word-props? f }
+    { deploy-c-types? f }
+    { "stop-after-last-window?" t }
+    { deploy-name "Chicago Talk" }
+}
diff --git a/extra/chicago-talk/summary.txt b/extra/chicago-talk/summary.txt
new file mode 100755
index 0000000000..229e1a363b
--- /dev/null
+++ b/extra/chicago-talk/summary.txt
@@ -0,0 +1 @@
+Slides for a talk at the Pycon VM Summit, Chicago, IL, March 2009
diff --git a/extra/minneapolis-talk/deploy.factor b/extra/minneapolis-talk/deploy.factor
index 2f7f79da9d..32b78a2c13 100755
--- a/extra/minneapolis-talk/deploy.factor
+++ b/extra/minneapolis-talk/deploy.factor
@@ -8,5 +8,5 @@ V{
     { deploy-word-props? f }
     { deploy-c-types? f }
     { "stop-after-last-window?" t }
-    { deploy-name "Catalyst Talk" }
+    { deploy-name "Minnesota Talk" }
 }
diff --git a/extra/minneapolis-talk/summary.txt b/extra/minneapolis-talk/summary.txt
index 7fcc7abc88..ef8d1bd5e3 100755
--- a/extra/minneapolis-talk/summary.txt
+++ b/extra/minneapolis-talk/summary.txt
@@ -1 +1 @@
-Slides for a talk at Ruby.mn, Minneapolis MN, January 2008
+Slides for a talk at Ruby.mn, Minneapolis, MN, January 2008

From fdb8c9da1a129b2efe2e1d65e9e9e62bc24289c2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 11:43:30 -0500
Subject: [PATCH 057/135] cleaning up html.parser

---
 extra/html/parser/parser.factor | 20 +++++++-------------
 1 file changed, 7 insertions(+), 13 deletions(-)

diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 61088d1b5e..63efa3fdb2 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays hashtables html.parser.state
-html.parser.utils kernel make namespaces sequences
+html.parser.utils kernel namespaces sequences
 unicode.case unicode.categories combinators.short-circuit
 quoting ;
 IN: html.parser
@@ -30,17 +30,11 @@ SYMBOL: tagstack
 : make-tag ( string attribs -- tag )
     [ [ closing-tag? ] keep "/" trim1 ] dip rot <tag> ;
 
-: new-tag ( string type -- tag )
+: new-tag ( text name -- tag )
     tag new
         swap >>name
         swap >>text ; inline
 
-: make-text-tag ( string -- tag ) text new-tag ; inline
-
-: make-comment-tag ( string -- tag ) comment new-tag ; inline
-
-: make-dtd-tag ( string -- tag ) dtd new-tag ; inline
-
 : read-single-quote ( state-parser -- string )
     [ [ current CHAR: ' = ] take-until ] [ next drop ] bi ;
 
@@ -68,10 +62,10 @@ SYMBOL: tagstack
     [ blank? ] trim ;
 
 : read-comment ( state-parser -- )
-    "-->" take-until-sequence make-comment-tag push-tag ;
+    "-->" take-until-sequence comment new-tag push-tag ;
 
 : read-dtd ( state-parser -- )
-    ">" take-until-sequence make-dtd-tag push-tag ;
+    ">" take-until-sequence dtd new-tag push-tag ;
 
 : read-bang ( state-parser -- )
     next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& [
@@ -89,7 +83,7 @@ SYMBOL: tagstack
     [ current CHAR: < = ] take-until ;
 
 : parse-text ( state-parser -- )
-    read-until-< [ make-text-tag push-tag ] unless-empty ;
+    read-until-< [ text new-tag push-tag ] unless-empty ;
 
 : (parse-attributes) ( state-parser -- )
     skip-whitespace
@@ -98,12 +92,12 @@ SYMBOL: tagstack
     ] [
         [
             [ read-key >lower ] [ read-= ] [ read-value ] tri
-            2array ,
+            swap set
         ] keep (parse-attributes)
     ] if ;
 
 : parse-attributes ( state-parser -- hashtable )
-    [ (parse-attributes) ] { } make >hashtable ;
+    [ (parse-attributes) ] H{ } make-assoc ;
 
 : (parse-tag) ( string -- string' hashtable )
     [

From d82b8ba4ebdeb3c948691ca4d7c1954da1086bd6 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 11:48:44 -0500
Subject: [PATCH 058/135] more cleanup

---
 extra/html/parser/parser.factor | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 63efa3fdb2..6d2e02cf1d 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -3,7 +3,7 @@
 USING: accessors arrays hashtables html.parser.state
 html.parser.utils kernel namespaces sequences
 unicode.case unicode.categories combinators.short-circuit
-quoting ;
+quoting fry ;
 IN: html.parser
 
 
@@ -19,7 +19,7 @@ SYMBOL: tagstack
 
 : closing-tag? ( string -- ? )
     [ f ]
-    [ [ first ] [ peek ] bi [ CHAR: / = ] bi@ or ] if-empty ;
+    [ { [ first CHAR: / = ] [ peek CHAR: / = ] } 1|| ] if-empty ;
 
 : <tag> ( name attributes closing? -- tag )
     tag new
@@ -35,11 +35,14 @@ SYMBOL: tagstack
         swap >>name
         swap >>text ; inline
 
+: (read-quote) ( state-parser ch -- string )
+    '[ [ current _ = ] take-until ] [ next drop ] bi ;
+
 : read-single-quote ( state-parser -- string )
-    [ [ current CHAR: ' = ] take-until ] [ next drop ] bi ;
+    CHAR: ' (read-quote) ;
 
 : read-double-quote ( state-parser -- string )
-    [ [ current CHAR: " = ] take-until ] [ next drop ] bi ;
+    CHAR: " (read-quote) ;
 
 : read-quote ( state-parser -- string )
     dup get+increment CHAR: ' =

From 7060a5905f89098f265afe0ffcf80b47ff743499 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 12:44:06 -0500
Subject: [PATCH 059/135] add take-sequence to state parser

---
 extra/html/parser/state/state-tests.factor | 18 ++++++++++
 extra/html/parser/state/state.factor       | 39 +++++++++++++---------
 2 files changed, 42 insertions(+), 15 deletions(-)

diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index 835b54d0d3..6766cfddc2 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -34,3 +34,21 @@ IN: html.parser.state.tests
 
 [ { 1 2 } ]
 [ { 1 2 3 4 } <state-parser> { 3 4 } take-until-sequence ] unit-test
+
+[ "ab" ]
+[ "abcd" <state-parser> "ab" take-sequence ] unit-test
+
+[ f ]
+[ "abcd" <state-parser> "lol" take-sequence ] unit-test
+
+[ "ab" ]
+[
+    "abcd" <state-parser>
+    [ "lol" take-sequence drop ] [ "ab" take-sequence ] bi
+] unit-test
+
+[ "" ]
+[ "abcd" <state-parser> "" take-sequence ] unit-test
+
+[ "cd" ]
+[ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 3f899446c0..85b0b0fbb9 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -12,32 +12,32 @@ TUPLE: state-parser sequence n ;
         swap >>sequence
         0 >>n ;
 
-: state-parser-nth ( n state -- char/f )
+: state-parser-nth ( n state-parser -- char/f )
     sequence>> ?nth ; inline
 
-: current ( state -- char/f )
+: current ( state-parser -- char/f )
     [ n>> ] keep state-parser-nth ; inline
 
-: previous ( state -- char/f )
+: previous ( state-parser -- char/f )
     [ n>> 1 - ] keep state-parser-nth ; inline
 
-: peek-next ( state -- char/f )
+: peek-next ( state-parser -- char/f )
     [ n>> 1 + ] keep state-parser-nth ; inline
 
-: next ( state -- state )
+: next ( state-parser -- state-parser )
     [ 1 + ] change-n ; inline
 
-: get+increment ( state -- char/f )
+: get+increment ( state-parser -- char/f )
     [ current ] [ next drop ] bi ; inline
 
-:: skip-until ( state quot: ( obj -- ? ) -- )
-    state current [
-        state quot call [ state next quot skip-until ] unless
+:: skip-until ( state-parser quot: ( obj -- ? ) -- )
+    state-parser current [
+        state-parser quot call [ state-parser next quot skip-until ] unless
     ] when ; inline recursive
 
-: state-parse-end? ( state -- ? ) peek-next not ;
+: state-parse-end? ( state-parser -- ? ) peek-next not ;
 
-: take-until ( state quot: ( obj -- ? ) -- sequence/f )
+: take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
     over state-parse-end? [
         2drop f
     ] [
@@ -46,9 +46,18 @@ TUPLE: state-parser sequence n ;
         [ drop [ n>> ] [ sequence>> ] bi ] 2tri subseq
     ] if ; inline
 
-: take-while ( state quot: ( obj -- ? ) -- sequence/f )
+: take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
     [ not ] compose take-until ; inline
 
+:: take-sequence ( state-parser sequence -- obj/f )
+    state-parser [ n>> dup sequence length + ] [ sequence>> ] bi <slice>
+    sequence sequence= [
+        sequence
+        state-parser [ sequence length + ] change-n drop
+    ] [
+        f
+    ] if ;
+
 :: take-until-sequence ( state-parser sequence -- sequence' )
     sequence length <growing-circular> :> growing
     state-parser
@@ -60,13 +69,13 @@ TUPLE: state-parser sequence n ;
     growing length 1- - head
     state-parser next drop ;
     
-: skip-whitespace ( state -- state )
+: skip-whitespace ( state-parser -- state-parser )
     [ [ current blank? not ] take-until drop ] keep ;
 
-: take-rest ( state -- sequence )
+: take-rest ( state-parser -- sequence )
     [ drop f ] take-until ; inline
 
-: take-until-object ( state obj -- sequence )
+: take-until-object ( state-parser obj -- sequence )
     '[ current _ = ] take-until ;
 
 : state-parse ( sequence quot -- )

From 826d9f18c52fdab38164946a9a7de92f8177e458 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 12:44:38 -0500
Subject: [PATCH 060/135] fix parsing of attributes for nofollows

---
 extra/html/parser/parser-tests.factor | 13 +++++++++++++
 extra/html/parser/parser.factor       | 21 +++++++++------------
 2 files changed, 22 insertions(+), 12 deletions(-)

diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor
index 9757f70a67..25251159b1 100644
--- a/extra/html/parser/parser-tests.factor
+++ b/extra/html/parser/parser-tests.factor
@@ -42,6 +42,19 @@ V{
 }
 ] [ "<a   href  =    \"http://factorcode.org/\"    foo   =  bar baz='quux'a=pirsqd  >" parse-html ] unit-test
 
+[
+V{
+    T{ tag f "a"
+        H{
+            { "a" "pirsqd" }
+            { "foo" "bar" }
+            { "href" "http://factorcode.org/" }
+            { "baz" "quux" }
+            { "nofollow" f }
+        } f f }
+}
+] [ "<a   href  =    \"http://factorcode.org/\"    nofollow  foo   =  bar baz='quux'a=pirsqd  >" parse-html ] unit-test
+
 [
 V{
     T{ tag f "html" H{ } f f }
diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 6d2e02cf1d..317337073b 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -6,7 +6,6 @@ unicode.case unicode.categories combinators.short-circuit
 quoting fry ;
 IN: html.parser
 
-
 TUPLE: tag name attributes text closing? ;
 
 SINGLETON: text
@@ -52,7 +51,7 @@ SYMBOL: tagstack
     skip-whitespace
     [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
 
-: read-= ( state-parser -- )
+: read-=1 ( state-parser -- )
     skip-whitespace
     [ [ current CHAR: = = ] take-until drop ] [ next drop ] bi ;
 
@@ -71,12 +70,8 @@ SYMBOL: tagstack
     ">" take-until-sequence dtd new-tag push-tag ;
 
 : read-bang ( state-parser -- )
-    next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&& [
-        next next
-        read-comment
-    ] [
-        read-dtd
-    ] if ;
+    next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
+    [ next next read-comment ] [ read-dtd ] if ;
 
 : read-tag ( state-parser -- string )
     [ [ current "><" member? ] take-until ]
@@ -88,15 +83,17 @@ SYMBOL: tagstack
 : parse-text ( state-parser -- )
     read-until-< [ text new-tag push-tag ] unless-empty ;
 
+: parse-key/value ( state-parser -- key value )
+    [ read-key >lower ]
+    [ skip-whitespace "=" take-sequence ]
+    [ swap [ read-value ] [ drop f ] if ] tri ;
+
 : (parse-attributes) ( state-parser -- )
     skip-whitespace
     dup state-parse-end? [
         drop
     ] [
-        [
-            [ read-key >lower ] [ read-= ] [ read-value ] tri
-            swap set
-        ] keep (parse-attributes)
+        [ parse-key/value swap set ] [ (parse-attributes) ] bi
     ] if ;
 
 : parse-attributes ( state-parser -- hashtable )

From 9ecf8ec3db08d986ff26a93e59a7d696112df7cd Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 12:47:17 -0500
Subject: [PATCH 061/135] remove dead code

---
 extra/html/parser/parser.factor | 4 ----
 1 file changed, 4 deletions(-)

diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 317337073b..f95684ae15 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -51,10 +51,6 @@ SYMBOL: tagstack
     skip-whitespace
     [ current { [ CHAR: = = ] [ blank? ] } 1|| ] take-until ;
 
-: read-=1 ( state-parser -- )
-    skip-whitespace
-    [ [ current CHAR: = = ] take-until drop ] [ next drop ] bi ;
-
 : read-token ( state-parser -- string )
     [ current blank? ] take-until ;
 

From 28dae46b7dffd39b3aa856110564a672d778fc99 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 12:48:51 -0500
Subject: [PATCH 062/135] make html.parser words private

---
 extra/html/parser/parser.factor | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index f95684ae15..498691e2b2 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -11,6 +11,9 @@ TUPLE: tag name attributes text closing? ;
 SINGLETON: text
 SINGLETON: dtd
 SINGLETON: comment
+
+<PRIVATE
+
 SYMBOL: tagstack
 
 : push-tag ( tag -- )
@@ -118,5 +121,7 @@ SYMBOL: tagstack
 : tag-parse ( quot -- vector )
     V{ } clone tagstack [ state-parse ] with-variable ; inline
 
+PRIVATE>
+
 : parse-html ( string -- vector )
     [ (parse-html) tagstack get ] tag-parse ;

From 09e4d34ff24c231ef1cea12ab2b736d666a10672 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 12:52:02 -0500
Subject: [PATCH 063/135] rename next to advance

---
 extra/html/parser/parser.factor      | 10 +++++-----
 extra/html/parser/state/state.factor |  8 ++++----
 2 files changed, 9 insertions(+), 9 deletions(-)

diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 498691e2b2..4aae6a25c4 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -38,7 +38,7 @@ SYMBOL: tagstack
         swap >>text ; inline
 
 : (read-quote) ( state-parser ch -- string )
-    '[ [ current _ = ] take-until ] [ next drop ] bi ;
+    '[ [ current _ = ] take-until ] [ advance drop ] bi ;
 
 : read-single-quote ( state-parser -- string )
     CHAR: ' (read-quote) ;
@@ -69,12 +69,12 @@ SYMBOL: tagstack
     ">" take-until-sequence dtd new-tag push-tag ;
 
 : read-bang ( state-parser -- )
-    next dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
-    [ next next read-comment ] [ read-dtd ] if ;
+    advance dup { [ current CHAR: - = ] [ peek-next CHAR: - = ] } 1&&
+    [ advance advance read-comment ] [ read-dtd ] if ;
 
 : read-tag ( state-parser -- string )
     [ [ current "><" member? ] take-until ]
-    [ dup current CHAR: < = [ next ] unless drop ] bi ;
+    [ dup current CHAR: < = [ advance ] unless drop ] bi ;
 
 : read-until-< ( state-parser -- string )
     [ current CHAR: < = ] take-until ;
@@ -104,7 +104,7 @@ SYMBOL: tagstack
     ] state-parse ;
 
 : read-< ( state-parser -- string/f )
-    next dup current [
+    advance dup current [
         CHAR: ! = [ read-bang f ] [ read-tag ] if
     ] [
         drop f
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 85b0b0fbb9..4a050306e9 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -24,15 +24,15 @@ TUPLE: state-parser sequence n ;
 : peek-next ( state-parser -- char/f )
     [ n>> 1 + ] keep state-parser-nth ; inline
 
-: next ( state-parser -- state-parser )
+: advance ( state-parser -- state-parser )
     [ 1 + ] change-n ; inline
 
 : get+increment ( state-parser -- char/f )
-    [ current ] [ next drop ] bi ; inline
+    [ current ] [ advance drop ] bi ; inline
 
 :: skip-until ( state-parser quot: ( obj -- ? ) -- )
     state-parser current [
-        state-parser quot call [ state-parser next quot skip-until ] unless
+        state-parser quot call [ state-parser advance quot skip-until ] unless
     ] when ; inline recursive
 
 : state-parse-end? ( state-parser -- ? ) peek-next not ;
@@ -67,7 +67,7 @@ TUPLE: state-parser sequence n ;
     ] take-until :> found
     found dup length
     growing length 1- - head
-    state-parser next drop ;
+    state-parser advance drop ;
     
 : skip-whitespace ( state-parser -- state-parser )
     [ [ current blank? not ] take-until drop ] keep ;

From d52535b63a71b216cac816cc87fe14db0ca57924 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 13:42:38 -0500
Subject: [PATCH 064/135] set non-key/value attributes to themselves

---
 extra/html/parser/parser-tests.factor | 2 +-
 extra/html/parser/parser.factor       | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/extra/html/parser/parser-tests.factor b/extra/html/parser/parser-tests.factor
index 25251159b1..ca276fc54e 100644
--- a/extra/html/parser/parser-tests.factor
+++ b/extra/html/parser/parser-tests.factor
@@ -50,7 +50,7 @@ V{
             { "foo" "bar" }
             { "href" "http://factorcode.org/" }
             { "baz" "quux" }
-            { "nofollow" f }
+            { "nofollow" "nofollow" }
         } f f }
 }
 ] [ "<a   href  =    \"http://factorcode.org/\"    nofollow  foo   =  bar baz='quux'a=pirsqd  >" parse-html ] unit-test
diff --git a/extra/html/parser/parser.factor b/extra/html/parser/parser.factor
index 4aae6a25c4..61315a4925 100644
--- a/extra/html/parser/parser.factor
+++ b/extra/html/parser/parser.factor
@@ -85,7 +85,7 @@ SYMBOL: tagstack
 : parse-key/value ( state-parser -- key value )
     [ read-key >lower ]
     [ skip-whitespace "=" take-sequence ]
-    [ swap [ read-value ] [ drop f ] if ] tri ;
+    [ swap [ read-value ] [ drop dup ] if ] tri ;
 
 : (parse-attributes) ( state-parser -- )
     skip-whitespace

From 1e4eebda3a5e82bcdf30ee5e30790f2c2161ca39 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 14:36:08 -0500
Subject: [PATCH 065/135] refactor state parser some more, add a word to parse
 escaped strings

---
 extra/html/parser/state/state-tests.factor | 14 +++++++++++
 extra/html/parser/state/state.factor       | 29 +++++++++++++++-------
 2 files changed, 34 insertions(+), 9 deletions(-)

diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index 6766cfddc2..4e0d512e89 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -52,3 +52,17 @@ IN: html.parser.state.tests
 
 [ "cd" ]
 [ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
+
+
+[ f ]
+[
+    "\"abc\" asdf" <state-parser>
+    [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
+] unit-test
+
+[ "asdf" ]
+[
+    "\"abc\" asdf" <state-parser>
+    [ CHAR: \ CHAR: " take-quoted-string drop ]
+    [ skip-whitespace "asdf" take-sequence ] bi
+] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 4a050306e9..22e901a310 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math kernel sequences accessors fry circular
-unicode.case unicode.categories locals ;
+unicode.case unicode.categories locals combinators.short-circuit ;
 
 IN: html.parser.state
 
@@ -12,21 +12,22 @@ TUPLE: state-parser sequence n ;
         swap >>sequence
         0 >>n ;
 
-: state-parser-nth ( n state-parser -- char/f )
-    sequence>> ?nth ; inline
+: offset  ( state-parser offset -- char/f )
+    swap
+    [ n>> + ] [ sequence>> ?nth ] bi ; inline
 
-: current ( state-parser -- char/f )
-    [ n>> ] keep state-parser-nth ; inline
+: current ( state-parser -- char/f ) 0 offset ; inline
 
-: previous ( state-parser -- char/f )
-    [ n>> 1 - ] keep state-parser-nth ; inline
+: previous ( state-parser -- char/f ) -1 offset ; inline
 
-: peek-next ( state-parser -- char/f )
-    [ n>> 1 + ] keep state-parser-nth ; inline
+: peek-next ( state-parser -- char/f ) 1 offset ; inline
 
 : advance ( state-parser -- state-parser )
     [ 1 + ] change-n ; inline
 
+: advance* ( state-parser -- )
+    advance drop ; inline
+
 : get+increment ( state-parser -- char/f )
     [ current ] [ advance drop ] bi ; inline
 
@@ -80,3 +81,13 @@ TUPLE: state-parser sequence n ;
 
 : state-parse ( sequence quot -- )
     [ <state-parser> ] dip call ; inline
+
+:: take-quoted-string ( state-parser escape-char quote-char -- string )
+    state-parser advance
+    [
+        {
+            [ { [ previous quote-char = ] [ current quote-char = ] } 1&& ]
+            [ current quote-char = not ]
+        } 1||
+    ] take-while
+    state-parser advance* ;

From 947bcc3d3323e9895a8b8ea187a8f1fcfbf08a80 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 14:50:43 -0500
Subject: [PATCH 066/135] state-parser take-quoted-string rewinds if the string
 is not found

---
 extra/html/parser/state/state-tests.factor | 13 +++++++++++++
 extra/html/parser/state/state.factor       |  9 +++++++--
 2 files changed, 20 insertions(+), 2 deletions(-)

diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index 4e0d512e89..316fe31805 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -66,3 +66,16 @@ IN: html.parser.state.tests
     [ CHAR: \ CHAR: " take-quoted-string drop ]
     [ skip-whitespace "asdf" take-sequence ] bi
 ] unit-test
+
+[ f ]
+[
+    "\"abc asdf" <state-parser>
+    CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
+[ "\"abc" ]
+[
+    "\"abc asdf" <state-parser>
+    [ CHAR: \ CHAR: " take-quoted-string drop ]
+    [ "\"abc" take-sequence ] bi
+] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 22e901a310..8a9084b91b 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -83,11 +83,16 @@ TUPLE: state-parser sequence n ;
     [ <state-parser> ] dip call ; inline
 
 :: take-quoted-string ( state-parser escape-char quote-char -- string )
+    state-parser n>> :> start-n
     state-parser advance
     [
         {
             [ { [ previous quote-char = ] [ current quote-char = ] } 1&& ]
             [ current quote-char = not ]
         } 1||
-    ] take-while
-    state-parser advance* ;
+    ] take-while :> string
+    state-parser current quote-char = [
+        state-parser advance* string
+    ] [
+        start-n state-parser (>>n) f
+    ] if ;

From 432ff9b07fbe4da2f23c8cabec4c2c4637df99c8 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Wed, 1 Apr 2009 14:52:43 -0500
Subject: [PATCH 067/135] Make math.blas library and ABI choice configurable

---
 basis/alien/fortran/fortran-docs.factor       |  8 +++----
 basis/math/blas/config/config-docs.factor     | 23 +++++++++++++++++++
 basis/math/blas/config/config.factor          | 23 +++++++++++++++++++
 basis/math/blas/ffi/ffi.factor                | 15 +++---------
 basis/math/blas/matrices/matrices-docs.factor |  5 ++--
 5 files changed, 56 insertions(+), 18 deletions(-)
 create mode 100644 basis/math/blas/config/config-docs.factor
 create mode 100644 basis/math/blas/config/config.factor

diff --git a/basis/alien/fortran/fortran-docs.factor b/basis/alien/fortran/fortran-docs.factor
index c5d124e198..8027020c75 100644
--- a/basis/alien/fortran/fortran-docs.factor
+++ b/basis/alien/fortran/fortran-docs.factor
@@ -7,10 +7,10 @@ IN: alien.fortran
 ARTICLE: "alien.fortran-abis" "Fortran ABIs"
 "Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
 { $list
-    { { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
-    { { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
-    { { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
-    { { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
+    { { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
+    { { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
+    { { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
+    { { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
 }
 "A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
 
diff --git a/basis/math/blas/config/config-docs.factor b/basis/math/blas/config/config-docs.factor
new file mode 100644
index 0000000000..60eaff25c2
--- /dev/null
+++ b/basis/math/blas/config/config-docs.factor
@@ -0,0 +1,23 @@
+USING: alien.fortran help.markup help.syntax math.blas.config multiline ;
+IN: math.blas.config
+
+ARTICLE: "math.blas.config" "Configuring the BLAS interface"
+"The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:"
+{ $subsection blas-library }
+{ $subsection blas-fortran-abi }
+"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
+{ $code <"
+USING: math.blas.config namespaces ;
+"X:\\path\\to\\acml.dll" blas-library set-global
+intel-windows-abi blas-fortran-abi set-global
+"> }
+"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
+;
+
+HELP: blas-library
+{ $description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+HELP: blas-fortran-abi
+{ $description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
+
+ABOUT: "math.blas.config"
diff --git a/basis/math/blas/config/config.factor b/basis/math/blas/config/config.factor
new file mode 100644
index 0000000000..8ed515625d
--- /dev/null
+++ b/basis/math/blas/config/config.factor
@@ -0,0 +1,23 @@
+USING: alien.fortran combinators kernel namespaces system ;
+IN: math.blas.config
+
+SYMBOLS: blas-library blas-fortran-abi ;
+
+blas-library [
+    {
+        { [ os macosx?  ] [ "libblas.dylib" ] }
+        { [ os windows? ] [ "blas.dll"      ] }
+        [ "libblas.so" ]
+    } cond
+] initialize
+
+blas-fortran-abi [
+    {
+        { [ os macosx?                  ] [ intel-unix-abi ] }
+        { [ os windows? cpu x86.32? and ] [ f2c-abi        ] }
+        { [ os windows? cpu x86.64? and ] [ gfortran-abi   ] }
+        { [ os freebsd?                 ] [ gfortran-abi   ] }
+        { [ os linux?   cpu x86.32? and ] [ gfortran-abi   ] }
+        [ f2c-abi ]
+    } cond
+] initialize
diff --git a/basis/math/blas/ffi/ffi.factor b/basis/math/blas/ffi/ffi.factor
index bc98f72d8b..b7748f500f 100644
--- a/basis/math/blas/ffi/ffi.factor
+++ b/basis/math/blas/ffi/ffi.factor
@@ -1,18 +1,9 @@
-USING: alien alien.fortran kernel system combinators
-alien.libraries ;
+USING: alien.fortran kernel math.blas.config namespaces ;
 IN: math.blas.ffi
 
 <<
-"blas" {
-    { [ 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? ] [ linux? cpu x86.32? and ] bi or ]
-        [ "libblas.so" gfortran-abi add-fortran-library ]
-    }
-    [ "libblas.so" f2c-abi add-fortran-library ]
-} cond
+"blas" blas-library blas-fortran-abi [ get ] bi@
+add-fortran-library
 >>
 
 LIBRARY: blas
diff --git a/basis/math/blas/matrices/matrices-docs.factor b/basis/math/blas/matrices/matrices-docs.factor
index 17d2f9ccd1..5662cd9905 100644
--- a/basis/math/blas/matrices/matrices-docs.factor
+++ b/basis/math/blas/matrices/matrices-docs.factor
@@ -2,13 +2,14 @@ USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequence
 IN: math.blas.matrices
 
 ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
-"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:"
+"Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:"
 { $subsection "math.blas-types" }
 "Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
 { $subsection "math.blas.vectors" }
 "Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
 { $subsection "math.blas.matrices" }
-"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ;
+"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:"
+{ $subsection "math.blas.config" } ;
 
 ARTICLE: "math.blas-types" "BLAS interface types"
 "BLAS vectors come in single- and double-precision, real and complex flavors:"

From d64e07af8b2b3cd8243b8a4a818209215814e95f Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 15:23:05 -0500
Subject: [PATCH 068/135] fix bug in state-parser, add take-token

---
 extra/html/parser/state/state-tests.factor | 3 +++
 extra/html/parser/state/state.factor       | 5 ++++-
 2 files changed, 7 insertions(+), 1 deletion(-)

diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index 316fe31805..b7a929284b 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -79,3 +79,6 @@ IN: html.parser.state.tests
     [ CHAR: \ CHAR: " take-quoted-string drop ]
     [ "\"abc" take-sequence ] bi
 ] unit-test
+
+[ "c" ]
+[ "c" <state-parser> take-token ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 8a9084b91b..1b83089c98 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -36,7 +36,7 @@ TUPLE: state-parser sequence n ;
         state-parser quot call [ state-parser advance quot skip-until ] unless
     ] when ; inline recursive
 
-: state-parse-end? ( state-parser -- ? ) peek-next not ;
+: state-parse-end? ( state-parser -- ? ) current not ;
 
 : take-until ( state-parser quot: ( obj -- ? ) -- sequence/f )
     over state-parse-end? [
@@ -96,3 +96,6 @@ TUPLE: state-parser sequence n ;
     ] [
         start-n state-parser (>>n) f
     ] if ;
+
+: take-token ( state-parser -- string )
+    skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;

From 6af6de1aacaa7b39c95c9d192a11fe29fb64c7bc Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 15:51:39 -0500
Subject: [PATCH 069/135] make tokenize-line configurable, fix bug in
 take-quoted-string

---
 extra/html/parser/state/state-tests.factor | 10 +++++++++-
 extra/html/parser/state/state.factor       | 19 +++++++++++++++++--
 2 files changed, 26 insertions(+), 3 deletions(-)

diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index b7a929284b..e655dbb699 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -53,13 +53,18 @@ IN: html.parser.state.tests
 [ "cd" ]
 [ "abcd" <state-parser> [ "ab" take-sequence drop ] [ "cd" take-sequence ] bi ] unit-test
 
-
 [ f ]
 [
     "\"abc\" asdf" <state-parser>
     [ CHAR: \ CHAR: " take-quoted-string drop ] [ "asdf" take-sequence ] bi
 ] unit-test
 
+[ "abc\\\"def" ]
+[
+    "\"abc\\\"def\" asdf" <state-parser>
+    CHAR: \ CHAR: " take-quoted-string
+] unit-test
+
 [ "asdf" ]
 [
     "\"abc\" asdf" <state-parser>
@@ -82,3 +87,6 @@ IN: html.parser.state.tests
 
 [ "c" ]
 [ "c" <state-parser> take-token ] unit-test
+
+[ { "a" "b" "c" "abcd e \\\"f g" } ]
+[ "a b c  \"abcd e \\\"f g\"" CHAR: \ CHAR: " tokenize-line ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 1b83089c98..6cca9f72a9 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math kernel sequences accessors fry circular
-unicode.case unicode.categories locals combinators.short-circuit ;
+unicode.case unicode.categories locals combinators.short-circuit
+make combinators ;
 
 IN: html.parser.state
 
@@ -87,7 +88,7 @@ TUPLE: state-parser sequence n ;
     state-parser advance
     [
         {
-            [ { [ previous quote-char = ] [ current quote-char = ] } 1&& ]
+            [ { [ previous escape-char = ] [ current quote-char = ] } 1&& ]
             [ current quote-char = not ]
         } 1||
     ] take-while :> string
@@ -99,3 +100,17 @@ TUPLE: state-parser sequence n ;
 
 : take-token ( state-parser -- string )
     skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
+
+:: (tokenize-line) ( state-parser escape-char quote-char -- )
+    state-parser skip-whitespace
+    dup current {
+        { quote-char [
+            [ escape-char quote-char take-quoted-string , ]
+            [ escape-char quote-char (tokenize-line) ] bi
+        ] }
+        { f [ drop ] }
+        [ drop [ take-token , ] [ escape-char quote-char (tokenize-line) ] bi ]
+    } case ;
+
+: tokenize-line ( line escape-char quote-char -- seq )
+    [ <state-parser> ] 2dip [ (tokenize-line) ] { } make ;

From 7b6260ca8c8471e20d30a6bffa760cc93f9e0461 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 17:28:36 -0500
Subject: [PATCH 070/135] remove tokenize-line

---
 extra/html/parser/state/state-tests.factor |  7 +++++--
 extra/html/parser/state/state.factor       | 17 +++++++----------
 2 files changed, 12 insertions(+), 12 deletions(-)

diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index e655dbb699..63916a3c1c 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -88,5 +88,8 @@ IN: html.parser.state.tests
 [ "c" ]
 [ "c" <state-parser> take-token ] unit-test
 
-[ { "a" "b" "c" "abcd e \\\"f g" } ]
-[ "a b c  \"abcd e \\\"f g\"" CHAR: \ CHAR: " tokenize-line ] unit-test
+[ f ]
+[ "" <state-parser> take-token ] unit-test
+
+[ "abcd e \\\"f g" ]
+[ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 6cca9f72a9..86adb0f914 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -98,19 +98,16 @@ TUPLE: state-parser sequence n ;
         start-n state-parser (>>n) f
     ] if ;
 
-: take-token ( state-parser -- string )
+: (take-token) ( state-parser -- string )
     skip-whitespace [ current { [ blank? ] [ f = ] } 1|| ] take-until ;
 
-:: (tokenize-line) ( state-parser escape-char quote-char -- )
+:: take-token* ( state-parser escape-char quote-char -- string/f )
     state-parser skip-whitespace
     dup current {
-        { quote-char [
-            [ escape-char quote-char take-quoted-string , ]
-            [ escape-char quote-char (tokenize-line) ] bi
-        ] }
-        { f [ drop ] }
-        [ drop [ take-token , ] [ escape-char quote-char (tokenize-line) ] bi ]
+        { quote-char [ escape-char quote-char take-quoted-string ] }
+        { f [ drop f ] }
+        [ drop (take-token) ]
     } case ;
 
-: tokenize-line ( line escape-char quote-char -- seq )
-    [ <state-parser> ] 2dip [ (tokenize-line) ] { } make ;
+: take-token ( state-parser -- string/f )
+    CHAR: \ CHAR: " take-token* ;

From 1b0c301005c9ddedec40cf6cef362d88ff4b0e33 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 17:29:58 -0500
Subject: [PATCH 071/135] move assoc-heaps to extra

---
 {basis => extra}/assoc-heaps/assoc-heaps-docs.factor  | 0
 {basis => extra}/assoc-heaps/assoc-heaps-tests.factor | 0
 {basis => extra}/assoc-heaps/assoc-heaps.factor       | 0
 {basis => extra}/assoc-heaps/authors.txt              | 0
 {basis => extra}/assoc-heaps/summary.txt              | 0
 5 files changed, 0 insertions(+), 0 deletions(-)
 rename {basis => extra}/assoc-heaps/assoc-heaps-docs.factor (100%)
 rename {basis => extra}/assoc-heaps/assoc-heaps-tests.factor (100%)
 rename {basis => extra}/assoc-heaps/assoc-heaps.factor (100%)
 rename {basis => extra}/assoc-heaps/authors.txt (100%)
 rename {basis => extra}/assoc-heaps/summary.txt (100%)

diff --git a/basis/assoc-heaps/assoc-heaps-docs.factor b/extra/assoc-heaps/assoc-heaps-docs.factor
similarity index 100%
rename from basis/assoc-heaps/assoc-heaps-docs.factor
rename to extra/assoc-heaps/assoc-heaps-docs.factor
diff --git a/basis/assoc-heaps/assoc-heaps-tests.factor b/extra/assoc-heaps/assoc-heaps-tests.factor
similarity index 100%
rename from basis/assoc-heaps/assoc-heaps-tests.factor
rename to extra/assoc-heaps/assoc-heaps-tests.factor
diff --git a/basis/assoc-heaps/assoc-heaps.factor b/extra/assoc-heaps/assoc-heaps.factor
similarity index 100%
rename from basis/assoc-heaps/assoc-heaps.factor
rename to extra/assoc-heaps/assoc-heaps.factor
diff --git a/basis/assoc-heaps/authors.txt b/extra/assoc-heaps/authors.txt
similarity index 100%
rename from basis/assoc-heaps/authors.txt
rename to extra/assoc-heaps/authors.txt
diff --git a/basis/assoc-heaps/summary.txt b/extra/assoc-heaps/summary.txt
similarity index 100%
rename from basis/assoc-heaps/summary.txt
rename to extra/assoc-heaps/summary.txt

From 9d44708e1d87e795f30d63b37e3f7b5908b4c160 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 1 Apr 2009 18:43:45 -0400
Subject: [PATCH 072/135] Fix contains? -> any? rename issue

---
 extra/project-euler/001/001.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor
index 17f8d0386d..68e1ff032a 100644
--- a/extra/project-euler/001/001.factor
+++ b/extra/project-euler/001/001.factor
@@ -53,7 +53,7 @@ PRIVATE>
 
 
 : euler001c ( -- answer )
-    1000 [ { 3 5 } [ mod 0 = ] with contains? ] filter sum ;
+    1000 [ { 3 5 } [ mod 0 = ] with any? ] filter sum ;
 
 ! [ euler001c ] 100 ave-time
 ! 0 ms ave run time - 0.06 SD (100 trials)

From c698a83a12f87713fea953ae4aec54c980bfde17 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 1 Apr 2009 19:29:19 -0400
Subject: [PATCH 073/135] Add divisor? math function

---
 basis/math/functions/functions-docs.factor  |  8 +++++++-
 basis/math/functions/functions-tests.factor | 16 +++++++++++-----
 basis/math/functions/functions.factor       |  5 ++++-
 3 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor
index 33a5d96fc4..02fcd5f4d9 100644
--- a/basis/math/functions/functions-docs.factor
+++ b/basis/math/functions/functions-docs.factor
@@ -13,7 +13,8 @@ ARTICLE: "integer-functions" "Integer functions"
 "Tests:"
 { $subsection power-of-2? }
 { $subsection even? }
-{ $subsection odd? } ;
+{ $subsection odd? }
+{ $subsection divisor? } ;
 
 ARTICLE: "arithmetic-functions" "Arithmetic functions"
 "Computing additive and multiplicative inverses:"
@@ -269,6 +270,11 @@ HELP: gcd
 { $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
 { $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ;
 
+HELP: divisor?
+{ $values { "x" integer } { "y" integer } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "y" } " is a divisor of " { $snippet "x" } ". This is the same thing as saying " { $snippet "x" } " is divisible by " { $snippet "y" } "." }
+{ $notes "Returns t for both negative and positive divisors, as well as trivial and non-trivial divisors." } ;
+
 HELP: mod-inv
 { $values { "x" integer } { "n" integer } { "y" integer } }
 { $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." }
diff --git a/basis/math/functions/functions-tests.factor b/basis/math/functions/functions-tests.factor
index 9f5ce36be1..4c9d151fd8 100644
--- a/basis/math/functions/functions-tests.factor
+++ b/basis/math/functions/functions-tests.factor
@@ -32,13 +32,13 @@ IN: math.functions.tests
 
 [ 1.0 ] [ 0 cosh ] unit-test
 [ 0.0 ] [ 1 acosh ] unit-test
-            
+
 [ 1.0 ] [ 0 cos ] unit-test
 [ 0.0 ] [ 1 acos ] unit-test
-            
+
 [ 0.0 ] [ 0 sinh ] unit-test
 [ 0.0 ] [ 0 asinh ] unit-test
-            
+
 [ 0.0 ] [ 0 sin ] unit-test
 [ 0.0 ] [ 0 asin ] unit-test
 
@@ -97,11 +97,17 @@ IN: math.functions.tests
 
 : verify-gcd ( a b -- ? )
     2dup gcd
-    [ rot * swap rem ] dip = ; 
+    [ rot * swap rem ] dip = ;
 
 [ t ] [ 123 124 verify-gcd ] unit-test
 [ t ] [ 50 120 verify-gcd ] unit-test
 
+[ t ] [ 0 42 divisor? ] unit-test
+[ t ] [ 42 7 divisor? ] unit-test
+[ t ] [ 42 -7 divisor? ] unit-test
+[ t ] [ 42 42 divisor? ] unit-test
+[ f ] [ 42 16 divisor? ] unit-test
+
 [ 3 ] [ 5 7 mod-inv ] unit-test
 [ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
 
@@ -150,4 +156,4 @@ IN: math.functions.tests
     1067811677921310779
     2135623355842621559
     [ >bignum ] tri@ ^mod
-] unit-test
\ No newline at end of file
+] unit-test
diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index a87b3995d7..799bb04169 100644
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -111,6 +111,9 @@ PRIVATE>
 : lcm ( a b -- c )
     [ * ] 2keep gcd nip /i ; foldable
 
+: divisor? ( x y -- ? )
+    mod 0 = ;
+
 : mod-inv ( x n -- y )
     [ nip ] [ gcd 1 = ] 2bi
     [ dup 0 < [ + ] [ nip ] if ]
@@ -198,7 +201,7 @@ M: real sin fsin ;
 
 GENERIC: sinh ( x -- y ) foldable
 
-M: complex sinh 
+M: complex sinh
     >float-rect
     [ [ fsinh ] [ fcos ] bi* * ]
     [ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;

From ca9fb1fcf1e68a1536bc0280f8a6f55281a84197 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 1 Apr 2009 21:53:18 -0400
Subject: [PATCH 074/135] Update usages of divisor? where appropriate

---
 basis/calendar/calendar.factor             | 8 ++++----
 basis/math/functions/functions-docs.factor | 6 +++---
 basis/math/primes/factors/factors.factor   | 4 ++--
 extra/project-euler/001/001.factor         | 4 ++--
 extra/project-euler/004/004.factor         | 6 +++---
 extra/project-euler/014/014.factor         | 6 +++---
 extra/project-euler/043/043.factor         | 6 +++---
 extra/project-euler/052/052.factor         | 7 +++----
 extra/project-euler/common/common.factor   | 5 ++---
 9 files changed, 25 insertions(+), 27 deletions(-)

diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index 104941ddb2..54741567bb 100644
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2007 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays kernel math math.functions namespaces sequences
-strings system vocabs.loader threads accessors combinators
-locals classes.tuple math.order summary combinators.short-circuit ;
+USING: accessors arrays classes.tuple combinators combinators.short-circuit
+    kernel locals math math.functions math.order namespaces sequences strings
+    summary system threads vocabs.loader ;
 IN: calendar
 
 HOOK: gmt-offset os ( -- hours minutes seconds )
@@ -136,7 +136,7 @@ CONSTANT: day-abbreviations3
 GENERIC: leap-year? ( obj -- ? )
 
 M: integer leap-year? ( year -- ? )
-    dup 100 mod zero? 400 4 ? mod zero? ;
+    dup 100 divisor? 400 4 ? divisor? ;
 
 M: timestamp leap-year? ( timestamp -- ? )
     year>> leap-year? ;
diff --git a/basis/math/functions/functions-docs.factor b/basis/math/functions/functions-docs.factor
index 02fcd5f4d9..f7d0d5a941 100644
--- a/basis/math/functions/functions-docs.factor
+++ b/basis/math/functions/functions-docs.factor
@@ -271,9 +271,9 @@ HELP: gcd
 { $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ;
 
 HELP: divisor?
-{ $values { "x" integer } { "y" integer } { "?" "a boolean" } }
-{ $description "Tests if " { $snippet "y" } " is a divisor of " { $snippet "x" } ". This is the same thing as saying " { $snippet "x" } " is divisible by " { $snippet "y" } "." }
-{ $notes "Returns t for both negative and positive divisors, as well as trivial and non-trivial divisors." } ;
+{ $values { "m" integer } { "n" integer } { "?" "a boolean" } }
+{ $description "Tests if " { $snippet "n" } " is a divisor of " { $snippet "m" } ". This is the same thing as asking if " { $snippet "m" } " is divisible by " { $snippet "n" } "." }
+{ $notes "Returns t for both negative and positive divisors, as well as for trivial and non-trivial divisors." } ;
 
 HELP: mod-inv
 { $values { "x" integer } { "n" integer } { "y" integer } }
diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor
index 199b72b7e1..9acc2b58c6 100644
--- a/basis/math/primes/factors/factors.factor
+++ b/basis/math/primes/factors/factors.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.primes sequences ;
+USING: arrays combinators kernel make math math.fucntions math.primes sequences ;
 IN: math.primes.factors
 
 <PRIVATE
@@ -11,7 +11,7 @@ IN: math.primes.factors
     swap ;
 
 : write-factor ( n d -- n' d' )
-    2dup mod zero? [
+    2dup divisor? [
         [ [ count-factor ] keep swap 2array , ] keep
         ! If the remainder is a prime number, increase d so that
         ! the caller stops looking for factors.
diff --git a/extra/project-euler/001/001.factor b/extra/project-euler/001/001.factor
index 68e1ff032a..20e08242c5 100644
--- a/extra/project-euler/001/001.factor
+++ b/extra/project-euler/001/001.factor
@@ -1,6 +1,6 @@
 ! Copyright (c) 2007, 2008 Aaron Schaefer, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math math.ranges sequences project-euler.common ;
+USING: kernel math math.functions math.ranges sequences project-euler.common ;
 IN: project-euler.001
 
 ! http://projecteuler.net/index.php?section=problems&id=1
@@ -53,7 +53,7 @@ PRIVATE>
 
 
 : euler001c ( -- answer )
-    1000 [ { 3 5 } [ mod 0 = ] with any? ] filter sum ;
+    1000 [ { 3 5 } [ divisor? ] with any? ] filter sum ;
 
 ! [ euler001c ] 100 ave-time
 ! 0 ms ave run time - 0.06 SD (100 trials)
diff --git a/extra/project-euler/004/004.factor b/extra/project-euler/004/004.factor
index ff62b4e181..fe09914d9f 100644
--- a/extra/project-euler/004/004.factor
+++ b/extra/project-euler/004/004.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2007 Aaron Schaefer, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables kernel math math.ranges project-euler.common sequences
-    sorting sets ;
+USING: hashtables kernel math math.functions math.ranges project-euler.common
+    sequences sorting sets ;
 IN: project-euler.004
 
 ! http://projecteuler.net/index.php?section=problems&id=4
@@ -21,7 +21,7 @@ IN: project-euler.004
 <PRIVATE
 
 : source-004 ( -- seq )
-    100 999 [a,b] [ 10 mod 0 = not ] filter ;
+    100 999 [a,b] [ 10 divisor? not ] filter ;
 
 : max-palindrome ( seq -- palindrome )
     natural-sort [ palindrome? ] find-last nip ;
diff --git a/extra/project-euler/014/014.factor b/extra/project-euler/014/014.factor
index a9a8dbce3f..b0305d5c39 100644
--- a/extra/project-euler/014/014.factor
+++ b/extra/project-euler/014/014.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2007 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel make math math.ranges
-sequences project-euler.common ;
+USING: combinators.short-circuit kernel make math math.functions math.ranges
+    sequences project-euler.common ;
 IN: project-euler.014
 
 ! http://projecteuler.net/index.php?section=problems&id=14
@@ -59,7 +59,7 @@ PRIVATE>
 <PRIVATE
 
 : worth-calculating? ( n -- ? )
-    1- 3 { [ mod 0 = ] [ / even? ] } 2&& ;
+    1- 3 { [ divisor? ] [ / even? ] } 2&& ;
 
 PRIVATE>
 
diff --git a/extra/project-euler/043/043.factor b/extra/project-euler/043/043.factor
index 7edcd14364..75241499e1 100644
--- a/extra/project-euler/043/043.factor
+++ b/extra/project-euler/043/043.factor
@@ -1,7 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math math.combinatorics math.parser
-    math.ranges project-euler.common sequences sets sorting ;
+USING: combinators.short-circuit kernel math math.functions math.combinatorics
+    math.parser math.ranges project-euler.common sequences sets sorting ;
 IN: project-euler.043
 
 ! http://projecteuler.net/index.php?section=problems&id=43
@@ -36,7 +36,7 @@ IN: project-euler.043
 <PRIVATE
 
 : subseq-divisible? ( n index seq -- ? )
-    [ 1- dup 3 + ] dip subseq 10 digits>integer swap mod zero? ;
+    [ 1- dup 3 + ] dip subseq 10 digits>integer swap divisor? ;
 
 : interesting? ( seq -- ? )
     {
diff --git a/extra/project-euler/052/052.factor b/extra/project-euler/052/052.factor
index 1b3b9ba1f1..c25b1adcc0 100644
--- a/extra/project-euler/052/052.factor
+++ b/extra/project-euler/052/052.factor
@@ -1,8 +1,7 @@
 ! Copyright (c) 2008 Aaron Schaefer.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators.short-circuit kernel math
-    project-euler.common sequences sorting
-    grouping ;
+USING: combinators.short-circuit kernel math math.functions
+    project-euler.common sequences sorting grouping ;
 IN: project-euler.052
 
 ! http://projecteuler.net/index.php?section=problems&id=52
@@ -31,7 +30,7 @@ IN: project-euler.052
     [ number>digits natural-sort ] map all-equal? ;
 
 : candidate? ( n -- ? )
-    { [ odd? ] [ 3 mod 0 = ] } 1&& ;
+    { [ odd? ] [ 3 divisor? ] } 1&& ;
 
 : next-all-same ( x n -- n )
     dup candidate? [
diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor
index 0ad3225e3e..ba8c81fbf4 100644
--- a/extra/project-euler/common/common.factor
+++ b/extra/project-euler/common/common.factor
@@ -44,7 +44,7 @@ IN: project-euler.common
 
 : (sum-divisors) ( n -- sum )
     dup sqrt >integer [1,b] [
-        [ 2dup mod 0 = [ 2dup / + , ] [ drop ] if ] each
+        [ 2dup divisor? [ 2dup / + , ] [ drop ] if ] each
         dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if
     ] { } make sum ;
 
@@ -120,7 +120,7 @@ PRIVATE>
     factor-2s dup [ 1+ ]
     [ perfect-square? -1 0 ? ]
     [ dup sqrt >fixnum [1,b] ] tri* [
-        dupd mod 0 = [ [ 2 + ] dip ] when
+        dupd divisor? [ [ 2 + ] dip ] when
     ] each drop * ;
 
 ! These transforms are for generating primitive Pythagorean triples
@@ -137,4 +137,3 @@ SYNTAX: SOLUTION:
     [ drop in get vocab (>>main) ]
     [ [ . ] swap prefix (( -- )) define-declared ]
     2bi ;
-

From ed9a63311cf1a9acf8d23f182650ac3efec760ba Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Wed, 1 Apr 2009 22:03:45 -0400
Subject: [PATCH 075/135] Fix typo and update a combinator usage in calendar

---
 basis/calendar/calendar.factor           | 2 +-
 basis/math/primes/factors/factors.factor | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/calendar/calendar.factor b/basis/calendar/calendar.factor
index 54741567bb..7a03fe4408 100644
--- a/basis/calendar/calendar.factor
+++ b/basis/calendar/calendar.factor
@@ -348,7 +348,7 @@ M: duration time-
     #! good for any date since October 15, 1582
     [
         dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
-        [ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
+        [ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
         [ 1+ 3 * 5 /i + ] keep 2 * +
     ] dip 1+ + 7 mod ;
 
diff --git a/basis/math/primes/factors/factors.factor b/basis/math/primes/factors/factors.factor
index 9acc2b58c6..278bf70b3d 100644
--- a/basis/math/primes/factors/factors.factor
+++ b/basis/math/primes/factors/factors.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2007-2009 Samuel Tardieu.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays combinators kernel make math math.fucntions math.primes sequences ;
+USING: arrays combinators kernel make math math.functions math.primes sequences ;
 IN: math.primes.factors
 
 <PRIVATE

From 318da06a71a837489d07123157ccbc291a678eec Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 22:05:12 -0500
Subject: [PATCH 076/135] ensure-port outputs a new URL instead of mutating its
 input

---
 basis/urls/urls-docs.factor | 5 ++---
 basis/urls/urls.factor      | 4 ++--
 2 files changed, 4 insertions(+), 5 deletions(-)

diff --git a/basis/urls/urls-docs.factor b/basis/urls/urls-docs.factor
index 707caf3188..eb8e452ca4 100644
--- a/basis/urls/urls-docs.factor
+++ b/basis/urls/urls-docs.factor
@@ -65,9 +65,8 @@ HELP: derive-url
 } ;
 
 HELP: ensure-port
-{ $values { "url" url } }
-{ $description "If the URL does not specify a port number, fill in the default for the URL's protocol. If the protocol is unknown, the port number is not changed." }
-{ $side-effects "url" }
+{ $values { "url" url } { "url'" url } }
+{ $description "If the URL does not specify a port number, create a new URL which is equal except the port number is set to the default for the URL's protocol. If the protocol is unknown, outputs an exact copy of the input URL." }
 { $examples
     { $example
         "USING: accessors prettyprint urls ;"
diff --git a/basis/urls/urls.factor b/basis/urls/urls.factor
index 38d0016d56..1e886ae3e2 100644
--- a/basis/urls/urls.factor
+++ b/basis/urls/urls.factor
@@ -175,8 +175,8 @@ PRIVATE>
     ] [ protocol>> ] bi
     secure-protocol? [ >secure-addr ] when ;
 
-: ensure-port ( url -- url )
-    dup protocol>> '[ _ protocol-port or ] change-port ;
+: ensure-port ( url -- url' )
+    clone dup protocol>> '[ _ protocol-port or ] change-port ;
 
 ! Literal syntax
 SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;

From 4dbb2aa491c2a691bcbd2abf5555a7c0ff28bea1 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Wed, 1 Apr 2009 22:24:49 -0500
Subject: [PATCH 077/135] Partial fix for pane selection

---
 basis/ui/gadgets/panes/panes.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index a6bd5c4e29..41e983eb28 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -75,7 +75,8 @@ M: pane gadget-selection ( pane -- string/f )
 GENERIC: draw-selection ( loc obj -- )
 
 : if-fits ( rect quot -- )
-    [ clip get over contains-rect? ] dip [ drop ] if ; inline
+    [ clip get origin get vneg offset-rect over contains-rect? ] dip
+    [ drop ] if ; inline
 
 M: gadget draw-selection ( loc gadget -- )
     swap offset-rect [

From 9bee1fe0041be56b814fe47d0cbe09173a8bdcda Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Wed, 1 Apr 2009 22:39:20 -0500
Subject: [PATCH 078/135] fix take-rest for out of bounds

---
 extra/html/parser/state/state-tests.factor |  6 ++++++
 extra/html/parser/state/state.factor       | 13 ++++++++++---
 2 files changed, 16 insertions(+), 3 deletions(-)

diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index 63916a3c1c..75db1a373e 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -93,3 +93,9 @@ IN: html.parser.state.tests
 
 [ "abcd e \\\"f g" ]
 [ "\"abcd e \\\"f g\"" <state-parser> CHAR: \ CHAR: " take-token* ] unit-test
+
+[ "" ]
+[ "" <state-parser> take-rest ] unit-test
+
+[ "" ]
+[ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 86adb0f914..b7936f6005 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -1,8 +1,8 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math kernel sequences accessors fry circular
-unicode.case unicode.categories locals combinators.short-circuit
-make combinators ;
+unicode.case ascii locals combinators.short-circuit
+make combinators io splitting ;
 
 IN: html.parser.state
 
@@ -74,8 +74,12 @@ TUPLE: state-parser sequence n ;
 : skip-whitespace ( state-parser -- state-parser )
     [ [ current blank? not ] take-until drop ] keep ;
 
+: take-rest-slice ( state-parser -- sequence/f )
+    [ sequence>> ] [ n>> ] bi
+    2dup [ length ] dip < [ 2drop f ] [ tail-slice ] if ; inline
+
 : take-rest ( state-parser -- sequence )
-    [ drop f ] take-until ; inline
+    [ take-rest-slice ] [ sequence>> like ] bi ;
 
 : take-until-object ( state-parser obj -- sequence )
     '[ current _ = ] take-until ;
@@ -111,3 +115,6 @@ TUPLE: state-parser sequence n ;
 
 : take-token ( state-parser -- string/f )
     CHAR: \ CHAR: " take-token* ;
+
+: write-full ( state-parser -- ) sequence>> write ;
+: write-rest ( state-parser -- ) take-rest write ;

From 4ef0344477d4619c5127579279395a2b74aa7289 Mon Sep 17 00:00:00 2001
From: Daniel Ehrenberg <littledan@pool-116-90.res.carleton.edu>
Date: Thu, 2 Apr 2009 01:12:09 -0500
Subject: [PATCH 079/135] Tabs are blank (better unicode whitespace support
 coming soon)

---
 basis/unicode/categories/categories-tests.factor | 5 +++++
 basis/unicode/categories/categories.factor       | 2 +-
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/basis/unicode/categories/categories-tests.factor b/basis/unicode/categories/categories-tests.factor
index 1e718cf9b7..0970df7ad8 100644
--- a/basis/unicode/categories/categories-tests.factor
+++ b/basis/unicode/categories/categories-tests.factor
@@ -12,3 +12,8 @@ IN: unicode.categories.tests
 [ "Lo" ] [ HEX: 3450 category ] unit-test
 [ "Lo" ] [ HEX: 4DB5 category ] unit-test
 [ "Cs" ] [ HEX: DD00 category ] unit-test
+[ t ] [ CHAR: \t blank? ] unit-test
+[ t ] [ CHAR: \s blank? ] unit-test
+[ t ] [ CHAR: \r blank? ] unit-test
+[ t ] [ CHAR: \n blank? ] unit-test
+[ f ] [ CHAR: a blank? ] unit-test
diff --git a/basis/unicode/categories/categories.factor b/basis/unicode/categories/categories.factor
index 126c03c869..4ca5c9a90e 100644
--- a/basis/unicode/categories/categories.factor
+++ b/basis/unicode/categories/categories.factor
@@ -3,7 +3,7 @@
 USING: unicode.categories.syntax sequences unicode.data ;
 IN: unicode.categories
 
-CATEGORY: blank Zs Zl Zp | "\r\n" member? ;
+CATEGORY: blank Zs Zl Zp | "\r\n\t" member? ;
 CATEGORY: letter Ll | "Other_Lowercase" property? ;
 CATEGORY: LETTER Lu | "Other_Uppercase" property? ;
 CATEGORY: Letter Lu Ll Lt Lm Lo Nl ;

From 2325710a4ff61ddbf3624e458e7dff391065622f Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 2 Apr 2009 01:17:36 -0500
Subject: [PATCH 080/135] beginnings of a c preprocessor -- needs #if, #elif,
 #else

---
 extra/c/preprocessor/authors.txt              |   1 +
 .../c/preprocessor/preprocessor-tests.factor  |  16 ++
 extra/c/preprocessor/preprocessor.factor      | 155 ++++++++++++++++++
 extra/c/tests/test1/README                    |   1 +
 extra/c/tests/test1/hi.h                      |   1 +
 extra/c/tests/test1/lo.h                      |   1 +
 extra/c/tests/test1/test1.c                   |   1 +
 extra/c/tests/test2/README                    |   1 +
 extra/c/tests/test2/test2.c                   |  17 ++
 extra/c/tests/test3/README                    |   1 +
 extra/c/tests/test3/test3.c                   |   1 +
 extra/c/tests/test4/test4.c                   |   2 +
 12 files changed, 198 insertions(+)
 create mode 100644 extra/c/preprocessor/authors.txt
 create mode 100644 extra/c/preprocessor/preprocessor-tests.factor
 create mode 100644 extra/c/preprocessor/preprocessor.factor
 create mode 100644 extra/c/tests/test1/README
 create mode 100644 extra/c/tests/test1/hi.h
 create mode 100644 extra/c/tests/test1/lo.h
 create mode 100644 extra/c/tests/test1/test1.c
 create mode 100644 extra/c/tests/test2/README
 create mode 100644 extra/c/tests/test2/test2.c
 create mode 100644 extra/c/tests/test3/README
 create mode 100644 extra/c/tests/test3/test3.c
 create mode 100644 extra/c/tests/test4/test4.c

diff --git a/extra/c/preprocessor/authors.txt b/extra/c/preprocessor/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/extra/c/preprocessor/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/extra/c/preprocessor/preprocessor-tests.factor b/extra/c/preprocessor/preprocessor-tests.factor
new file mode 100644
index 0000000000..d86b85a1b1
--- /dev/null
+++ b/extra/c/preprocessor/preprocessor-tests.factor
@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test c.preprocessor kernel accessors ;
+IN: c.preprocessor.tests
+
+[ "vocab:c/tests/test1/test1.c" start-preprocess-file ]
+[ include-nested-too-deeply? ] must-fail-with
+
+[ "yo\n\n\n\nyo4\n" ]
+[ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test
+
+[ "vocab:c/tests/test3/test3.c" start-preprocess-file ]
+[ "\"BOO\"" = ] must-fail-with
+
+[ V{ "\"omg\"" "\"lol\"" } ]
+[ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test
diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor
new file mode 100644
index 0000000000..89292eb74b
--- /dev/null
+++ b/extra/c/preprocessor/preprocessor.factor
@@ -0,0 +1,155 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: html.parser.state io io.encodings.utf8 io.files
+io.streams.string kernel combinators accessors io.pathnames
+fry sequences arrays locals namespaces io.directories
+assocs math splitting make ;
+IN: c.preprocessor
+
+: initial-library-paths ( -- seq )
+    V{ "/usr/include" } clone ;
+
+TUPLE: preprocessor-state library-paths symbol-table
+include-nesting include-nesting-max processing-disabled?
+ifdef-nesting warnings ;
+
+: <preprocessor-state> ( -- preprocessor-state )
+    preprocessor-state new
+        initial-library-paths >>library-paths
+        H{ } clone >>symbol-table
+        0 >>include-nesting
+        200 >>include-nesting-max
+        0 >>ifdef-nesting
+        V{ } clone >>warnings ;
+
+DEFER: preprocess-file
+
+ERROR: unknown-c-preprocessor state-parser name ;
+
+ERROR: bad-include-line line ;
+
+ERROR: header-file-missing path ;
+
+:: read-standard-include ( preprocessor-state path -- )
+    preprocessor-state dup library-paths>>
+    [ path append-path exists? ] find nip
+    [
+        dup [
+            path append-path
+            preprocess-file
+        ] with-directory
+    ] [
+        ! path header-file-missing
+        drop
+    ] if* ;
+
+:: read-local-include ( preprocessor-state path -- )
+    current-directory get path append-path dup :> full-path
+    dup exists? [
+        [ preprocessor-state ] dip preprocess-file
+    ] [
+        ! full-path header-file-missing
+        drop
+    ] if ;
+
+: handle-include ( preprocessor-state state-parser -- )
+    skip-whitespace advance dup previous {
+        { CHAR: < [ CHAR: > take-until-object read-standard-include ] }
+        { CHAR: " [ CHAR: " take-until-object read-local-include ] }
+        [ bad-include-line ]
+    } case ;
+
+: (readlns) ( -- )
+    readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
+
+: readlns ( -- string ) [ (readlns) ] { } make concat ;
+
+: handle-define ( preprocessor-state state-parser -- )
+    [ take-token ] [ take-rest ] bi 
+    "\\" ?tail [ readlns append ] when
+    spin symbol-table>> set-at ;
+
+: handle-undef ( preprocessor-state state-parser -- )
+    take-token swap symbol-table>> delete-at ;
+
+: handle-ifdef ( preprocessor-state state-parser -- )
+    [ [ 1 + ] change-ifdef-nesting ] dip
+    take-token over symbol-table>> key?
+    [ drop ] [ t >>processing-disabled? drop ] if ;
+
+: handle-ifndef ( preprocessor-state state-parser -- )
+    [ [ 1 + ] change-ifdef-nesting ] dip
+    take-token over symbol-table>> key?
+    [ t >>processing-disabled? drop ]
+    [ drop ] if ; 
+
+: handle-endif ( preprocessor-state state-parser -- )
+    drop [ 1 - ] change-ifdef-nesting drop ;
+
+: handle-error ( preprocessor-state state-parser -- )
+    skip-whitespace
+    nip take-rest throw ;
+
+: handle-warning ( preprocessor-state state-parser -- )
+    skip-whitespace
+    take-rest swap warnings>> push ;
+
+: parse-directive ( preprocessor-state state-parser string -- )
+    {
+        { "warning" [ handle-warning ] }
+        { "error" [ handle-error ] }
+        { "include" [ handle-include ] }
+        { "define" [ handle-define ] }
+        { "undef" [ handle-undef ] }
+        { "ifdef" [ handle-ifdef ] }
+        { "ifndef" [ handle-ifndef ] }
+        { "endif" [ handle-endif ] }
+        { "if" [ 2drop ] }
+        { "elif" [ 2drop ] }
+        { "else" [ 2drop ] }
+        { "pragma" [ 2drop ] }
+        { "include_next" [ 2drop ] }
+        [ unknown-c-preprocessor ]
+    } case ;
+
+: parse-directive-line ( preprocessor-state state-parser -- )
+    advance dup take-token
+    pick processing-disabled?>> [
+        "endif" = [
+            drop f >>processing-disabled?
+            [ 1 - ] change-ifdef-nesting
+            drop
+         ] [ 2drop ] if
+    ] [
+        parse-directive
+    ] if ;
+
+: preprocess-line ( preprocessor-state state-parser -- )
+    skip-whitespace dup current CHAR: # =
+    [ parse-directive-line ]
+    [ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
+
+: preprocess-lines ( preprocessor-state -- )
+    readln 
+    [ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
+    [ drop ] if* ;
+
+ERROR: include-nested-too-deeply ;
+
+: check-nesting ( preprocessor-state -- preprocessor-state )
+    [ 1 + ] change-include-nesting
+    dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
+        include-nested-too-deeply
+    ] when ;
+
+: preprocess-file ( preprocessor-state path -- )
+    [ check-nesting ] dip
+    [ utf8 [ preprocess-lines ] with-file-reader ]
+    [ drop [ 1 - ] change-include-nesting drop ] 2bi ;
+
+: start-preprocess-file ( path -- preprocessor-state string )
+    dup parent-directory [
+        [
+            [ <preprocessor-state> dup ] dip preprocess-file
+        ] with-string-writer
+    ] with-directory ;
diff --git a/extra/c/tests/test1/README b/extra/c/tests/test1/README
new file mode 100644
index 0000000000..99873133b2
--- /dev/null
+++ b/extra/c/tests/test1/README
@@ -0,0 +1 @@
+Tests if the preprocessor bails on an infinite loop caused by mutually recursive #include lines.
diff --git a/extra/c/tests/test1/hi.h b/extra/c/tests/test1/hi.h
new file mode 100644
index 0000000000..c9f337c47a
--- /dev/null
+++ b/extra/c/tests/test1/hi.h
@@ -0,0 +1 @@
+#include "lo.h"
diff --git a/extra/c/tests/test1/lo.h b/extra/c/tests/test1/lo.h
new file mode 100644
index 0000000000..d59fdd272e
--- /dev/null
+++ b/extra/c/tests/test1/lo.h
@@ -0,0 +1 @@
+#include "hi.h"
diff --git a/extra/c/tests/test1/test1.c b/extra/c/tests/test1/test1.c
new file mode 100644
index 0000000000..d59fdd272e
--- /dev/null
+++ b/extra/c/tests/test1/test1.c
@@ -0,0 +1 @@
+#include "hi.h"
diff --git a/extra/c/tests/test2/README b/extra/c/tests/test2/README
new file mode 100644
index 0000000000..4244828197
--- /dev/null
+++ b/extra/c/tests/test2/README
@@ -0,0 +1 @@
+Tests whether #define and #ifdef/#endif work in the positive case.
diff --git a/extra/c/tests/test2/test2.c b/extra/c/tests/test2/test2.c
new file mode 100644
index 0000000000..4cc4191db1
--- /dev/null
+++ b/extra/c/tests/test2/test2.c
@@ -0,0 +1,17 @@
+#define YO
+#ifdef YO
+yo
+#endif
+
+#define YO2
+#ifndef YO2
+yo2
+#endif
+
+#ifdef YO3
+yo3
+#endif
+
+#ifndef YO4
+yo4
+#endif
diff --git a/extra/c/tests/test3/README b/extra/c/tests/test3/README
new file mode 100644
index 0000000000..4244828197
--- /dev/null
+++ b/extra/c/tests/test3/README
@@ -0,0 +1 @@
+Tests whether #define and #ifdef/#endif work in the positive case.
diff --git a/extra/c/tests/test3/test3.c b/extra/c/tests/test3/test3.c
new file mode 100644
index 0000000000..8d08e836b2
--- /dev/null
+++ b/extra/c/tests/test3/test3.c
@@ -0,0 +1 @@
+#error "BOO"
diff --git a/extra/c/tests/test4/test4.c b/extra/c/tests/test4/test4.c
new file mode 100644
index 0000000000..5acd20da67
--- /dev/null
+++ b/extra/c/tests/test4/test4.c
@@ -0,0 +1,2 @@
+#warning "omg"
+#warning "lol"

From 2aaeb62c4e9d2968c4284c593bc841475f21d6e3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 2 Apr 2009 01:17:55 -0500
Subject: [PATCH 081/135] Fix up 'demos' vocab

---
 basis/help/tips/tips-docs.factor |  2 ++
 extra/demos/demos.factor         | 18 ++++++------------
 2 files changed, 8 insertions(+), 12 deletions(-)

diff --git a/basis/help/tips/tips-docs.factor b/basis/help/tips/tips-docs.factor
index 750eff7a52..48ed65b318 100644
--- a/basis/help/tips/tips-docs.factor
+++ b/basis/help/tips/tips-docs.factor
@@ -20,6 +20,8 @@ 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." ;
 
+TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $code "\"demos\" run" } ;
+
 HELP: TIP:
 { $syntax "TIP: content ;" }
 { $values { "content" "a markup element" } }
diff --git a/extra/demos/demos.factor b/extra/demos/demos.factor
index 8c55945105..dfd73f1236 100644
--- a/extra/demos/demos.factor
+++ b/extra/demos/demos.factor
@@ -1,22 +1,16 @@
-
-USING: kernel fry sequences
-       vocabs.loader help.vocabs
-       ui ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.scrollers
-       ui.tools.listener
-       accessors ;
-
+USING: kernel fry sequences vocabs.loader help.vocabs ui
+ui.gadgets ui.gadgets.buttons ui.gadgets.packs ui.gadgets.borders
+ui.gadgets.scrollers ui.tools.listener accessors ;
 IN: demos
 
 : demo-vocabs ( -- seq ) "demos" tagged [ second ] map concat [ name>> ] map ;
 
 : <run-vocab-button> ( vocab-name -- button )
-  dup '[ drop [ _ run ] call-listener ] <border-button> ;
+    dup '[ drop [ _ run ] \ run call-listener ] <border-button> ;
 
 : <demo-runner> ( -- gadget )
-  <pile> 1 >>fill demo-vocabs [ <run-vocab-button> add-gadget ] each ;
+    <pile> 1 >>fill { 2 2 } >>gap demo-vocabs [ <run-vocab-button> add-gadget ] each ;
 
-: demos ( -- ) [ <demo-runner> <scroller> "Demos" open-window ] with-ui ;
-
-! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+: demos ( -- ) [ <demo-runner> { 2 2 } <border> <scroller> "Demos" open-window ] with-ui ;
 
 MAIN: demos
\ No newline at end of file

From 7c7742cafa7089c2f05837207597e0e0a9bee5b1 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 2 Apr 2009 01:18:53 -0500
Subject: [PATCH 082/135] use unicode instead of ascii again

---
 extra/html/parser/state/state.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index b7936f6005..5f845ce810 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2009 Daniel Ehrenberg
 ! See http://factorcode.org/license.txt for BSD license.
 USING: namespaces math kernel sequences accessors fry circular
-unicode.case ascii locals combinators.short-circuit
+unicode.case unicode.categories locals combinators.short-circuit
 make combinators io splitting ;
 
 IN: html.parser.state

From 4f19f9b2c1bae4b97088369bdcb3e9f034a4522b Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 2 Apr 2009 09:09:09 -0500
Subject: [PATCH 083/135] Fix UI pane selection

---
 basis/ui/gadgets/gadgets.factor     |   3 +-
 basis/ui/gadgets/panes/panes.factor |  34 ++--------
 basis/ui/render/render.factor       | 101 ++++++++++++++++++----------
 basis/ui/traverse/traverse.factor   |  14 +++-
 4 files changed, 88 insertions(+), 64 deletions(-)

diff --git a/basis/ui/gadgets/gadgets.factor b/basis/ui/gadgets/gadgets.factor
index adcfdfb00d..bc07006d62 100644
--- a/basis/ui/gadgets/gadgets.factor
+++ b/basis/ui/gadgets/gadgets.factor
@@ -11,6 +11,7 @@ CONSTANT: horizontal { 1 0 }
 CONSTANT: vertical { 0 1 }
 
 TUPLE: gadget < rect
+id
 pref-dim
 parent
 children
@@ -28,7 +29,7 @@ model ;
 
 M: gadget equal? 2drop f ;
 
-M: gadget hashcode* drop gadget hashcode* ;
+M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
 
 M: gadget model-changed 2drop ;
 
diff --git a/basis/ui/gadgets/panes/panes.factor b/basis/ui/gadgets/panes/panes.factor
index 41e983eb28..6f6e7ee95f 100644
--- a/basis/ui/gadgets/panes/panes.factor
+++ b/basis/ui/gadgets/panes/panes.factor
@@ -49,13 +49,13 @@ M: pane-stream stream-element-type drop +character+ ;
 : pane-caret&mark ( pane -- caret mark )
     [ caret>> ] [ mark>> ] bi ; inline
 
-: selected-children ( pane -- seq )
+: selected-subtree ( pane -- seq )
     [ pane-caret&mark sort-pair ] keep gadget-subtree ;
 
 M: pane gadget-selection? pane-caret&mark and ;
 
 M: pane gadget-selection ( pane -- string/f )
-    selected-children gadget-text ;
+    selected-subtree gadget-text ;
 
 : init-prototype ( pane -- pane )
     <shelf> +baseline+ >>align >>prototype ; inline
@@ -72,32 +72,12 @@ M: pane gadget-selection ( pane -- string/f )
     [ >>last-line ] [ 1 track-add ] bi
     dup prepare-last-line ; inline
 
-GENERIC: draw-selection ( loc obj -- )
-
-: if-fits ( rect quot -- )
-    [ clip get origin get vneg offset-rect over contains-rect? ] dip
-    [ drop ] if ; inline
-
-M: gadget draw-selection ( loc gadget -- )
-    swap offset-rect [
-        rect-bounds gl-fill-rect
-    ] if-fits ;
-
-M: node draw-selection ( loc node -- )
-    2dup value>> swap offset-rect [
-        drop 2dup
-        [ value>> loc>> v+ ] keep
-        children>> [ draw-selection ] with each
-    ] if-fits 2drop ;
-
-M: pane draw-gadget*
+M: pane selected-children
     dup gadget-selection? [
-        [ selection-color>> gl-color ]
-        [
-            [ loc>> vneg ] keep selected-children
-            [ draw-selection ] with each
-        ] bi
-    ] [ drop ] if ;
+        [ selected-subtree leaves ]
+        [ selection-color>> ]
+        bi
+    ] [ drop f f ] if ;
 
 : scroll-pane ( pane -- )
     dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
diff --git a/basis/ui/render/render.factor b/basis/ui/render/render.factor
index 4c8f7c24e5..09c26fd271 100755
--- a/basis/ui/render/render.factor
+++ b/basis/ui/render/render.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: math.rectangles math.vectors namespaces kernel accessors
-combinators sequences opengl opengl.gl opengl.glu colors
+assocs combinators sequences opengl opengl.gl opengl.glu colors
 colors.constants ui.gadgets ui.pens ;
 IN: ui.render
 
@@ -55,21 +55,57 @@ SYMBOL: origin
 
 GENERIC: draw-children ( gadget -- )
 
+! For gadget selection
+SYMBOL: selected-gadgets
+
+SYMBOL: selection-background
+
+GENERIC: selected-children ( gadget -- assoc/f selection-background )
+
+M: gadget selected-children drop f f ;
+
+! For text rendering
+SYMBOL: background
+
+SYMBOL: foreground
+
+GENERIC: gadget-background ( gadget -- color )
+
+M: gadget gadget-background dup interior>> pen-background ;
+
+GENERIC: gadget-foreground ( gadget -- color )
+
+M: gadget gadget-foreground dup interior>> pen-foreground ;
+
+<PRIVATE
+
+: draw-selection-background ( gadget -- )
+    selection-background get background set
+    selection-background get gl-color
+    [ { 0 0 } ] dip dim>> gl-fill-rect ;
+
+: draw-standard-background ( object -- )
+    dup interior>> dup [ draw-interior ] [ 2drop ] if ;
+
+: draw-background ( gadget -- )
+    origin get [
+        [
+            dup selected-gadgets get key?
+            [ draw-selection-background ]
+            [ draw-standard-background ] if
+        ] [ draw-gadget* ] bi
+    ] with-translation ;
+
+: draw-border ( object -- )
+    dup boundary>> dup [
+        origin get [ draw-boundary ] with-translation
+    ] [ 2drop ] if ;
+
+PRIVATE>
+
 : (draw-gadget) ( gadget -- )
     dup loc>> origin get v+ origin [
-        [
-            origin get [
-                [ dup interior>> dup [ draw-interior ] [ 2drop ] if ]
-                [ draw-gadget* ]
-                bi
-            ] with-translation
-        ]
-        [ draw-children ]
-        [
-            dup boundary>> dup [
-                origin get [ draw-boundary ] with-translation
-            ] [ 2drop ] if
-        ] tri
+        [ draw-background ] [ draw-children ] [ draw-border ] tri
     ] with-variable ;
 
 : >absolute ( rect -- rect )
@@ -88,27 +124,24 @@ GENERIC: draw-children ( gadget -- )
         [ [ (draw-gadget) ] with-clipping ]
     } cond ;
 
-! For text rendering
-SYMBOL: background
-
-SYMBOL: foreground
-
-GENERIC: gadget-background ( gadget -- color )
-
-M: gadget gadget-background dup interior>> pen-background ;
-
-GENERIC: gadget-foreground ( gadget -- color )
-
-M: gadget gadget-foreground dup interior>> pen-foreground ;
-
 M: gadget draw-children
-    [ visible-children ]
-    [ gadget-background ]
-    [ gadget-foreground ] tri [
-        [ foreground set ] when*
-        [ background set ] when*
-        [ draw-gadget ] each
-    ] with-scope ;
+    dup children>> [
+        {
+            [ visible-children ]
+            [ selected-children ]
+            [ gadget-background ]
+            [ gadget-foreground ]
+        } cleave [
+            
+            {
+                [ [ selected-gadgets set ] when* ]
+                [ [ selection-background set ] when* ]
+                [ [ background set ] when* ]
+                [ [ foreground set ] when* ]
+            } spread
+            [ draw-gadget ] each
+        ] with-scope
+    ] [ drop ] if ;
 
 CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
 
diff --git a/basis/ui/traverse/traverse.factor b/basis/ui/traverse/traverse.factor
index 63c656205c..9df084210d 100644
--- a/basis/ui/traverse/traverse.factor
+++ b/basis/ui/traverse/traverse.factor
@@ -1,7 +1,7 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors namespaces make sequences kernel math arrays io
-ui.gadgets generic combinators ;
+ui.gadgets generic combinators fry sets ;
 IN: ui.traverse
 
 TUPLE: node value children ;
@@ -85,3 +85,13 @@ M: node gadget-text*
 
 : gadget-at-path ( parent path -- gadget )
     [ swap nth-gadget ] each ;
+
+GENERIC# leaves* 1 ( tree assoc -- )
+
+M: node leaves* [ children>> ] dip leaves* ;
+
+M: array leaves* '[ _ leaves* ] each ;
+
+M: gadget leaves* conjoin ;
+
+: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;
\ No newline at end of file

From d6e646389c32e9f66981ba9541c7af9b1d5a0c17 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 2 Apr 2009 11:58:35 -0400
Subject: [PATCH 084/135] Solution to Project Euler problem 49

---
 extra/project-euler/049/049-tests.factor |  4 ++
 extra/project-euler/049/049.factor       | 74 ++++++++++++++++++++++++
 extra/project-euler/project-euler.factor | 16 ++---
 3 files changed, 86 insertions(+), 8 deletions(-)
 create mode 100644 extra/project-euler/049/049-tests.factor
 create mode 100644 extra/project-euler/049/049.factor

diff --git a/extra/project-euler/049/049-tests.factor b/extra/project-euler/049/049-tests.factor
new file mode 100644
index 0000000000..679647ac18
--- /dev/null
+++ b/extra/project-euler/049/049-tests.factor
@@ -0,0 +1,4 @@
+USING: project-euler.049 tools.test ;
+IN: project-euler.049.tests
+
+[ 296962999629 ] [ euler049 ] unit-test
diff --git a/extra/project-euler/049/049.factor b/extra/project-euler/049/049.factor
new file mode 100644
index 0000000000..2fa51fa221
--- /dev/null
+++ b/extra/project-euler/049/049.factor
@@ -0,0 +1,74 @@
+! Copyright (c) 2009 Aaron Schaefer.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays byte-arrays fry hints kernel math math.combinatorics
+    math.functions math.parser math.primes project-euler.common sequences sets ;
+IN: project-euler.049
+
+! http://projecteuler.net/index.php?section=problems&id=49
+
+! DESCRIPTION
+! -----------
+
+! The arithmetic sequence, 1487, 4817, 8147, in which each of the terms
+! increases by 3330, is unusual in two ways: (i) each of the three terms are
+! prime, and, (ii) each of the 4-digit numbers are permutations of one another.
+
+! There are no arithmetic sequences made up of three 1-, 2-, or 3-digit primes,
+! exhibiting this property, but there is one other 4-digit increasing sequence.
+
+! What 12-digit number do you form by concatenating the three terms in this
+! sequence?
+
+
+! SOLUTION
+! --------
+
+<PRIVATE
+
+: count-digits ( n -- byte-array )
+    10 <byte-array> [
+        '[ 10 /mod _ [ 1+ ] change-nth dup 0 > ] loop drop
+    ] keep ;
+
+HINTS: count-digits fixnum ;
+
+: permutations? ( n m -- ? )
+    [ count-digits ] bi@ = ;
+
+: collect-permutations ( seq -- seq )
+    [ V{ } clone ] [ dup ] bi* [
+        dupd '[ _ permutations? ] filter
+        [ diff ] keep pick push
+    ] each drop ;
+
+: potential-sequences ( -- seq )
+    1000 9999 primes-between
+    collect-permutations [ length 3 > ] filter ;
+
+: arithmetic-terms ( m n -- seq )
+    2dup [ swap - ] keep + 3array ;
+
+: (find-unusual-terms) ( n seq -- seq/f )
+    [ [ arithmetic-terms ] with map ] keep
+    '[ _ [ peek ] dip member? ] find nip ;
+
+: find-unusual-terms ( seq -- seq/? )
+    unclip-slice over (find-unusual-terms) [
+        nip
+    ] [
+        dup length 3 >= [ find-unusual-terms ] [ drop f ] if
+    ] if* ;
+
+: 4digit-concat ( seq -- str )
+    0 [ [ 10000 * ] dip + ] reduce ;
+
+PRIVATE>
+
+: euler049 ( -- answer )
+    potential-sequences [ find-unusual-terms ] map sift
+    [ { 1487 4817 8147 } = not ] find nip 4digit-concat ;
+
+! [ euler049 ] 100 ave-time
+! 206 ms ave run time - 10.25 SD (100 trials)
+
+SOLUTION: euler049
diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor
index 3d10dbcfbd..1e1da38a3f 100644
--- a/extra/project-euler/project-euler.factor
+++ b/extra/project-euler/project-euler.factor
@@ -14,14 +14,14 @@ USING: definitions io io.files io.pathnames kernel math math.parser
     project-euler.037 project-euler.038 project-euler.039 project-euler.040
     project-euler.041 project-euler.042 project-euler.043 project-euler.044
     project-euler.045 project-euler.046 project-euler.047 project-euler.048
-    project-euler.052 project-euler.053 project-euler.055 project-euler.056
-    project-euler.057 project-euler.059 project-euler.067 project-euler.071
-    project-euler.073 project-euler.075 project-euler.076 project-euler.079
-    project-euler.092 project-euler.097 project-euler.099 project-euler.100
-    project-euler.116 project-euler.117 project-euler.134 project-euler.148
-    project-euler.150 project-euler.151 project-euler.164 project-euler.169
-    project-euler.173 project-euler.175 project-euler.186 project-euler.190
-    project-euler.203 project-euler.215 ;
+    project-euler.049 project-euler.052 project-euler.053 project-euler.055
+    project-euler.056 project-euler.057 project-euler.059 project-euler.067
+    project-euler.071 project-euler.073 project-euler.075 project-euler.076
+    project-euler.079 project-euler.092 project-euler.097 project-euler.099
+    project-euler.100 project-euler.116 project-euler.117 project-euler.134
+    project-euler.148 project-euler.150 project-euler.151 project-euler.164
+    project-euler.169 project-euler.173 project-euler.175 project-euler.186
+    project-euler.190 project-euler.203 project-euler.215 ;
 IN: project-euler
 
 <PRIVATE

From 59145c06721394869ad933555ec14f48d0d69433 Mon Sep 17 00:00:00 2001
From: Aaron Schaefer <aaron@elasticdog.com>
Date: Thu, 2 Apr 2009 12:10:51 -0400
Subject: [PATCH 085/135] Minor typo in solution for PE problem 49

---
 extra/project-euler/049/049.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/project-euler/049/049.factor b/extra/project-euler/049/049.factor
index 2fa51fa221..15dd7ed6d2 100644
--- a/extra/project-euler/049/049.factor
+++ b/extra/project-euler/049/049.factor
@@ -43,7 +43,7 @@ HINTS: count-digits fixnum ;
 
 : potential-sequences ( -- seq )
     1000 9999 primes-between
-    collect-permutations [ length 3 > ] filter ;
+    collect-permutations [ length 3 >= ] filter ;
 
 : arithmetic-terms ( m n -- seq )
     2dup [ swap - ] keep + 3array ;

From 6399f4bc1a297d13285c108c98f20c98660ae12f Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 2 Apr 2009 11:39:18 -0500
Subject: [PATCH 086/135] handle defines better, save all
 #if/#elif/#else/#pragma/#include_next. next step: tokenizing and macro
 replacement

---
 .../c/preprocessor/preprocessor-tests.factor  | 12 +++-
 extra/c/preprocessor/preprocessor.factor      | 62 +++++++++++++++----
 2 files changed, 61 insertions(+), 13 deletions(-)

diff --git a/extra/c/preprocessor/preprocessor-tests.factor b/extra/c/preprocessor/preprocessor-tests.factor
index d86b85a1b1..ba0531dfe7 100644
--- a/extra/c/preprocessor/preprocessor-tests.factor
+++ b/extra/c/preprocessor/preprocessor-tests.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test c.preprocessor kernel accessors ;
+USING: tools.test c.preprocessor kernel accessors multiline ;
 IN: c.preprocessor.tests
 
 [ "vocab:c/tests/test1/test1.c" start-preprocess-file ]
@@ -9,8 +9,18 @@ IN: c.preprocessor.tests
 [ "yo\n\n\n\nyo4\n" ]
 [ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test
 
+/*
 [ "vocab:c/tests/test3/test3.c" start-preprocess-file ]
 [ "\"BOO\"" = ] must-fail-with
+*/
 
 [ V{ "\"omg\"" "\"lol\"" } ]
 [ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test
+
+
+/*
+f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1); 
+f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1); 
+int i[] = { 1, 23, 4, 5, }; 
+char c[2][6] = { "hello", "" }; 
+*/
diff --git a/extra/c/preprocessor/preprocessor.factor b/extra/c/preprocessor/preprocessor.factor
index 89292eb74b..f7cd10a0e9 100644
--- a/extra/c/preprocessor/preprocessor.factor
+++ b/extra/c/preprocessor/preprocessor.factor
@@ -3,24 +3,41 @@
 USING: html.parser.state io io.encodings.utf8 io.files
 io.streams.string kernel combinators accessors io.pathnames
 fry sequences arrays locals namespaces io.directories
-assocs math splitting make ;
+assocs math splitting make unicode.categories
+combinators.short-circuit ;
 IN: c.preprocessor
 
 : initial-library-paths ( -- seq )
     V{ "/usr/include" } clone ;
 
+: initial-symbol-table ( -- hashtable )
+    H{
+        { "__APPLE__" "" }
+        { "__amd64__" "" }
+        { "__x86_64__" "" }
+    } clone ;
+
 TUPLE: preprocessor-state library-paths symbol-table
 include-nesting include-nesting-max processing-disabled?
-ifdef-nesting warnings ;
+ifdef-nesting warnings errors
+pragmas
+include-nexts
+ifs elifs elses ;
 
 : <preprocessor-state> ( -- preprocessor-state )
     preprocessor-state new
         initial-library-paths >>library-paths
-        H{ } clone >>symbol-table
+        initial-symbol-table >>symbol-table
         0 >>include-nesting
         200 >>include-nesting-max
         0 >>ifdef-nesting
-        V{ } clone >>warnings ;
+        V{ } clone >>warnings
+        V{ } clone >>errors
+        V{ } clone >>pragmas
+        V{ } clone >>include-nexts
+        V{ } clone >>ifs
+        V{ } clone >>elifs
+        V{ } clone >>elses ;
 
 DEFER: preprocess-file
 
@@ -64,8 +81,13 @@ ERROR: header-file-missing path ;
 
 : readlns ( -- string ) [ (readlns) ] { } make concat ;
 
+: take-define-identifier ( state-parser -- string )
+    skip-whitespace
+    [ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
+
 : handle-define ( preprocessor-state state-parser -- )
-    [ take-token ] [ take-rest ] bi 
+    [ take-define-identifier ]
+    [ skip-whitespace take-rest ] bi 
     "\\" ?tail [ readlns append ] when
     spin symbol-table>> set-at ;
 
@@ -86,9 +108,25 @@ ERROR: header-file-missing path ;
 : handle-endif ( preprocessor-state state-parser -- )
     drop [ 1 - ] change-ifdef-nesting drop ;
 
+: handle-if ( preprocessor-state state-parser -- )
+    [ [ 1 + ] change-ifdef-nesting ] dip
+    skip-whitespace take-rest swap ifs>> push ;
+
+: handle-elif ( preprocessor-state state-parser -- )
+    skip-whitespace take-rest swap elifs>> push ;
+
+: handle-else ( preprocessor-state state-parser -- )
+    skip-whitespace take-rest swap elses>> push ;
+
+: handle-pragma ( preprocessor-state state-parser -- )
+    skip-whitespace take-rest swap pragmas>> push ;
+
+: handle-include-next ( preprocessor-state state-parser -- )
+    skip-whitespace take-rest swap include-nexts>> push ;
+
 : handle-error ( preprocessor-state state-parser -- )
-    skip-whitespace
-    nip take-rest throw ;
+    skip-whitespace take-rest swap errors>> push ;
+    ! nip take-rest throw ;
 
 : handle-warning ( preprocessor-state state-parser -- )
     skip-whitespace
@@ -104,11 +142,11 @@ ERROR: header-file-missing path ;
         { "ifdef" [ handle-ifdef ] }
         { "ifndef" [ handle-ifndef ] }
         { "endif" [ handle-endif ] }
-        { "if" [ 2drop ] }
-        { "elif" [ 2drop ] }
-        { "else" [ 2drop ] }
-        { "pragma" [ 2drop ] }
-        { "include_next" [ 2drop ] }
+        { "if" [ handle-if ] }
+        { "elif" [ handle-elif ] }
+        { "else" [ handle-else ] }
+        { "pragma" [ handle-pragma ] }
+        { "include_next" [ handle-include-next ] }
         [ unknown-c-preprocessor ]
     } case ;
 

From e841308bf6af017ba9aadbdd276cf1ad7ecfa99c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 2 Apr 2009 11:40:15 -0500
Subject: [PATCH 087/135] adding some preprocessor test files

---
 extra/c/tests/test5/test5.c |  3 +++
 extra/c/tests/test6/test6.c |  1 +
 extra/c/tests/test7/test7.c | 19 +++++++++++++++++++
 extra/c/tests/test8/test8.c | 15 +++++++++++++++
 extra/c/tests/test9/test9.c |  4 ++++
 5 files changed, 42 insertions(+)
 create mode 100644 extra/c/tests/test5/test5.c
 create mode 100644 extra/c/tests/test6/test6.c
 create mode 100644 extra/c/tests/test7/test7.c
 create mode 100644 extra/c/tests/test8/test8.c
 create mode 100644 extra/c/tests/test9/test9.c

diff --git a/extra/c/tests/test5/test5.c b/extra/c/tests/test5/test5.c
new file mode 100644
index 0000000000..4c169640ef
--- /dev/null
+++ b/extra/c/tests/test5/test5.c
@@ -0,0 +1,3 @@
+#define TABSIZE 100
+
+int table[TABSIZE];
diff --git a/extra/c/tests/test6/test6.c b/extra/c/tests/test6/test6.c
new file mode 100644
index 0000000000..3b0353a518
--- /dev/null
+++ b/extra/c/tests/test6/test6.c
@@ -0,0 +1 @@
+#define max(a, b) ((a) > (b) ? (a) : (b))
diff --git a/extra/c/tests/test7/test7.c b/extra/c/tests/test7/test7.c
new file mode 100644
index 0000000000..4d5e66ba24
--- /dev/null
+++ b/extra/c/tests/test7/test7.c
@@ -0,0 +1,19 @@
+#define x 3 
+#define f(a) f(x * (a)) 
+#undef x 
+#define x 2 
+#define g f 
+#define z z[0] 
+#define h g(~ 
+#define m(a) a(w) 
+#define w 0,1 
+#define t(a) a 
+#define p() int 
+#define q(x) x 
+#define r(x,y) x ## y 
+#define str(x) # x 
+f(y+1) + f(f(z)) % t(t(g)(0) + t)(1); 
+g(x+(3,4)-w) | h 5) & m 
+(f)^m(m); 
+p() i[q()] = { q(1), r(2,3), r(4,), r(,5), r(,) }; 
+char c[2][6] = { str(hello), str() }; 
diff --git a/extra/c/tests/test8/test8.c b/extra/c/tests/test8/test8.c
new file mode 100644
index 0000000000..bc1e27348d
--- /dev/null
+++ b/extra/c/tests/test8/test8.c
@@ -0,0 +1,15 @@
+#define str(s) #s 
+#define xstr(s) str(s) 
+#define debug(s, t) printf("x" # s "= %d, x" # t "= %s", \ 
+x ## s, x ## t) 
+#define INCFILE(n) vers ## n 
+#define glue(a, b) a## b 
+#define xglue(a, b) glue(a, b) 
+#define HIGHLOW "hello" 
+#define LOW LOW ", world" 
+debug(1, 2); 
+fputs(str(strncmp("abc\0d", "abc", '\4') //this goes away 
+== 0) str(: @\n), s); 
+#include xstr(INCFILE(2).h) 
+glue(HIGH, LOW); 
+xglue(HIGH, LOW) 
diff --git a/extra/c/tests/test9/test9.c b/extra/c/tests/test9/test9.c
new file mode 100644
index 0000000000..86940cfbea
--- /dev/null
+++ b/extra/c/tests/test9/test9.c
@@ -0,0 +1,4 @@
+#define t(x,y,z) x ## y ## z 
+int j[] = { t(1,2,3), t(,4,5), t(6,,7), t(8,9,), 
+t(10,,), t(,11,), t(,,12), t(,,) }; 
+

From 5a9dc867745bc68e902773459ace0d25c2228e26 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 2 Apr 2009 11:42:10 -0500
Subject: [PATCH 088/135] fix typo

---
 vm/platform.h | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/vm/platform.h b/vm/platform.h
index 21336e88bb..70804542b4 100644
--- a/vm/platform.h
+++ b/vm/platform.h
@@ -96,7 +96,7 @@
 			#if defined(FACTOR_X86)
 				#include "os-solaris-x86.32.h"
 			#elif defined(FACTOR_AMD64)
-				#incluide "os-solaris-x86.64.h"
+				#include "os-solaris-x86.64.h"
 			#else
 				#error "Unsupported Solaris flavor"
 			#endif

From 070e5ef9bf3de5eab531f212a2382437c8b683a0 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 2 Apr 2009 12:25:41 -0500
Subject: [PATCH 089/135] check in more test cases for later

---
 extra/c/tests/test10/test10.c |  3 +++
 extra/c/tests/test11/foo.h    |  1 +
 extra/c/tests/test11/test11.c |  2 ++
 extra/c/tests/test12/test12.c |  3 +++
 extra/c/tests/test13/test13.c |  2 ++
 extra/c/tests/test14/test14.c | 15 +++++++++++++++
 6 files changed, 26 insertions(+)
 create mode 100644 extra/c/tests/test10/test10.c
 create mode 100644 extra/c/tests/test11/foo.h
 create mode 100644 extra/c/tests/test11/test11.c
 create mode 100644 extra/c/tests/test12/test12.c
 create mode 100644 extra/c/tests/test13/test13.c
 create mode 100644 extra/c/tests/test14/test14.c

diff --git a/extra/c/tests/test10/test10.c b/extra/c/tests/test10/test10.c
new file mode 100644
index 0000000000..7f38e70d73
--- /dev/null
+++ b/extra/c/tests/test10/test10.c
@@ -0,0 +1,3 @@
+/*
+# lol
+*/
diff --git a/extra/c/tests/test11/foo.h b/extra/c/tests/test11/foo.h
new file mode 100644
index 0000000000..381b7535a0
--- /dev/null
+++ b/extra/c/tests/test11/foo.h
@@ -0,0 +1 @@
+foo.h ftw
diff --git a/extra/c/tests/test11/test11.c b/extra/c/tests/test11/test11.c
new file mode 100644
index 0000000000..1b05118b01
--- /dev/null
+++ b/extra/c/tests/test11/test11.c
@@ -0,0 +1,2 @@
+#define FOO_H "foo.h"
+#include FOO_H
diff --git a/extra/c/tests/test12/test12.c b/extra/c/tests/test12/test12.c
new file mode 100644
index 0000000000..2da127bce0
--- /dev/null
+++ b/extra/c/tests/test12/test12.c
@@ -0,0 +1,3 @@
+#if 4 > (5 - 4++)
+#error "Umm"
+#endif
diff --git a/extra/c/tests/test13/test13.c b/extra/c/tests/test13/test13.c
new file mode 100644
index 0000000000..13c48ff6d0
--- /dev/null
+++ b/extra/c/tests/test13/test13.c
@@ -0,0 +1,2 @@
+#if 10
+#error "Umm"
diff --git a/extra/c/tests/test14/test14.c b/extra/c/tests/test14/test14.c
new file mode 100644
index 0000000000..1697ea1697
--- /dev/null
+++ b/extra/c/tests/test14/test14.c
@@ -0,0 +1,15 @@
+#if 4 > (1 + 2) 
+good
+#endif
+
+#if 4 > 1 + 2
+good
+#endif
+
+#if (4 > 1) - 1
+bad
+#endif
+
+#if (4 > 1) - 2
+good
+#endif

From 9c3054c84a5316e538a7345e491e0f935559ca9c Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Thu, 2 Apr 2009 13:05:26 -0500
Subject: [PATCH 090/135] More progress on Uniscribe

---
 README.txt                                    |    6 -
 basis/alien/destructors/destructors.factor    |    5 +-
 .../images/normalization/normalization.factor |   12 +
 basis/opengl/textures/textures.factor         |    1 +
 basis/ui/backend/windows/windows.factor       |    7 +-
 basis/ui/text/core-text/core-text.factor      |    3 -
 basis/ui/text/pango/pango.factor              |    3 -
 basis/ui/text/text-tests.factor               |   20 +-
 basis/ui/text/text.factor                     |   11 +-
 basis/ui/text/uniscribe/uniscribe.factor      |   41 +
 basis/windows/fonts/fonts.factor              |   37 +
 basis/windows/gdi32/gdi32.factor              | 1311 ++++++++++++++++-
 .../windows/offscreen/offscreen-tests.factor  |    5 +
 basis/windows/offscreen/offscreen.factor      |   30 +-
 basis/windows/types/types.factor              |   64 +-
 basis/windows/uniscribe/uniscribe.factor      |  100 +-
 16 files changed, 1536 insertions(+), 120 deletions(-)
 mode change 100644 => 100755 basis/alien/destructors/destructors.factor
 mode change 100644 => 100755 basis/images/normalization/normalization.factor
 mode change 100644 => 100755 basis/opengl/textures/textures.factor
 mode change 100644 => 100755 basis/ui/text/core-text/core-text.factor
 mode change 100644 => 100755 basis/ui/text/text-tests.factor
 mode change 100644 => 100755 basis/ui/text/text.factor
 create mode 100755 basis/ui/text/uniscribe/uniscribe.factor
 create mode 100755 basis/windows/fonts/fonts.factor
 create mode 100755 basis/windows/offscreen/offscreen-tests.factor
 mode change 100644 => 100755 basis/windows/offscreen/offscreen.factor
 mode change 100644 => 100755 basis/windows/uniscribe/uniscribe.factor

diff --git a/README.txt b/README.txt
index bd9da0ab2b..c5d53de842 100755
--- a/README.txt
+++ b/README.txt
@@ -113,12 +113,6 @@ the command prompt using the console application:
 
   factor.com -i=boot.<cpu>.image
 
-Before bootstrapping, you will need to download the DLLs for the Pango
-text rendering library. The required DLLs are listed in
-build-support/dlls.txt and are available from the following location:
-
-  <http://factorcode.org/dlls>
-
 Once bootstrapped, double-clicking factor.exe or factor.com starts
 the Factor UI.
 
diff --git a/basis/alien/destructors/destructors.factor b/basis/alien/destructors/destructors.factor
old mode 100644
new mode 100755
index 1c5c975fe6..374d6425c4
--- a/basis/alien/destructors/destructors.factor
+++ b/basis/alien/destructors/destructors.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: functors destructors accessors kernel parser words
-combinators.smart ;
+effects generalizations sequences ;
 IN: alien.destructors
 
 SLOT: alien
@@ -12,6 +12,7 @@ F-destructor DEFINES-CLASS ${F}-destructor
 <F-destructor> DEFINES <${F}-destructor>
 &F DEFINES &${F}
 |F DEFINES |${F}
+N [ F stack-effect out>> length ]
 
 WHERE
 
@@ -19,7 +20,7 @@ TUPLE: F-destructor alien disposed ;
 
 : <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
 
-M: F-destructor dispose* [ alien>> F ] drop-outputs ;
+M: F-destructor dispose* alien>> F N ndrop ;
 
 : &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
 
diff --git a/basis/images/normalization/normalization.factor b/basis/images/normalization/normalization.factor
old mode 100644
new mode 100755
index bcdf841b42..dcdf39a53e
--- a/basis/images/normalization/normalization.factor
+++ b/basis/images/normalization/normalization.factor
@@ -61,6 +61,18 @@ M: ARGB normalize-component-order*
 M: ABGR normalize-component-order*
     drop ARGB>RGBA BGRA>RGBA ;
 
+: fix-XBGR ( bitmap -- bitmap' )
+    dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
+
+M: XBGR normalize-component-order*
+    drop fix-XBGR ABGR normalize-component-order* ;
+
+: fix-BGRX ( bitmap -- bitmap' )
+    dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
+
+M: BGRX normalize-component-order*
+    drop fix-BGRX BGRA normalize-component-order* ;
+
 : normalize-scan-line-order ( image -- image )
     dup upside-down?>> [
         dup dim>> first 4 * '[
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
old mode 100644
new mode 100755
index 810aaa2c9c..67094200d1
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -17,6 +17,7 @@ M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
 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 ;
+M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
 
 GENERIC: draw-texture ( texture -- )
 
diff --git a/basis/ui/backend/windows/windows.factor b/basis/ui/backend/windows/windows.factor
index 12ce2bed80..e405efb540 100755
--- a/basis/ui/backend/windows/windows.factor
+++ b/basis/ui/backend/windows/windows.factor
@@ -433,12 +433,7 @@ M: windows-ui-backend do-events
     style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
 
 : make-RECT ( world -- RECT )
-    [ window-loc>> dup ] [ dim>> ] bi v+
-    "RECT" <c-object>
-    over first over set-RECT-right
-    swap second over set-RECT-bottom
-    over first over set-RECT-left
-    swap second over set-RECT-top ;
+    [ window-loc>> ] [ dim>> ] bi <RECT> ;
 
 : default-position-RECT ( RECT -- )
     dup get-RECT-dimensions [ 2drop ] 2dip
diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor
old mode 100644
new mode 100755
index 3704189e48..514d918e2f
--- a/basis/ui/text/core-text/core-text.factor
+++ b/basis/ui/text/core-text/core-text.factor
@@ -10,9 +10,6 @@ IN: ui.text.core-text
 
 SINGLETON: core-text-renderer
 
-M: core-text-renderer init-text-rendering
-    <cache-assoc> >>text-handle drop ;
-
 M: core-text-renderer string-dim
     [ " " string-dim { 0 1 } v* ]
     [ cached-line dim>> ]
diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor
index 017a4b2cf2..3f4808a208 100755
--- a/basis/ui/text/pango/pango.factor
+++ b/basis/ui/text/pango/pango.factor
@@ -7,9 +7,6 @@ IN: ui.text.pango
 
 SINGLETON: pango-renderer
 
-M: pango-renderer init-text-rendering
-    <cache-assoc> >>text-handle drop ;
-
 M: pango-renderer string-dim
     [ " " string-dim { 0 1 } v* ]
     [ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;
diff --git a/basis/ui/text/text-tests.factor b/basis/ui/text/text-tests.factor
old mode 100644
new mode 100755
index 939e262997..7ee901dc80
--- a/basis/ui/text/text-tests.factor
+++ b/basis/ui/text/text-tests.factor
@@ -1,6 +1,22 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test ui.text fonts ;
+USING: tools.test ui.text fonts math accessors kernel sequences ;
 IN: ui.text.tests
 
-[ 0.0 ] [ 0 sans-serif-font "aaa" offset>x ] unit-test
+[ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test
+[ t ] [ 1 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
+[ t ] [ 3 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
+[ t ] [ 1 monospace-font "a" offset>x 0.0 > ] unit-test
+[ 0 ] [ 0 sans-serif-font "aaa" x>offset ] unit-test
+[ 3 ] [ 100 sans-serif-font "aaa" x>offset ] unit-test
+[ 0 ] [ 0 sans-serif-font "" x>offset ] unit-test
+
+[ t ] [
+    sans-serif-font "aaa" line-metrics
+    [ [ ascent>> ] [ descent>> ] bi + ] [ height>> ] bi =
+] unit-test
+
+[ f ] [ sans-serif-font "\0a" text-dim first zero? ] unit-test
+[ t ] [ sans-serif-font "" text-dim first zero? ] unit-test
+
+[ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test
diff --git a/basis/ui/text/text.factor b/basis/ui/text/text.factor
old mode 100644
new mode 100755
index ebf4b9cce0..d787fe8ea9
--- a/basis/ui/text/text.factor
+++ b/basis/ui/text/text.factor
@@ -1,17 +1,16 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel arrays sequences math math.order opengl opengl.gl
-strings fonts colors accessors namespaces ui.gadgets.worlds ;
+USING: kernel arrays sequences math math.order cache opengl
+opengl.gl strings fonts colors accessors namespaces
+ui.gadgets.worlds ;
 IN: ui.text
 
 <PRIVATE
 
 SYMBOL: font-renderer
 
-HOOK: init-text-rendering font-renderer ( world -- )
-
 : world-text-handle ( world -- handle )
-    dup text-handle>> [ dup init-text-rendering ] unless
+    dup text-handle>> [ <cache-assoc> >>text-handle ] unless
     text-handle>> ;
 
 HOOK: flush-layout-cache font-renderer ( -- )
@@ -79,7 +78,7 @@ USING: vocabs.loader namespaces system combinators ;
 "ui-backend" get [
     {
         { [ os macosx? ] [ "core-text" ] }
-        { [ os windows? ] [ "pango" ] }
+        { [ os windows? ] [ "uniscribe" ] }
         { [ os unix? ] [ "pango" ] }
     } cond
 ] unless* "ui.text." prepend require
\ No newline at end of file
diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor
new file mode 100755
index 0000000000..f7d4207927
--- /dev/null
+++ b/basis/ui/text/uniscribe/uniscribe.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs cache kernel math.vectors sequences
+namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds 
+windows.uniscribe ;
+IN: ui.text.uniscribe
+
+SINGLETON: uniscribe-renderer
+
+M: uniscribe-renderer string-dim
+    [ " " string-dim { 0 1 } v* ]
+    [ cached-script-string size>> ] if-empty ;
+
+M: uniscribe-renderer flush-layout-cache
+    cached-script-strings get purge-cache ;
+
+: rendered-script-string ( font string -- texture )
+    world get world-text-handle
+    [ cached-script-string [ image>> ] [ text-position vneg ] bi <texture> ]
+    2cache ;
+
+M: uniscribe-renderer draw-string ( font string -- )
+    [ drop ] [ rendered-script-string draw-texture ] if-empty ;
+
+M: uniscribe-renderer x>offset ( x font string -- n )
+    [ 2drop 0 ] [
+        cached-script-string x>line-offset drop
+    ] if-empty ;
+
+M: uniscribe-renderer offset>x ( n font string -- x )
+    [ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ;
+
+M: uniscribe-renderer font-metrics ( font -- metrics )
+    " " cached-script-string metrics>> clone f >>width ;
+
+M: uniscribe-renderer line-metrics ( font string -- metrics )
+    [ " " line-metrics clone 0 >>width ]
+    [ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ]
+    if-empty ;
+
+uniscribe-renderer font-renderer set-global
diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor
new file mode 100755
index 0000000000..b9fb48d840
--- /dev/null
+++ b/basis/windows/fonts/fonts.factor
@@ -0,0 +1,37 @@
+USING: assocs memoize locals kernel accessors init fonts
+combinators windows windows.types windows.gdi32 ;
+IN: windows.fonts
+
+: windows-font-name ( string -- string' )
+    H{
+        { "sans-serif" "Tahoma" }
+        { "serif" "Times New Roman" }
+        { "monospace" "Courier New" }
+    } at-default ;
+    
+MEMO:: (cache-font) ( font -- HFONT )
+    font size>> ! nHeight
+    0 0 0 ! nWidth, nEscapement, nOrientation
+    font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
+    font italic?>> TRUE FALSE ? ! fdwItalic
+    FALSE ! fdwUnderline
+    FALSE ! fdWStrikeOut
+    DEFAULT_CHARSET ! fdwCharSet
+    OUT_OUTLINE_PRECIS ! fdwOutputPrecision
+    CLIP_DEFAULT_PRECIS ! fdwClipPrecision
+    DEFAULT_QUALITY ! fdwQuality
+    DEFAULT_PITCH ! fdwPitchAndFamily
+    font name>> windows-font-name
+    CreateFont
+    dup win32-error=0/f ;
+
+: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
+
+[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
+
+: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
+    [ metrics new 0 >>width ] dip {
+        [ TEXTMETRICW-tmHeight >>height ]
+        [ TEXTMETRICW-tmAscent >>ascent ]
+        [ TEXTMETRICW-tmDescent >>descent ]
+    } cleave ;
diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor
index 2281255a4f..549286d4f0 100755
--- a/basis/windows/gdi32/gdi32.factor
+++ b/basis/windows/gdi32/gdi32.factor
@@ -1,37 +1,1272 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax alien.destructors kernel windows.types ;
+USING: alien alien.syntax alien.destructors kernel windows.types
+math.bitwise ;
 IN: windows.gdi32
 
-! Stock Logical Objects
-CONSTANT: WHITE_BRUSH         0
-CONSTANT: LTGRAY_BRUSH        1
-CONSTANT: GRAY_BRUSH          2
-CONSTANT: DKGRAY_BRUSH        3
-CONSTANT: BLACK_BRUSH         4
-CONSTANT: NULL_BRUSH          5
-ALIAS: HOLLOW_BRUSH        NULL_BRUSH
-CONSTANT: WHITE_PEN           6
-CONSTANT: BLACK_PEN           7
-CONSTANT: NULL_PEN            8
-CONSTANT: OEM_FIXED_FONT      10
-CONSTANT: ANSI_FIXED_FONT     11
-CONSTANT: ANSI_VAR_FONT       12
-CONSTANT: SYSTEM_FONT         13
-CONSTANT: DEVICE_DEFAULT_FONT 14
-CONSTANT: DEFAULT_PALETTE     15
-CONSTANT: SYSTEM_FIXED_FONT   16
-CONSTANT: DEFAULT_GUI_FONT    17
-CONSTANT: DC_BRUSH            18
-CONSTANT: DC_PEN              19
-                  
-CONSTANT: BI_RGB        0
-CONSTANT: BI_RLE8       1
-CONSTANT: BI_RLE4       2
-CONSTANT: BI_BITFIELDS  3
-
-CONSTANT: DIB_RGB_COLORS 0
+CONSTANT: BI_RGB 0
+CONSTANT: BI_RLE8 1
+CONSTANT: BI_RLE4 2
+CONSTANT: BI_BITFIELDS 3
+CONSTANT: BI_JPEG 4
+CONSTANT: BI_PNG 5
+CONSTANT: LF_FACESIZE 32
+CONSTANT: LF_FULLFACESIZE 64
+CONSTANT: CA_NEGATIVE 1
+CONSTANT: CA_LOG_FILTER 2
+CONSTANT: ILLUMINANT_DEVICE_DEFAULT 0
+CONSTANT: ILLUMINANT_A 1
+CONSTANT: ILLUMINANT_B 2
+CONSTANT: ILLUMINANT_C 3
+CONSTANT: ILLUMINANT_D50 4
+CONSTANT: ILLUMINANT_D55 5
+CONSTANT: ILLUMINANT_D65 6
+CONSTANT: ILLUMINANT_D75 7
+CONSTANT: ILLUMINANT_F2 8
+ALIAS: ILLUMINANT_MAX_INDEX ILLUMINANT_F2
+ALIAS: ILLUMINANT_TUNGSTEN ILLUMINANT_A
+ALIAS: ILLUMINANT_DAYLIGHT ILLUMINANT_C
+ALIAS: ILLUMINANT_FLUORESCENT ILLUMINANT_F2
+ALIAS: ILLUMINANT_NTSC ILLUMINANT_C
+CONSTANT: RGB_GAMMA_MIN 2500
+CONSTANT: RGB_GAMMA_MAX 65000
+CONSTANT: REFERENCE_WHITE_MIN 6000
+CONSTANT: REFERENCE_WHITE_MAX 10000
+CONSTANT: REFERENCE_BLACK_MIN 0
+CONSTANT: REFERENCE_BLACK_MAX 4000
+CONSTANT: COLOR_ADJ_MIN -100
+CONSTANT: COLOR_ADJ_MAX 100
+CONSTANT: CCHDEVICENAME 32
+CONSTANT: CCHFORMNAME 32
+CONSTANT: DI_COMPAT 4
+CONSTANT: DI_DEFAULTSIZE 8
+CONSTANT: DI_IMAGE 2
+CONSTANT: DI_MASK 1
+CONSTANT: DI_NORMAL 3
+CONSTANT: DI_APPBANDING 1
+CONSTANT: EMR_HEADER 1
+CONSTANT: EMR_POLYBEZIER 2
+CONSTANT: EMR_POLYGON 3
+CONSTANT: EMR_POLYLINE 4
+CONSTANT: EMR_POLYBEZIERTO 5
+CONSTANT: EMR_POLYLINETO 6
+CONSTANT: EMR_POLYPOLYLINE 7
+CONSTANT: EMR_POLYPOLYGON 8
+CONSTANT: EMR_SETWINDOWEXTEX 9
+CONSTANT: EMR_SETWINDOWORGEX 10
+CONSTANT: EMR_SETVIEWPORTEXTEX 11
+CONSTANT: EMR_SETVIEWPORTORGEX 12
+CONSTANT: EMR_SETBRUSHORGEX 13
+CONSTANT: EMR_EOF 14
+CONSTANT: EMR_SETPIXELV 15
+CONSTANT: EMR_SETMAPPERFLAGS 16
+CONSTANT: EMR_SETMAPMODE 17
+CONSTANT: EMR_SETBKMODE 18
+CONSTANT: EMR_SETPOLYFILLMODE 19
+CONSTANT: EMR_SETROP2 20
+CONSTANT: EMR_SETSTRETCHBLTMODE 21
+CONSTANT: EMR_SETTEXTALIGN 22
+CONSTANT: EMR_SETCOLORADJUSTMENT 23
+CONSTANT: EMR_SETTEXTCOLOR 24
+CONSTANT: EMR_SETBKCOLOR 25
+CONSTANT: EMR_OFFSETCLIPRGN 26
+CONSTANT: EMR_MOVETOEX 27
+CONSTANT: EMR_SETMETARGN 28
+CONSTANT: EMR_EXCLUDECLIPRECT 29
+CONSTANT: EMR_INTERSECTCLIPRECT 30
+CONSTANT: EMR_SCALEVIEWPORTEXTEX 31
+CONSTANT: EMR_SCALEWINDOWEXTEX 32
+CONSTANT: EMR_SAVEDC 33
+CONSTANT: EMR_RESTOREDC 34
+CONSTANT: EMR_SETWORLDTRANSFORM 35
+CONSTANT: EMR_MODIFYWORLDTRANSFORM 36
+CONSTANT: EMR_SELECTOBJECT 37
+CONSTANT: EMR_CREATEPEN 38
+CONSTANT: EMR_CREATEBRUSHINDIRECT 39
+CONSTANT: EMR_DELETEOBJECT 40
+CONSTANT: EMR_ANGLEARC 41
+CONSTANT: EMR_ELLIPSE 42
+CONSTANT: EMR_RECTANGLE 43
+CONSTANT: EMR_ROUNDRECT 44
+CONSTANT: EMR_ARC 45
+CONSTANT: EMR_CHORD 46
+CONSTANT: EMR_PIE 47
+CONSTANT: EMR_SELECTPALETTE 48
+CONSTANT: EMR_CREATEPALETTE 49
+CONSTANT: EMR_SETPALETTEENTRIES 50
+CONSTANT: EMR_RESIZEPALETTE 51
+CONSTANT: EMR_REALIZEPALETTE 52
+CONSTANT: EMR_EXTFLOODFILL 53
+CONSTANT: EMR_LINETO 54
+CONSTANT: EMR_ARCTO 55
+CONSTANT: EMR_POLYDRAW 56
+CONSTANT: EMR_SETARCDIRECTION 57
+CONSTANT: EMR_SETMITERLIMIT 58
+CONSTANT: EMR_BEGINPATH 59
+CONSTANT: EMR_ENDPATH 60
+CONSTANT: EMR_CLOSEFIGURE 61
+CONSTANT: EMR_FILLPATH 62
+CONSTANT: EMR_STROKEANDFILLPATH 63
+CONSTANT: EMR_STROKEPATH 64
+CONSTANT: EMR_FLATTENPATH 65
+CONSTANT: EMR_WIDENPATH 66
+CONSTANT: EMR_SELECTCLIPPATH 67
+CONSTANT: EMR_ABORTPATH 68
+CONSTANT: EMR_GDICOMMENT 70
+CONSTANT: EMR_FILLRGN 71
+CONSTANT: EMR_FRAMERGN 72
+CONSTANT: EMR_INVERTRGN 73
+CONSTANT: EMR_PAINTRGN 74
+CONSTANT: EMR_EXTSELECTCLIPRGN 75
+CONSTANT: EMR_BITBLT 76
+CONSTANT: EMR_STRETCHBLT 77
+CONSTANT: EMR_MASKBLT 78
+CONSTANT: EMR_PLGBLT 79
+CONSTANT: EMR_SETDIBITSTODEVICE 80
+CONSTANT: EMR_STRETCHDIBITS 81
+CONSTANT: EMR_EXTCREATEFONTINDIRECTW 82
+CONSTANT: EMR_EXTTEXTOUTA 83
+CONSTANT: EMR_EXTTEXTOUTW 84
+CONSTANT: EMR_POLYBEZIER16 85
+CONSTANT: EMR_POLYGON16 86
+CONSTANT: EMR_POLYLINE16 87
+CONSTANT: EMR_POLYBEZIERTO16 88
+CONSTANT: EMR_POLYLINETO16 89
+CONSTANT: EMR_POLYPOLYLINE16 90
+CONSTANT: EMR_POLYPOLYGON16 91
+CONSTANT: EMR_POLYDRAW16 92
+CONSTANT: EMR_CREATEMONOBRUSH 93
+CONSTANT: EMR_CREATEDIBPATTERNBRUSHPT 94
+CONSTANT: EMR_EXTCREATEPEN 95
+CONSTANT: EMR_POLYTEXTOUTA 96
+CONSTANT: EMR_POLYTEXTOUTW 97
+CONSTANT: EMR_SETICMMODE 98
+CONSTANT: EMR_CREATECOLORSPACE 99
+CONSTANT: EMR_SETCOLORSPACE 100
+CONSTANT: EMR_DELETECOLORSPACE 101
+CONSTANT: EMR_GLSRECORD 102
+CONSTANT: EMR_GLSBOUNDEDRECORD 103
+CONSTANT: EMR_PIXELFORMAT 104
+CONSTANT: ENHMETA_SIGNATURE 1179469088
+CONSTANT: EPS_SIGNATURE HEX: 46535045
+CONSTANT: FR_PRIVATE HEX: 10
+CONSTANT: FR_NOT_ENUM HEX: 20
+CONSTANT: META_SETBKCOLOR HEX: 201
+CONSTANT: META_SETBKMODE HEX: 102
+CONSTANT: META_SETMAPMODE HEX: 103
+CONSTANT: META_SETROP2 HEX: 104
+CONSTANT: META_SETRELABS HEX: 105
+CONSTANT: META_SETPOLYFILLMODE HEX: 106
+CONSTANT: META_SETSTRETCHBLTMODE HEX: 107
+CONSTANT: META_SETTEXTCHAREXTRA HEX: 108
+CONSTANT: META_SETTEXTCOLOR HEX: 209
+CONSTANT: META_SETTEXTJUSTIFICATION HEX: 20A
+CONSTANT: META_SETWINDOWORG HEX: 20B
+CONSTANT: META_SETWINDOWEXT HEX: 20C
+CONSTANT: META_SETVIEWPORTORG HEX: 20D
+CONSTANT: META_SETVIEWPORTEXT HEX: 20E
+CONSTANT: META_OFFSETWINDOWORG HEX: 20F
+CONSTANT: META_SCALEWINDOWEXT HEX: 410
+CONSTANT: META_OFFSETVIEWPORTORG HEX: 211
+CONSTANT: META_SCALEVIEWPORTEXT HEX: 412
+CONSTANT: META_LINETO HEX: 213
+CONSTANT: META_MOVETO HEX: 214
+CONSTANT: META_EXCLUDECLIPRECT HEX: 415
+CONSTANT: META_INTERSECTCLIPRECT HEX: 416
+CONSTANT: META_ARC HEX: 817
+CONSTANT: META_ELLIPSE HEX: 418
+CONSTANT: META_FLOODFILL HEX: 419
+CONSTANT: META_PIE HEX: 81A
+CONSTANT: META_RECTANGLE HEX: 41B
+CONSTANT: META_ROUNDRECT HEX: 61C
+CONSTANT: META_PATBLT HEX: 61D
+CONSTANT: META_SAVEDC HEX: 1E
+CONSTANT: META_SETPIXEL HEX: 41F
+CONSTANT: META_OFFSETCLIPRGN HEX: 220
+CONSTANT: META_TEXTOUT HEX: 521
+CONSTANT: META_BITBLT HEX: 922
+CONSTANT: META_STRETCHBLT HEX: b23
+CONSTANT: META_POLYGON HEX: 324
+CONSTANT: META_POLYLINE HEX: 325
+CONSTANT: META_ESCAPE HEX: 626
+CONSTANT: META_RESTOREDC HEX: 127
+CONSTANT: META_FILLREGION HEX: 228
+CONSTANT: META_FRAMEREGION HEX: 429
+CONSTANT: META_INVERTREGION HEX: 12A
+CONSTANT: META_PAINTREGION HEX: 12B
+CONSTANT: META_SELECTCLIPREGION HEX: 12C
+CONSTANT: META_SELECTOBJECT HEX: 12D
+CONSTANT: META_SETTEXTALIGN HEX: 12E
+CONSTANT: META_CHORD HEX: 830
+CONSTANT: META_SETMAPPERFLAGS HEX: 231
+CONSTANT: META_EXTTEXTOUT HEX: a32
+CONSTANT: META_SETDIBTODEV HEX: d33
+CONSTANT: META_SELECTPALETTE HEX: 234
+CONSTANT: META_REALIZEPALETTE HEX: 35
+CONSTANT: META_ANIMATEPALETTE HEX: 436
+CONSTANT: META_SETPALENTRIES HEX: 37
+CONSTANT: META_POLYPOLYGON HEX: 538
+CONSTANT: META_RESIZEPALETTE HEX: 139
+CONSTANT: META_DIBBITBLT HEX: 940
+CONSTANT: META_DIBSTRETCHBLT HEX: b41
+CONSTANT: META_DIBCREATEPATTERNBRUSH HEX: 142
+CONSTANT: META_STRETCHDIB HEX: f43
+CONSTANT: META_EXTFLOODFILL HEX: 548
+CONSTANT: META_DELETEOBJECT HEX: 1f0
+CONSTANT: META_CREATEPALETTE HEX: f7
+CONSTANT: META_CREATEPATTERNBRUSH HEX: 1F9
+CONSTANT: META_CREATEPENINDIRECT HEX: 2FA
+CONSTANT: META_CREATEFONTINDIRECT HEX: 2FB
+CONSTANT: META_CREATEBRUSHINDIRECT HEX: 2FC
+CONSTANT: META_CREATEREGION HEX: 6FF
+CONSTANT: ELF_VENDOR_SIZE 4
+CONSTANT: ELF_VERSION 0
+CONSTANT: ELF_CULTURE_LATIN 0
+CONSTANT: PFD_TYPE_RGBA 0
+CONSTANT: PFD_TYPE_COLORINDEX 1
+CONSTANT: PFD_MAIN_PLANE 0
+CONSTANT: PFD_OVERLAY_PLANE 1
+CONSTANT: PFD_UNDERLAY_PLANE -1
+CONSTANT: PFD_DOUBLEBUFFER 1
+CONSTANT: PFD_STEREO 2
+CONSTANT: PFD_DRAW_TO_WINDOW 4
+CONSTANT: PFD_DRAW_TO_BITMAP 8
+CONSTANT: PFD_SUPPORT_GDI 16
+CONSTANT: PFD_SUPPORT_OPENGL 32
+CONSTANT: PFD_GENERIC_FORMAT 64
+CONSTANT: PFD_NEED_PALETTE 128
+CONSTANT: PFD_NEED_SYSTEM_PALETTE HEX: 00000100
+CONSTANT: PFD_SWAP_EXCHANGE HEX: 00000200
+CONSTANT: PFD_SWAP_COPY HEX: 00000400
+CONSTANT: PFD_SWAP_LAYER_BUFFERS HEX: 00000800
+CONSTANT: PFD_GENERIC_ACCELERATED HEX: 00001000
+CONSTANT: PFD_DEPTH_DONTCARE HEX: 20000000
+CONSTANT: PFD_DOUBLEBUFFER_DONTCARE HEX: 40000000
+CONSTANT: PFD_STEREO_DONTCARE HEX: 80000000
+CONSTANT: SP_ERROR -1
+CONSTANT: SP_OUTOFDISK -4
+CONSTANT: SP_OUTOFMEMORY -5
+CONSTANT: SP_USERABORT -3
+CONSTANT: SP_APPABORT -2
+CONSTANT: BLACKNESS HEX: 00000042
+CONSTANT: NOTSRCERASE HEX: 001100A6
+CONSTANT: NOTSRCCOPY HEX: 00330008
+CONSTANT: SRCERASE HEX: 00440328
+CONSTANT: DSTINVERT HEX: 00550009
+CONSTANT: PATINVERT HEX: 005A0049
+CONSTANT: SRCINVERT HEX: 00660046
+CONSTANT: SRCAND HEX: 008800C6
+CONSTANT: MERGEPAINT HEX: 00BB0226
+CONSTANT: MERGECOPY HEX: 00C000CA
+CONSTANT: SRCCOPY HEX: 00CC0020
+CONSTANT: SRCPAINT HEX: 00EE0086
+CONSTANT: PATCOPY HEX: 00F00021
+CONSTANT: PATPAINT HEX: 00FB0A09
+CONSTANT: WHITENESS HEX: 00FF0062
+CONSTANT: CAPTUREBLT HEX: 40000000
+CONSTANT: NOMIRRORBITMAP HEX: 80000000
+CONSTANT: R2_BLACK 1
+CONSTANT: R2_COPYPEN 13
+CONSTANT: R2_MASKNOTPEN 3
+CONSTANT: R2_MASKPEN 9
+CONSTANT: R2_MASKPENNOT 5
+CONSTANT: R2_MERGENOTPEN 12
+CONSTANT: R2_MERGEPEN 15
+CONSTANT: R2_MERGEPENNOT 14
+CONSTANT: R2_NOP 11
+CONSTANT: R2_NOT 6
+CONSTANT: R2_NOTCOPYPEN 4
+CONSTANT: R2_NOTMASKPEN 8
+CONSTANT: R2_NOTMERGEPEN 2
+CONSTANT: R2_NOTXORPEN 10
+CONSTANT: R2_WHITE 16
+CONSTANT: R2_XORPEN 7
+CONSTANT: CM_OUT_OF_GAMUT 255
+CONSTANT: CM_IN_GAMUT 0
+CONSTANT: RGN_AND 1
+CONSTANT: RGN_COPY 5
+CONSTANT: RGN_DIFF 4
+CONSTANT: RGN_OR 2
+CONSTANT: RGN_XOR 3
+CONSTANT: NULLREGION 1
+CONSTANT: SIMPLEREGION 2
+CONSTANT: COMPLEXREGION 3
+CONSTANT: ERROR 0
+CONSTANT: CBM_INIT 4
 CONSTANT: DIB_PAL_COLORS 1
+CONSTANT: DIB_RGB_COLORS 0
+CONSTANT: FW_DONTCARE 0
+CONSTANT: FW_THIN 100
+CONSTANT: FW_EXTRALIGHT 200
+ALIAS: FW_ULTRALIGHT FW_EXTRALIGHT
+CONSTANT: FW_LIGHT 300
+CONSTANT: FW_NORMAL 400
+CONSTANT: FW_REGULAR 400
+CONSTANT: FW_MEDIUM 500
+CONSTANT: FW_SEMIBOLD 600
+ALIAS: FW_DEMIBOLD FW_SEMIBOLD
+CONSTANT: FW_BOLD 700
+CONSTANT: FW_EXTRABOLD 800
+ALIAS: FW_ULTRABOLD FW_EXTRABOLD
+CONSTANT: FW_HEAVY 900
+ALIAS: FW_BLACK FW_HEAVY
+CONSTANT: ANSI_CHARSET 0
+CONSTANT: DEFAULT_CHARSET 1
+CONSTANT: SYMBOL_CHARSET 2
+CONSTANT: SHIFTJIS_CHARSET 128
+CONSTANT: HANGEUL_CHARSET 129
+CONSTANT: HANGUL_CHARSET 129
+CONSTANT: GB2312_CHARSET 134
+CONSTANT: CHINESEBIG5_CHARSET 136
+CONSTANT: GREEK_CHARSET 161
+CONSTANT: TURKISH_CHARSET 162
+CONSTANT: HEBREW_CHARSET 177
+CONSTANT: ARABIC_CHARSET 178
+CONSTANT: BALTIC_CHARSET 186
+CONSTANT: RUSSIAN_CHARSET 204
+CONSTANT: THAI_CHARSET 222
+CONSTANT: EASTEUROPE_CHARSET 238
+CONSTANT: OEM_CHARSET 255
+CONSTANT: JOHAB_CHARSET 130
+CONSTANT: VIETNAMESE_CHARSET 163
+CONSTANT: MAC_CHARSET 77
+CONSTANT: OUT_DEFAULT_PRECIS 0
+CONSTANT: OUT_STRING_PRECIS 1
+CONSTANT: OUT_CHARACTER_PRECIS 2
+CONSTANT: OUT_STROKE_PRECIS 3
+CONSTANT: OUT_TT_PRECIS 4
+CONSTANT: OUT_DEVICE_PRECIS 5
+CONSTANT: OUT_RASTER_PRECIS 6
+CONSTANT: OUT_TT_ONLY_PRECIS 7
+CONSTANT: OUT_OUTLINE_PRECIS 8
+CONSTANT: CLIP_DEFAULT_PRECIS 0
+CONSTANT: CLIP_CHARACTER_PRECIS 1
+CONSTANT: CLIP_STROKE_PRECIS 2
+CONSTANT: CLIP_MASK 15
+CONSTANT: CLIP_LH_ANGLES 16
+CONSTANT: CLIP_TT_ALWAYS 32
+CONSTANT: CLIP_EMBEDDED 128
+CONSTANT: DEFAULT_QUALITY 0
+CONSTANT: DRAFT_QUALITY 1
+CONSTANT: PROOF_QUALITY 2
+CONSTANT: NONANTIALIASED_QUALITY 3
+CONSTANT: ANTIALIASED_QUALITY 4
+CONSTANT: DEFAULT_PITCH 0
+CONSTANT: FIXED_PITCH 1
+CONSTANT: VARIABLE_PITCH 2
+CONSTANT: MONO_FONT 8
+CONSTANT: FF_DECORATIVE 80
+CONSTANT: FF_DONTCARE 0
+CONSTANT: FF_MODERN 48
+CONSTANT: FF_ROMAN 16
+CONSTANT: FF_SCRIPT 64
+CONSTANT: FF_SWISS 32
+CONSTANT: PANOSE_COUNT 10
+CONSTANT: PAN_FAMILYTYPE_INDEX 0
+CONSTANT: PAN_SERIFSTYLE_INDEX 1
+CONSTANT: PAN_WEIGHT_INDEX 2
+CONSTANT: PAN_PROPORTION_INDEX 3
+CONSTANT: PAN_CONTRAST_INDEX 4
+CONSTANT: PAN_STROKEVARIATION_INDEX 5
+CONSTANT: PAN_ARMSTYLE_INDEX 6
+CONSTANT: PAN_LETTERFORM_INDEX 7
+CONSTANT: PAN_MIDLINE_INDEX 8
+CONSTANT: PAN_XHEIGHT_INDEX 9
+CONSTANT: PAN_CULTURE_LATIN 0
+CONSTANT: PAN_ANY 0
+CONSTANT: PAN_NO_FIT 1
+CONSTANT: PAN_FAMILY_TEXT_DISPLAY 2
+CONSTANT: PAN_FAMILY_SCRIPT 3
+CONSTANT: PAN_FAMILY_DECORATIVE 4
+CONSTANT: PAN_FAMILY_PICTORIAL 5
+CONSTANT: PAN_SERIF_COVE 2
+CONSTANT: PAN_SERIF_OBTUSE_COVE 3
+CONSTANT: PAN_SERIF_SQUARE_COVE 4
+CONSTANT: PAN_SERIF_OBTUSE_SQUARE_COVE 5
+CONSTANT: PAN_SERIF_SQUARE 6
+CONSTANT: PAN_SERIF_THIN 7
+CONSTANT: PAN_SERIF_BONE 8
+CONSTANT: PAN_SERIF_EXAGGERATED 9
+CONSTANT: PAN_SERIF_TRIANGLE 10
+CONSTANT: PAN_SERIF_NORMAL_SANS 11
+CONSTANT: PAN_SERIF_OBTUSE_SANS 12
+CONSTANT: PAN_SERIF_PERP_SANS 13
+CONSTANT: PAN_SERIF_FLARED 14
+CONSTANT: PAN_SERIF_ROUNDED 15
+CONSTANT: PAN_WEIGHT_VERY_LIGHT 2
+CONSTANT: PAN_WEIGHT_LIGHT 3
+CONSTANT: PAN_WEIGHT_THIN 4
+CONSTANT: PAN_WEIGHT_BOOK 5
+CONSTANT: PAN_WEIGHT_MEDIUM 6
+CONSTANT: PAN_WEIGHT_DEMI 7
+CONSTANT: PAN_WEIGHT_BOLD 8
+CONSTANT: PAN_WEIGHT_HEAVY 9
+CONSTANT: PAN_WEIGHT_BLACK 10
+CONSTANT: PAN_WEIGHT_NORD 11
+CONSTANT: PAN_PROP_OLD_STYLE 2
+CONSTANT: PAN_PROP_MODERN 3
+CONSTANT: PAN_PROP_EVEN_WIDTH 4
+CONSTANT: PAN_PROP_EXPANDED 5
+CONSTANT: PAN_PROP_CONDENSED 6
+CONSTANT: PAN_PROP_VERY_EXPANDED 7
+CONSTANT: PAN_PROP_VERY_CONDENSED 8
+CONSTANT: PAN_PROP_MONOSPACED 9
+CONSTANT: PAN_CONTRAST_NONE 2
+CONSTANT: PAN_CONTRAST_VERY_LOW 3
+CONSTANT: PAN_CONTRAST_LOW 4
+CONSTANT: PAN_CONTRAST_MEDIUM_LOW 5
+CONSTANT: PAN_CONTRAST_MEDIUM 6
+CONSTANT: PAN_CONTRAST_MEDIUM_HIGH 7
+CONSTANT: PAN_CONTRAST_HIGH 8
+CONSTANT: PAN_CONTRAST_VERY_HIGH 9
+CONSTANT: PAN_STROKE_GRADUAL_DIAG 2
+CONSTANT: PAN_STROKE_GRADUAL_TRAN 3
+CONSTANT: PAN_STROKE_GRADUAL_VERT 4
+CONSTANT: PAN_STROKE_GRADUAL_HORZ 5
+CONSTANT: PAN_STROKE_RAPID_VERT 6
+CONSTANT: PAN_STROKE_RAPID_HORZ 7
+CONSTANT: PAN_STROKE_INSTANT_VERT 8
+CONSTANT: PAN_STRAIGHT_ARMS_HORZ 2
+CONSTANT: PAN_STRAIGHT_ARMS_WEDGE 3
+CONSTANT: PAN_STRAIGHT_ARMS_VERT 4
+CONSTANT: PAN_STRAIGHT_ARMS_SINGLE_SERIF 5
+CONSTANT: PAN_STRAIGHT_ARMS_DOUBLE_SERIF 6
+CONSTANT: PAN_BENT_ARMS_HORZ 7
+CONSTANT: PAN_BENT_ARMS_WEDGE 8
+CONSTANT: PAN_BENT_ARMS_VERT 9
+CONSTANT: PAN_BENT_ARMS_SINGLE_SERIF 10
+CONSTANT: PAN_BENT_ARMS_DOUBLE_SERIF 11
+CONSTANT: PAN_LETT_NORMAL_CONTACT 2
+CONSTANT: PAN_LETT_NORMAL_WEIGHTED 3
+CONSTANT: PAN_LETT_NORMAL_BOXED 4
+CONSTANT: PAN_LETT_NORMAL_FLATTENED 5
+CONSTANT: PAN_LETT_NORMAL_ROUNDED 6
+CONSTANT: PAN_LETT_NORMAL_OFF_CENTER 7
+CONSTANT: PAN_LETT_NORMAL_SQUARE 8
+CONSTANT: PAN_LETT_OBLIQUE_CONTACT 9
+CONSTANT: PAN_LETT_OBLIQUE_WEIGHTED 10
+CONSTANT: PAN_LETT_OBLIQUE_BOXED 11
+CONSTANT: PAN_LETT_OBLIQUE_FLATTENED 12
+CONSTANT: PAN_LETT_OBLIQUE_ROUNDED 13
+CONSTANT: PAN_LETT_OBLIQUE_OFF_CENTER 14
+CONSTANT: PAN_LETT_OBLIQUE_SQUARE 15
+CONSTANT: PAN_MIDLINE_STANDARD_TRIMMED 2
+CONSTANT: PAN_MIDLINE_STANDARD_POINTED 3
+CONSTANT: PAN_MIDLINE_STANDARD_SERIFED 4
+CONSTANT: PAN_MIDLINE_HIGH_TRIMMED 5
+CONSTANT: PAN_MIDLINE_HIGH_POINTED 6
+CONSTANT: PAN_MIDLINE_HIGH_SERIFED 7
+CONSTANT: PAN_MIDLINE_CONSTANT_TRIMMED 8
+CONSTANT: PAN_MIDLINE_CONSTANT_POINTED 9
+CONSTANT: PAN_MIDLINE_CONSTANT_SERIFED 10
+CONSTANT: PAN_MIDLINE_LOW_TRIMMED 11
+CONSTANT: PAN_MIDLINE_LOW_POINTED 12
+CONSTANT: PAN_MIDLINE_LOW_SERIFED 13
+CONSTANT: PAN_XHEIGHT_CONSTANT_SMALL 2
+CONSTANT: PAN_XHEIGHT_CONSTANT_STD 3
+CONSTANT: PAN_XHEIGHT_CONSTANT_LARGE 4
+CONSTANT: PAN_XHEIGHT_DUCKING_SMALL 5
+CONSTANT: PAN_XHEIGHT_DUCKING_STD 6
+CONSTANT: PAN_XHEIGHT_DUCKING_LARGE 7
+CONSTANT: FS_LATIN1 1
+CONSTANT: FS_LATIN2 2
+CONSTANT: FS_CYRILLIC 4
+CONSTANT: FS_GREEK 8
+CONSTANT: FS_TURKISH 16
+CONSTANT: FS_HEBREW 32
+CONSTANT: FS_ARABIC 64
+CONSTANT: FS_BALTIC 128
+CONSTANT: FS_THAI HEX: 10000
+CONSTANT: FS_JISJAPAN HEX: 20000
+CONSTANT: FS_CHINESESIMP HEX: 40000
+CONSTANT: FS_WANSUNG HEX: 80000
+CONSTANT: FS_CHINESETRAD HEX: 100000
+CONSTANT: FS_JOHAB HEX: 200000
+CONSTANT: FS_SYMBOL HEX: 80000000
+CONSTANT: HS_BDIAGONAL 3
+CONSTANT: HS_CROSS 4
+CONSTANT: HS_DIAGCROSS 5
+CONSTANT: HS_FDIAGONAL 2
+CONSTANT: HS_HORIZONTAL 0
+CONSTANT: HS_VERTICAL 1
+CONSTANT: PS_GEOMETRIC 65536
+CONSTANT: PS_COSMETIC 0
+CONSTANT: PS_ALTERNATE 8
+CONSTANT: PS_SOLID 0
+CONSTANT: PS_DASH 1
+CONSTANT: PS_DOT 2
+CONSTANT: PS_DASHDOT 3
+CONSTANT: PS_DASHDOTDOT 4
+CONSTANT: PS_NULL 5
+CONSTANT: PS_USERSTYLE 7
+CONSTANT: PS_INSIDEFRAME 6
+CONSTANT: PS_ENDCAP_ROUND 0
+CONSTANT: PS_ENDCAP_SQUARE 256
+CONSTANT: PS_ENDCAP_FLAT 512
+CONSTANT: PS_JOIN_BEVEL 4096
+CONSTANT: PS_JOIN_MITER 8192
+CONSTANT: PS_JOIN_ROUND 0
+CONSTANT: PS_STYLE_MASK 15
+CONSTANT: PS_ENDCAP_MASK 3840
+CONSTANT: PS_TYPE_MASK 983040
+CONSTANT: ALTERNATE 1
+CONSTANT: WINDING 2
+CONSTANT: DC_BINNAMES 12
+CONSTANT: DC_BINS 6
+CONSTANT: DC_COPIES 18
+CONSTANT: DC_DRIVER 11
+CONSTANT: DC_DATATYPE_PRODUCED 21
+CONSTANT: DC_DUPLEX 7
+CONSTANT: DC_EMF_COMPLIANT 20
+CONSTANT: DC_ENUMRESOLUTIONS 13
+CONSTANT: DC_EXTRA 9
+CONSTANT: DC_FIELDS 1
+CONSTANT: DC_FILEDEPENDENCIES 14
+CONSTANT: DC_MAXEXTENT 5
+CONSTANT: DC_MINEXTENT 4
+CONSTANT: DC_ORIENTATION 17
+CONSTANT: DC_PAPERNAMES 16
+CONSTANT: DC_PAPERS 2
+CONSTANT: DC_PAPERSIZE 3
+CONSTANT: DC_SIZE 8
+CONSTANT: DC_TRUETYPE 15
+CONSTANT: DCTT_BITMAP 1
+CONSTANT: DCTT_DOWNLOAD 2
+CONSTANT: DCTT_SUBDEV 4
+CONSTANT: DCTT_DOWNLOAD_OUTLINE 8
+CONSTANT: DC_VERSION 10
+CONSTANT: DC_BINADJUST 19
+CONSTANT: DC_MANUFACTURER 23
+CONSTANT: DC_MODEL 24
+CONSTANT: DC_PERSONALITY 25
+CONSTANT: DC_PRINTRATE 26
+CONSTANT: DC_PRINTRATEUNIT 27
+CONSTANT: DC_PRINTERMEM 28
+CONSTANT: DC_MEDIAREADY 29
+CONSTANT: DC_STAPLE 30
+CONSTANT: DC_PRINTRATEPPM 31
+CONSTANT: DC_COLORDEVICE 32
+CONSTANT: DC_NUP 33
+CONSTANT: DC_MEDIATYPENAMES 34
+CONSTANT: DC_MEDIATYPES 35
+CONSTANT: DCBA_FACEUPNONE 0
+CONSTANT: DCBA_FACEUPCENTER 1
+CONSTANT: DCBA_FACEUPLEFT 2
+CONSTANT: DCBA_FACEUPRIGHT 3
+CONSTANT: DCBA_FACEDOWNNONE 256
+CONSTANT: DCBA_FACEDOWNCENTER 257
+CONSTANT: DCBA_FACEDOWNLEFT 258
+CONSTANT: DCBA_FACEDOWNRIGHT 259
+CONSTANT: FLOODFILLBORDER 0
+CONSTANT: FLOODFILLSURFACE 1
+CONSTANT: ETO_CLIPPED HEX: 0004
+CONSTANT: ETO_GLYPH_INDEX HEX: 0010
+CONSTANT: ETO_OPAQUE HEX: 0002
+CONSTANT: ETO_NUMERICSLATIN HEX: 0800
+CONSTANT: ETO_NUMERICSLOCAL HEX: 0400
+CONSTANT: ETO_RTLREADING HEX: 0080
+CONSTANT: ETO_IGNORELANGUAGE HEX: 1000
+CONSTANT: ETO_PDY HEX: 2000
+CONSTANT: GDICOMMENT_WINDOWS_METAFILE -2147483647
+CONSTANT: GDICOMMENT_BEGINGROUP 2
+CONSTANT: GDICOMMENT_ENDGROUP 3
+CONSTANT: GDICOMMENT_MULTIFORMATS 1073741828
+CONSTANT: GDICOMMENT_IDENTIFIER 1128875079
+CONSTANT: AD_COUNTERCLOCKWISE 1
+CONSTANT: AD_CLOCKWISE 2
+CONSTANT: RDH_RECTANGLES 1
+CONSTANT: GCPCLASS_LATIN 1
+CONSTANT: GCPCLASS_HEBREW 2
+CONSTANT: GCPCLASS_ARABIC 2
+CONSTANT: GCPCLASS_NEUTRAL 3
+CONSTANT: GCPCLASS_LOCALNUMBER 4
+CONSTANT: GCPCLASS_LATINNUMBER 5
+CONSTANT: GCPCLASS_LATINNUMERICTERMINATOR 6
+CONSTANT: GCPCLASS_LATINNUMERICSEPARATOR 7
+CONSTANT: GCPCLASS_NUMERICSEPARATOR 8
+CONSTANT: GCPCLASS_PREBOUNDLTR 128
+CONSTANT: GCPCLASS_PREBOUNDRTL 64
+CONSTANT: GCPCLASS_POSTBOUNDLTR 32
+CONSTANT: GCPCLASS_POSTBOUNDRTL 16
+CONSTANT: GCPGLYPH_LINKBEFORE HEX: 8000
+CONSTANT: GCPGLYPH_LINKAFTER HEX: 4000
+CONSTANT: DCB_DISABLE 8
+CONSTANT: DCB_ENABLE 4
+CONSTANT: DCB_RESET 1
+CONSTANT: DCB_SET 3
+CONSTANT: DCB_ACCUMULATE 2
+CONSTANT: DCB_DIRTY 2
+CONSTANT: OBJ_BRUSH 2
+CONSTANT: OBJ_PEN 1
+CONSTANT: OBJ_PAL 5
+CONSTANT: OBJ_FONT 6
+CONSTANT: OBJ_BITMAP 7
+CONSTANT: OBJ_EXTPEN 11
+CONSTANT: OBJ_REGION 8
+CONSTANT: OBJ_DC 3
+CONSTANT: OBJ_MEMDC 10
+CONSTANT: OBJ_METAFILE 9
+CONSTANT: OBJ_METADC 4
+CONSTANT: OBJ_ENHMETAFILE 13
+CONSTANT: OBJ_ENHMETADC 12
+CONSTANT: DRIVERVERSION 0
+CONSTANT: TECHNOLOGY 2
+CONSTANT: DT_PLOTTER 0
+CONSTANT: DT_RASDISPLAY 1
+CONSTANT: DT_RASPRINTER 2
+CONSTANT: DT_RASCAMERA 3
+CONSTANT: DT_CHARSTREAM 4
+CONSTANT: DT_METAFILE 5
+CONSTANT: DT_DISPFILE 6
+CONSTANT: HORZSIZE 4
+CONSTANT: VERTSIZE 6
+CONSTANT: HORZRES 8
+CONSTANT: VERTRES 10
+CONSTANT: LOGPIXELSX 88
+CONSTANT: LOGPIXELSY 90
+CONSTANT: BITSPIXEL 12
+CONSTANT: PLANES 14
+CONSTANT: NUMBRUSHES 16
+CONSTANT: NUMPENS 18
+CONSTANT: NUMFONTS 22
+CONSTANT: NUMCOLORS 24
+CONSTANT: NUMMARKERS 20
+CONSTANT: ASPECTX 40
+CONSTANT: ASPECTY 42
+CONSTANT: ASPECTXY 44
+CONSTANT: PDEVICESIZE 26
+CONSTANT: CLIPCAPS 36
+CONSTANT: SIZEPALETTE 104
+CONSTANT: NUMRESERVED 106
+CONSTANT: COLORRES 108
+CONSTANT: PHYSICALWIDTH 110
+CONSTANT: PHYSICALHEIGHT 111
+CONSTANT: PHYSICALOFFSETX 112
+CONSTANT: PHYSICALOFFSETY 113
+CONSTANT: SCALINGFACTORX 114
+CONSTANT: SCALINGFACTORY 115
+CONSTANT: VREFRESH 116
+CONSTANT: DESKTOPHORZRES 118
+CONSTANT: DESKTOPVERTRES 117
+CONSTANT: BLTALIGNMENT 119
+CONSTANT: SHADEBLENDCAPS 120
+CONSTANT: SB_NONE HEX: 00
+CONSTANT: SB_CONST_ALPHA HEX: 01
+CONSTANT: SB_PIXEL_ALPHA HEX: 02
+CONSTANT: SB_PREMULT_ALPHA HEX: 04
+CONSTANT: SB_GRAD_RECT HEX: 10
+CONSTANT: SB_GRAD_TRI HEX: 20
+CONSTANT: COLORMGMTCAPS 121
+CONSTANT: CM_NONE HEX: 00
+CONSTANT: CM_DEVICE_ICM HEX: 01
+CONSTANT: CM_GAMMA_RAMP HEX: 02
+CONSTANT: CM_CMYK_COLOR HEX: 04
+CONSTANT: RASTERCAPS 38
+CONSTANT: RC_BITBLT 1
+CONSTANT: RC_BITMAP64 8
+CONSTANT: RC_DI_BITMAP 128
+CONSTANT: RC_DIBTODEV 512
+CONSTANT: RC_FLOODFILL 4096
+CONSTANT: RC_STRETCHBLT 2048
+CONSTANT: RC_STRETCHDIB 8192
+CONSTANT: CURVECAPS 28
+CONSTANT: CC_NONE 0
+CONSTANT: CC_CIRCLES 1
+CONSTANT: CC_PIE 2
+CONSTANT: CC_CHORD 4
+CONSTANT: CC_ELLIPSES 8
+CONSTANT: CC_WIDE 16
+CONSTANT: CC_STYLED 32
+CONSTANT: CC_WIDESTYLED 64
+CONSTANT: CC_INTERIORS 128
+CONSTANT: CC_ROUNDRECT 256
+CONSTANT: LINECAPS 30
+CONSTANT: LC_NONE 0
+CONSTANT: LC_POLYLINE 2
+CONSTANT: LC_MARKER 4
+CONSTANT: LC_POLYMARKER 8
+CONSTANT: LC_WIDE 16
+CONSTANT: LC_STYLED 32
+CONSTANT: LC_WIDESTYLED 64
+CONSTANT: LC_INTERIORS 128
+CONSTANT: POLYGONALCAPS 32
+CONSTANT: RC_BANDING 2
+CONSTANT: RC_BIGFONT 1024
+CONSTANT: RC_DEVBITS HEX: 8000
+CONSTANT: RC_GDI20_OUTPUT 16
+CONSTANT: RC_GDI20_STATE 32
+CONSTANT: RC_NONE 0
+CONSTANT: RC_OP_DX_OUTPUT HEX: 4000
+CONSTANT: RC_PALETTE 256
+CONSTANT: RC_SAVEBITMAP 64
+CONSTANT: RC_SCALING 4
+CONSTANT: PC_NONE 0
+CONSTANT: PC_POLYGON 1
+CONSTANT: PC_POLYPOLYGON 256
+CONSTANT: PC_PATHS 512
+CONSTANT: PC_RECTANGLE 2
+CONSTANT: PC_WINDPOLYGON 4
+CONSTANT: PC_SCANLINE 8
+CONSTANT: PC_TRAPEZOID 4
+CONSTANT: PC_WIDE 16
+CONSTANT: PC_STYLED 32
+CONSTANT: PC_WIDESTYLED 64
+CONSTANT: PC_INTERIORS 128
+CONSTANT: TEXTCAPS 34
+CONSTANT: TC_OP_CHARACTER 1
+CONSTANT: TC_OP_STROKE 2
+CONSTANT: TC_CP_STROKE 4
+CONSTANT: TC_CR_90 8
+CONSTANT: TC_CR_ANY 16
+CONSTANT: TC_SF_X_YINDEP 32
+CONSTANT: TC_SA_DOUBLE 64
+CONSTANT: TC_SA_INTEGER 128
+CONSTANT: TC_SA_CONTIN 256
+CONSTANT: TC_EA_DOUBLE 512
+CONSTANT: TC_IA_ABLE 1024
+CONSTANT: TC_UA_ABLE 2048
+CONSTANT: TC_SO_ABLE 4096
+CONSTANT: TC_RA_ABLE 8192
+CONSTANT: TC_VA_ABLE 16384
+CONSTANT: TC_RESERVED 32768
+CONSTANT: TC_SCROLLBLT 65536
+CONSTANT: GCP_DBCS 1
+CONSTANT: GCP_ERROR HEX: 8000
+CONSTANT: GCP_CLASSIN HEX: 80000
+CONSTANT: GCP_DIACRITIC 256
+CONSTANT: GCP_DISPLAYZWG HEX: 400000
+CONSTANT: GCP_GLYPHSHAPE 16
+CONSTANT: GCP_JUSTIFY HEX: 10000
+CONSTANT: GCP_JUSTIFYIN HEX: 200000
+CONSTANT: GCP_KASHIDA 1024
+CONSTANT: GCP_LIGATE 32
+CONSTANT: GCP_MAXEXTENT HEX: 100000
+CONSTANT: GCP_NEUTRALOVERRIDE HEX: 2000000
+CONSTANT: GCP_NUMERICOVERRIDE HEX: 1000000
+CONSTANT: GCP_NUMERICSLATIN HEX: 4000000
+CONSTANT: GCP_NUMERICSLOCAL HEX: 8000000
+CONSTANT: GCP_REORDER 2
+CONSTANT: GCP_SYMSWAPOFF HEX: 800000
+CONSTANT: GCP_USEKERNING 8
+CONSTANT: FLI_GLYPHS HEX: 40000
+CONSTANT: FLI_MASK HEX: 103b
+CONSTANT: GGO_METRICS 0
+CONSTANT: GGO_BITMAP 1
+CONSTANT: GGO_NATIVE 2
+CONSTANT: GGO_BEZIER 3
+CONSTANT: GGO_GRAY2_BITMAP 4
+CONSTANT: GGO_GRAY4_BITMAP 5
+CONSTANT: GGO_GRAY8_BITMAP 6
+CONSTANT: GGO_GLYPH_INDEX 128
+CONSTANT: GGO_UNHINTED 256
+CONSTANT: GM_COMPATIBLE 1
+CONSTANT: GM_ADVANCED 2
+CONSTANT: MM_ANISOTROPIC 8
+CONSTANT: MM_HIENGLISH 5
+CONSTANT: MM_HIMETRIC 3
+CONSTANT: MM_ISOTROPIC 7
+CONSTANT: MM_LOENGLISH 4
+CONSTANT: MM_LOMETRIC 2
+CONSTANT: MM_TEXT 1
+CONSTANT: MM_TWIPS 6
+ALIAS: MM_MAX_FIXEDSCALE MM_TWIPS
+CONSTANT: ABSOLUTE 1
+CONSTANT: RELATIVE 2
+CONSTANT: PC_EXPLICIT 2
+CONSTANT: PC_NOCOLLAPSE 4
+CONSTANT: PC_RESERVED 1
+CONSTANT: CLR_NONE HEX: ffffffff
+ALIAS: CLR_INVALID CLR_NONE
+CONSTANT: CLR_DEFAULT HEX: ff000000
+CONSTANT: PT_MOVETO 6
+CONSTANT: PT_LINETO 2
+CONSTANT: PT_BEZIERTO 4
+CONSTANT: PT_CLOSEFIGURE 1
+CONSTANT: TT_AVAILABLE 1
+CONSTANT: TT_ENABLED 2
+CONSTANT: BLACK_BRUSH 4
+CONSTANT: DKGRAY_BRUSH 3
+CONSTANT: GRAY_BRUSH 2
+CONSTANT: HOLLOW_BRUSH 5
+CONSTANT: LTGRAY_BRUSH 1
+CONSTANT: NULL_BRUSH 5
+CONSTANT: WHITE_BRUSH 0
+CONSTANT: BLACK_PEN 7
+CONSTANT: NULL_PEN 8
+CONSTANT: WHITE_PEN 6
+CONSTANT: ANSI_FIXED_FONT 11
+CONSTANT: ANSI_VAR_FONT 12
+CONSTANT: DEVICE_DEFAULT_FONT 14
+CONSTANT: DEFAULT_GUI_FONT 17
+CONSTANT: OEM_FIXED_FONT 10
+CONSTANT: SYSTEM_FONT 13
+CONSTANT: SYSTEM_FIXED_FONT 16
+CONSTANT: DEFAULT_PALETTE 15
+CONSTANT: DC_BRUSH 18
+CONSTANT: DC_PEN 19
+CONSTANT: SYSPAL_ERROR 0
+CONSTANT: SYSPAL_STATIC 1
+CONSTANT: SYSPAL_NOSTATIC 2
+CONSTANT: SYSPAL_NOSTATIC256 3 
+CONSTANT: TA_BASELINE 24
+CONSTANT: TA_BOTTOM 8
+CONSTANT: TA_TOP 0
+CONSTANT: TA_CENTER 6
+CONSTANT: TA_LEFT 0
+CONSTANT: TA_RIGHT 2
+CONSTANT: TA_RTLREADING 256
+CONSTANT: TA_NOUPDATECP 0
+CONSTANT: TA_UPDATECP 1
+: TA_MASK ( -- n ) { TA_BASELINE TA_CENTER TA_UPDATECP TA_RTLREADING } flags ; foldable
+CONSTANT: VTA_BASELINE 24
+CONSTANT: VTA_CENTER 6
+ALIAS: VTA_LEFT TA_BOTTOM
+ALIAS: VTA_RIGHT TA_TOP
+ALIAS: VTA_BOTTOM TA_RIGHT
+ALIAS: VTA_TOP TA_LEFT
+CONSTANT: MWT_IDENTITY 1
+CONSTANT: MWT_LEFTMULTIPLY 2
+CONSTANT: MWT_RIGHTMULTIPLY 3
+CONSTANT: OPAQUE 2
+CONSTANT: TRANSPARENT 1
+CONSTANT: BLACKONWHITE 1
+CONSTANT: WHITEONBLACK 2
+CONSTANT: COLORONCOLOR 3
+CONSTANT: HALFTONE 4
+CONSTANT: MAXSTRETCHBLTMODE 4
+CONSTANT: STRETCH_ANDSCANS 1
+CONSTANT: STRETCH_DELETESCANS 3
+CONSTANT: STRETCH_HALFTONE 4
+CONSTANT: STRETCH_ORSCANS 2
+CONSTANT: TCI_SRCCHARSET 1
+CONSTANT: TCI_SRCCODEPAGE 2
+CONSTANT: TCI_SRCFONTSIG 3
+CONSTANT: ICM_ON 2
+CONSTANT: ICM_OFF 1
+CONSTANT: ICM_QUERY 3
+CONSTANT: NEWFRAME 1
+CONSTANT: ABORTDOC 2
+CONSTANT: NEXTBAND 3
+CONSTANT: SETCOLORTABLE 4
+CONSTANT: GETCOLORTABLE 5
+CONSTANT: FLUSHOUTPUT 6
+CONSTANT: DRAFTMODE 7
+CONSTANT: QUERYESCSUPPORT 8
+CONSTANT: SETABORTPROC 9
+CONSTANT: STARTDOC 10
+CONSTANT: ENDDOC 11
+CONSTANT: GETPHYSPAGESIZE 12
+CONSTANT: GETPRINTINGOFFSET 13
+CONSTANT: GETSCALINGFACTOR 14
+CONSTANT: MFCOMMENT 15
+CONSTANT: GETPENWIDTH 16
+CONSTANT: SETCOPYCOUNT 17
+CONSTANT: SELECTPAPERSOURCE 18
+CONSTANT: DEVICEDATA 19
+CONSTANT: PASSTHROUGH 19
+CONSTANT: GETTECHNOLGY 20
+CONSTANT: GETTECHNOLOGY 20
+CONSTANT: SETLINECAP 21
+CONSTANT: SETLINEJOIN 22
+CONSTANT: SETMITERLIMIT 23
+CONSTANT: BANDINFO 24
+CONSTANT: DRAWPATTERNRECT 25
+CONSTANT: GETVECTORPENSIZE 26
+CONSTANT: GETVECTORBRUSHSIZE 27
+CONSTANT: ENABLEDUPLEX 28
+CONSTANT: GETSETPAPERBINS 29
+CONSTANT: GETSETPRINTORIENT 30
+CONSTANT: ENUMPAPERBINS 31
+CONSTANT: SETDIBSCALING 32
+CONSTANT: EPSPRINTING 33
+CONSTANT: ENUMPAPERMETRICS 34
+CONSTANT: GETSETPAPERMETRICS 35
+CONSTANT: POSTSCRIPT_DATA 37
+CONSTANT: POSTSCRIPT_IGNORE 38
+CONSTANT: MOUSETRAILS 39
+CONSTANT: GETDEVICEUNITS 42
+CONSTANT: GETEXTENDEDTEXTMETRICS 256
+CONSTANT: GETEXTENTTABLE 257
+CONSTANT: GETPAIRKERNTABLE 258
+CONSTANT: GETTRACKKERNTABLE 259
+CONSTANT: EXTTEXTOUT 512
+CONSTANT: GETFACENAME 513
+CONSTANT: DOWNLOADFACE 514
+CONSTANT: ENABLERELATIVEWIDTHS 768
+CONSTANT: ENABLEPAIRKERNING 769
+CONSTANT: SETKERNTRACK 770
+CONSTANT: SETALLJUSTVALUES 771
+CONSTANT: SETCHARSET 772
+CONSTANT: STRETCHBLT 2048
+CONSTANT: GETSETSCREENPARAMS 3072
+CONSTANT: QUERYDIBSUPPORT 3073
+CONSTANT: BEGIN_PATH 4096
+CONSTANT: CLIP_TO_PATH 4097
+CONSTANT: END_PATH 4098
+CONSTANT: EXT_DEVICE_CAPS 4099
+CONSTANT: RESTORE_CTM 4100
+CONSTANT: SAVE_CTM 4101
+CONSTANT: SET_ARC_DIRECTION 4102
+CONSTANT: SET_BACKGROUND_COLOR 4103
+CONSTANT: SET_POLY_MODE 4104
+CONSTANT: SET_SCREEN_ANGLE 4105
+CONSTANT: SET_SPREAD 4106
+CONSTANT: TRANSFORM_CTM 4107
+CONSTANT: SET_CLIP_BOX 4108
+CONSTANT: SET_BOUNDS 4109
+CONSTANT: SET_MIRROR_MODE 4110
+CONSTANT: OPENCHANNEL 4110
+CONSTANT: DOWNLOADHEADER 4111
+CONSTANT: CLOSECHANNEL 4112
+CONSTANT: POSTSCRIPT_PASSTHROUGH 4115
+CONSTANT: ENCAPSULATED_POSTSCRIPT 4116
+CONSTANT: QDI_SETDIBITS 1
+CONSTANT: QDI_GETDIBITS 2
+CONSTANT: QDI_DIBTOSCREEN 4
+CONSTANT: QDI_STRETCHDIB 8
+CONSTANT: SP_NOTREPORTED HEX: 4000
+CONSTANT: PR_JOBSTATUS 0
+CONSTANT: ASPECT_FILTERING 1
+CONSTANT: BS_SOLID 0
+CONSTANT: BS_NULL 1
+CONSTANT: BS_HOLLOW 1
+CONSTANT: BS_HATCHED 2
+CONSTANT: BS_PATTERN 3
+CONSTANT: BS_INDEXED 4
+CONSTANT: BS_DIBPATTERN 5
+CONSTANT: BS_DIBPATTERNPT 6
+CONSTANT: BS_PATTERN8X8 7
+CONSTANT: BS_DIBPATTERN8X8 8
+CONSTANT: LCS_CALIBRATED_RGB 0
+CONSTANT: LCS_DEVICE_RGB 1
+CONSTANT: LCS_DEVICE_CMYK 2
+CONSTANT: LCS_GM_BUSINESS 1
+CONSTANT: LCS_GM_GRAPHICS 2
+CONSTANT: LCS_GM_IMAGES 4
+CONSTANT: RASTER_FONTTYPE 1
+CONSTANT: DEVICE_FONTTYPE 2
+CONSTANT: TRUETYPE_FONTTYPE 4
+CONSTANT: DMORIENT_PORTRAIT 1
+CONSTANT: DMORIENT_LANDSCAPE 2
+CONSTANT: DMPAPER_FIRST 1
+CONSTANT: DMPAPER_LETTER 1
+CONSTANT: DMPAPER_LETTERSMALL 2
+CONSTANT: DMPAPER_TABLOID 3
+CONSTANT: DMPAPER_LEDGER 4
+CONSTANT: DMPAPER_LEGAL 5
+CONSTANT: DMPAPER_STATEMENT 6
+CONSTANT: DMPAPER_EXECUTIVE 7
+CONSTANT: DMPAPER_A3 8
+CONSTANT: DMPAPER_A4 9
+CONSTANT: DMPAPER_A4SMALL 10
+CONSTANT: DMPAPER_A5 11
+CONSTANT: DMPAPER_B4 12
+CONSTANT: DMPAPER_B5 13
+CONSTANT: DMPAPER_FOLIO 14
+CONSTANT: DMPAPER_QUARTO 15
+CONSTANT: DMPAPER_10X14 16
+CONSTANT: DMPAPER_11X17 17
+CONSTANT: DMPAPER_NOTE 18
+CONSTANT: DMPAPER_ENV_9 19
+CONSTANT: DMPAPER_ENV_10 20
+CONSTANT: DMPAPER_ENV_11 21
+CONSTANT: DMPAPER_ENV_12 22
+CONSTANT: DMPAPER_ENV_14 23
+CONSTANT: DMPAPER_CSHEET 24
+CONSTANT: DMPAPER_DSHEET 25
+CONSTANT: DMPAPER_ESHEET 26
+CONSTANT: DMPAPER_ENV_DL 27
+CONSTANT: DMPAPER_ENV_C5 28
+CONSTANT: DMPAPER_ENV_C3 29
+CONSTANT: DMPAPER_ENV_C4 30
+CONSTANT: DMPAPER_ENV_C6 31
+CONSTANT: DMPAPER_ENV_C65 32
+CONSTANT: DMPAPER_ENV_B4 33
+CONSTANT: DMPAPER_ENV_B5 34
+CONSTANT: DMPAPER_ENV_B6 35
+CONSTANT: DMPAPER_ENV_ITALY 36
+CONSTANT: DMPAPER_ENV_MONARCH 37
+CONSTANT: DMPAPER_ENV_PERSONAL 38
+CONSTANT: DMPAPER_FANFOLD_US 39
+CONSTANT: DMPAPER_FANFOLD_STD_GERMAN 40
+CONSTANT: DMPAPER_FANFOLD_LGL_GERMAN 41
+CONSTANT: DMPAPER_ISO_B4 42
+CONSTANT: DMPAPER_JAPANESE_POSTCARD 43
+CONSTANT: DMPAPER_9X11 44
+CONSTANT: DMPAPER_10X11 45
+CONSTANT: DMPAPER_15X11 46
+CONSTANT: DMPAPER_ENV_INVITE 47
+CONSTANT: DMPAPER_RESERVED_48 48
+CONSTANT: DMPAPER_RESERVED_49 49
+CONSTANT: DMPAPER_LETTER_EXTRA 50
+CONSTANT: DMPAPER_LEGAL_EXTRA 51
+CONSTANT: DMPAPER_TABLOID_EXTRA 52
+CONSTANT: DMPAPER_A4_EXTRA 53
+CONSTANT: DMPAPER_LETTER_TRANSVERSE 54
+CONSTANT: DMPAPER_A4_TRANSVERSE 55
+CONSTANT: DMPAPER_LETTER_EXTRA_TRANSVERSE 56
+CONSTANT: DMPAPER_A_PLUS 57
+CONSTANT: DMPAPER_B_PLUS 58
+CONSTANT: DMPAPER_LETTER_PLUS 59
+CONSTANT: DMPAPER_A4_PLUS 60
+CONSTANT: DMPAPER_A5_TRANSVERSE 61
+CONSTANT: DMPAPER_B5_TRANSVERSE 62
+CONSTANT: DMPAPER_A3_EXTRA 63
+CONSTANT: DMPAPER_A5_EXTRA 64
+CONSTANT: DMPAPER_B5_EXTRA 65
+CONSTANT: DMPAPER_A2 66
+CONSTANT: DMPAPER_A3_TRANSVERSE 67
+CONSTANT: DMPAPER_A3_EXTRA_TRANSVERSE 68
+CONSTANT: DMPAPER_DBL_JAPANESE_POSTCARD 69
+CONSTANT: DMPAPER_A6 70
+CONSTANT: DMPAPER_JENV_KAKU2 71
+CONSTANT: DMPAPER_JENV_KAKU3 72
+CONSTANT: DMPAPER_JENV_CHOU3 73
+CONSTANT: DMPAPER_JENV_CHOU4 74
+CONSTANT: DMPAPER_LETTER_ROTATED 75
+CONSTANT: DMPAPER_A3_ROTATED 76
+CONSTANT: DMPAPER_A4_ROTATED 77
+CONSTANT: DMPAPER_A5_ROTATED 78
+CONSTANT: DMPAPER_B4_JIS_ROTATED 79
+CONSTANT: DMPAPER_B5_JIS_ROTATED 80
+CONSTANT: DMPAPER_JAPANESE_POSTCARD_ROTATED 81
+CONSTANT: DMPAPER_DBL_JAPANESE_POSTCARD_ROTATED 82
+CONSTANT: DMPAPER_A6_ROTATED 83
+CONSTANT: DMPAPER_JENV_KAKU2_ROTATED 84
+CONSTANT: DMPAPER_JENV_KAKU3_ROTATED 85
+CONSTANT: DMPAPER_JENV_CHOU3_ROTATED 86
+CONSTANT: DMPAPER_JENV_CHOU4_ROTATED 87
+CONSTANT: DMPAPER_B6_JIS 88
+CONSTANT: DMPAPER_B6_JIS_ROTATED 89
+CONSTANT: DMPAPER_12X11 90
+CONSTANT: DMPAPER_JENV_YOU4 91
+CONSTANT: DMPAPER_JENV_YOU4_ROTATED 92
+CONSTANT: DMPAPER_P16K 93
+CONSTANT: DMPAPER_P32K 94
+CONSTANT: DMPAPER_P32KBIG 95
+CONSTANT: DMPAPER_PENV_1 96
+CONSTANT: DMPAPER_PENV_2 97
+CONSTANT: DMPAPER_PENV_3 98
+CONSTANT: DMPAPER_PENV_4 99
+CONSTANT: DMPAPER_PENV_5 100
+CONSTANT: DMPAPER_PENV_6 101
+CONSTANT: DMPAPER_PENV_7 102
+CONSTANT: DMPAPER_PENV_8 103
+CONSTANT: DMPAPER_PENV_9 104
+CONSTANT: DMPAPER_PENV_10 105
+CONSTANT: DMPAPER_P16K_ROTATED 106
+CONSTANT: DMPAPER_P32K_ROTATED 107
+CONSTANT: DMPAPER_P32KBIG_ROTATED 108
+CONSTANT: DMPAPER_PENV_1_ROTATED 109
+CONSTANT: DMPAPER_PENV_2_ROTATED 110
+CONSTANT: DMPAPER_PENV_3_ROTATED 111
+CONSTANT: DMPAPER_PENV_4_ROTATED 112
+CONSTANT: DMPAPER_PENV_5_ROTATED 113
+CONSTANT: DMPAPER_PENV_6_ROTATED 114
+CONSTANT: DMPAPER_PENV_7_ROTATED 115
+CONSTANT: DMPAPER_PENV_8_ROTATED 116
+CONSTANT: DMPAPER_PENV_9_ROTATED 117
+CONSTANT: DMPAPER_PENV_10_ROTATED 118
+CONSTANT: DMPAPER_LAST 118
+CONSTANT: DMPAPER_USER 256
+CONSTANT: DMBIN_FIRST 1
+CONSTANT: DMBIN_UPPER 1
+CONSTANT: DMBIN_ONLYONE 1
+CONSTANT: DMBIN_LOWER 2
+CONSTANT: DMBIN_MIDDLE 3
+CONSTANT: DMBIN_MANUAL 4
+CONSTANT: DMBIN_ENVELOPE 5
+CONSTANT: DMBIN_ENVMANUAL 6
+CONSTANT: DMBIN_AUTO 7
+CONSTANT: DMBIN_TRACTOR 8
+CONSTANT: DMBIN_SMALLFMT 9
+CONSTANT: DMBIN_LARGEFMT 10
+CONSTANT: DMBIN_LARGECAPACITY 11
+CONSTANT: DMBIN_CASSETTE 14
+CONSTANT: DMBIN_FORMSOURCE 15
+CONSTANT: DMBIN_LAST 15
+CONSTANT: DMBIN_USER 256
+CONSTANT: DMRES_DRAFT -1
+CONSTANT: DMRES_LOW -2
+CONSTANT: DMRES_MEDIUM -3
+CONSTANT: DMRES_HIGH -4
+CONSTANT: DMCOLOR_MONOCHROME 1
+CONSTANT: DMCOLOR_COLOR 2
+CONSTANT: DMDUP_SIMPLEX 1
+CONSTANT: DMDUP_VERTICAL 2
+CONSTANT: DMDUP_HORIZONTAL 3
+CONSTANT: DMTT_BITMAP 1
+CONSTANT: DMTT_DOWNLOAD 2
+CONSTANT: DMTT_SUBDEV 3
+CONSTANT: DMTT_DOWNLOAD_OUTLINE 4
+CONSTANT: DMCOLLATE_FALSE 0
+CONSTANT: DMCOLLATE_TRUE 1
+CONSTANT: DM_SPECVERSION 800
+CONSTANT: DM_GRAYSCALE 1
+CONSTANT: DM_INTERLACED 2
+CONSTANT: DM_UPDATE 1
+CONSTANT: DM_COPY 2
+CONSTANT: DM_PROMPT 4
+CONSTANT: DM_MODIFY 8
+ALIAS: DM_IN_BUFFER DM_MODIFY
+ALIAS: DM_IN_PROMPT DM_PROMPT
+ALIAS: DM_OUT_BUFFER DM_COPY
+ALIAS: DM_OUT_DEFAULT DM_UPDATE
+CONSTANT: DM_ORIENTATION HEX: 00000001
+CONSTANT: DM_PAPERSIZE HEX: 00000002
+CONSTANT: DM_PAPERLENGTH HEX: 00000004
+CONSTANT: DM_PAPERWIDTH HEX: 00000008
+CONSTANT: DM_SCALE HEX: 00000010
+CONSTANT: DM_POSITION HEX: 00000020
+CONSTANT: DM_COPIES HEX: 00000100
+CONSTANT: DM_DEFAULTSOURCE HEX: 00000200
+CONSTANT: DM_PRINTQUALITY HEX: 00000400
+CONSTANT: DM_COLOR HEX: 00000800
+CONSTANT: DM_DUPLEX HEX: 00001000
+CONSTANT: DM_YRESOLUTION HEX: 00002000
+CONSTANT: DM_TTOPTION HEX: 00004000
+CONSTANT: DM_COLLATE HEX: 00008000
+CONSTANT: DM_FORMNAME HEX: 00010000
+CONSTANT: DM_LOGPIXELS HEX: 00020000
+CONSTANT: DM_BITSPERPEL HEX: 00040000
+CONSTANT: DM_PELSWIDTH HEX: 00080000
+CONSTANT: DM_PELSHEIGHT HEX: 00100000
+CONSTANT: DM_DISPLAYFLAGS HEX: 00200000
+CONSTANT: DM_DISPLAYFREQUENCY HEX: 00400000
+CONSTANT: DM_ICMMETHOD HEX: 00800000
+CONSTANT: DM_ICMINTENT HEX: 01000000
+CONSTANT: DM_MEDIATYPE HEX: 02000000
+CONSTANT: DM_DITHERTYPE HEX: 04000000
+CONSTANT: DM_PANNINGWIDTH HEX: 08000000
+CONSTANT: DM_PANNINGHEIGHT HEX: 10000000
+CONSTANT: DM_DISPLAYFIXEDOUTPUT HEX: 20000000
+CONSTANT: DM_DISPLAYORIENTATION HEX: 00000080
+CONSTANT: DMDO_DEFAULT HEX: 00000000
+CONSTANT: DMDO_90 HEX: 00000001
+CONSTANT: DMDO_180 HEX: 00000002
+CONSTANT: DMDO_270 HEX: 00000003
+CONSTANT: DMDFO_DEFAULT HEX: 00000000
+CONSTANT: DMDFO_STRETCH HEX: 00000001
+CONSTANT: DMDFO_CENTER HEX: 00000002
+CONSTANT: DMICMMETHOD_NONE 1
+CONSTANT: DMICMMETHOD_SYSTEM 2
+CONSTANT: DMICMMETHOD_DRIVER 3
+CONSTANT: DMICMMETHOD_DEVICE 4
+CONSTANT: DMICMMETHOD_USER 256
+CONSTANT: DMICM_SATURATE 1
+CONSTANT: DMICM_CONTRAST 2
+CONSTANT: DMICM_COLORMETRIC 3
+CONSTANT: DMICM_USER 256
+CONSTANT: DMMEDIA_STANDARD 1
+CONSTANT: DMMEDIA_TRANSPARENCY 2
+CONSTANT: DMMEDIA_GLOSSY 3
+CONSTANT: DMMEDIA_USER 256
+CONSTANT: DMDITHER_NONE 1
+CONSTANT: DMDITHER_COARSE 2
+CONSTANT: DMDITHER_FINE 3
+CONSTANT: DMDITHER_LINEART 4
+CONSTANT: DMDITHER_ERRORDIFFUSION 5
+CONSTANT: DMDITHER_RESERVED6 6
+CONSTANT: DMDITHER_RESERVED7 7
+CONSTANT: DMDITHER_RESERVED8 8
+CONSTANT: DMDITHER_RESERVED9 9
+CONSTANT: DMDITHER_GRAYSCALE 10
+CONSTANT: DMDITHER_USER 256
+CONSTANT: GDI_ERROR HEX: FFFFFFFF
+: HGDI_ERROR ( -- alien ) GDI_ERROR <alien> ; inline
+CONSTANT: TMPF_FIXED_PITCH 1
+CONSTANT: TMPF_VECTOR 2
+CONSTANT: TMPF_TRUETYPE 4
+CONSTANT: TMPF_DEVICE 8
+CONSTANT: NTM_ITALIC 1
+CONSTANT: NTM_BOLD 32
+CONSTANT: NTM_REGULAR 64
+CONSTANT: TT_POLYGON_TYPE 24
+CONSTANT: TT_PRIM_LINE 1
+CONSTANT: TT_PRIM_QSPLINE 2
+CONSTANT: TT_PRIM_CSPLINE 3 
+CONSTANT: FONTMAPPER_MAX 10
+CONSTANT: ENHMETA_STOCK_OBJECT HEX: 80000000
+CONSTANT: WGL_FONT_LINES 0
+CONSTANT: WGL_FONT_POLYGONS 1
+CONSTANT: LPD_DOUBLEBUFFER 1
+CONSTANT: LPD_STEREO 2
+CONSTANT: LPD_SUPPORT_GDI 16
+CONSTANT: LPD_SUPPORT_OPENGL 32
+CONSTANT: LPD_SHARE_DEPTH 64
+CONSTANT: LPD_SHARE_STENCIL 128
+CONSTANT: LPD_SHARE_ACCUM 256
+CONSTANT: LPD_SWAP_EXCHANGE 512
+CONSTANT: LPD_SWAP_COPY 1024
+CONSTANT: LPD_TRANSPARENT 4096
+CONSTANT: LPD_TYPE_RGBA 0
+CONSTANT: LPD_TYPE_COLORINDEX 1
+CONSTANT: WGL_SWAP_MAIN_PLANE 1
+CONSTANT: WGL_SWAP_OVERLAY1 2
+CONSTANT: WGL_SWAP_OVERLAY2 4
+CONSTANT: WGL_SWAP_OVERLAY3 8
+CONSTANT: WGL_SWAP_OVERLAY4 16
+CONSTANT: WGL_SWAP_OVERLAY5 32
+CONSTANT: WGL_SWAP_OVERLAY6 64
+CONSTANT: WGL_SWAP_OVERLAY7 128
+CONSTANT: WGL_SWAP_OVERLAY8 256
+CONSTANT: WGL_SWAP_OVERLAY9 512
+CONSTANT: WGL_SWAP_OVERLAY10 1024
+CONSTANT: WGL_SWAP_OVERLAY11 2048
+CONSTANT: WGL_SWAP_OVERLAY12 4096
+CONSTANT: WGL_SWAP_OVERLAY13 8192
+CONSTANT: WGL_SWAP_OVERLAY14 16384
+CONSTANT: WGL_SWAP_OVERLAY15 32768
+CONSTANT: WGL_SWAP_UNDERLAY1 65536
+CONSTANT: WGL_SWAP_UNDERLAY2 HEX: 20000
+CONSTANT: WGL_SWAP_UNDERLAY3 HEX: 40000
+CONSTANT: WGL_SWAP_UNDERLAY4 HEX: 80000
+CONSTANT: WGL_SWAP_UNDERLAY5 HEX: 100000
+CONSTANT: WGL_SWAP_UNDERLAY6 HEX: 200000
+CONSTANT: WGL_SWAP_UNDERLAY7 HEX: 400000
+CONSTANT: WGL_SWAP_UNDERLAY8 HEX: 800000
+CONSTANT: WGL_SWAP_UNDERLAY9 HEX: 1000000
+CONSTANT: WGL_SWAP_UNDERLAY10 HEX: 2000000
+CONSTANT: WGL_SWAP_UNDERLAY11 HEX: 4000000
+CONSTANT: WGL_SWAP_UNDERLAY12 HEX: 8000000
+CONSTANT: WGL_SWAP_UNDERLAY13 HEX: 10000000
+CONSTANT: WGL_SWAP_UNDERLAY14 HEX: 20000000
+CONSTANT: WGL_SWAP_UNDERLAY15 HEX: 40000000
+CONSTANT: AC_SRC_OVER HEX: 00
+CONSTANT: AC_SRC_ALPHA HEX: 01
+CONSTANT: AC_SRC_NO_PREMULT_ALPHA HEX: 01
+CONSTANT: AC_SRC_NO_ALPHA HEX: 02
+CONSTANT: AC_DST_NO_PREMULT_ALPHA HEX: 10
+CONSTANT: AC_DST_NO_ALPHA HEX: 20
+CONSTANT: LAYOUT_RTL 1
+CONSTANT: LAYOUT_BITMAPORIENTATIONPRESERVED 8
+CONSTANT: CS_ENABLE HEX: 00000001
+CONSTANT: CS_DISABLE HEX: 00000002
+CONSTANT: CS_DELETE_TRANSFORM HEX: 00000003
+CONSTANT: GRADIENT_FILL_RECT_H HEX: 00
+CONSTANT: GRADIENT_FILL_RECT_V HEX: 01
+CONSTANT: GRADIENT_FILL_TRIANGLE HEX: 02
+CONSTANT: GRADIENT_FILL_OP_FLAG HEX: ff
+CONSTANT: COLORMATCHTOTARGET_EMBEDED HEX: 00000001
+CONSTANT: CREATECOLORSPACE_EMBEDED HEX: 00000001
+CONSTANT: SETICMPROFILE_EMBEDED HEX: 00000001
+
+CONSTANT: DISPLAY_DEVICE_ATTACHED_TO_DESKTOP HEX: 00000001
+CONSTANT: DISPLAY_DEVICE_MULTI_DRIVER HEX: 00000002
+CONSTANT: DISPLAY_DEVICE_PRIMARY_DEVICE HEX: 00000004
+CONSTANT: DISPLAY_DEVICE_MIRRORING_DRIVER HEX: 00000008
+CONSTANT: DISPLAY_DEVICE_VGA_COMPATIBLE HEX: 00000010
+CONSTANT: DISPLAY_DEVICE_REMOVABLE HEX: 00000020
+CONSTANT: DISPLAY_DEVICE_MODESPRUNED HEX: 08000000
+
+CONSTANT: NTM_NONNEGATIVE_AC HEX: 00010000
+CONSTANT: NTM_PS_OPENTYPE HEX: 00020000
+CONSTANT: NTM_TT_OPENTYPE HEX: 00040000
+CONSTANT: NTM_MULTIPLEMASTER HEX: 00080000
+CONSTANT: NTM_TYPE1 HEX: 00100000
+CONSTANT: NTM_DSIG HEX: 00200000
+
+CONSTANT: GGI_MARK_NONEXISTING_GLYPHS 1
 
 LIBRARY: gdi32
 
@@ -100,7 +1335,8 @@ FUNCTION: HBITMAP CreateDIBSection ( HDC hdc, BITMAPINFO* pbmi, UINT iUsage, voi
 ! FUNCTION: CreateFontIndirectExA
 ! FUNCTION: CreateFontIndirectExW
 ! FUNCTION: CreateFontIndirectW
-! FUNCTION: CreateFontW
+FUNCTION: HFONT CreateFontW ( int nHeight, int nWidth, int nEscapement, int nOrientation, int fnWeight, DWORD fdwItalic, DWORD fdwUnderline, DWORD fdwStrikeOut, DWORD fdwCharSet, DWORD fdwOutputPrecision, DWORD fdwClipPrecision, DWORD fdwQuality, DWORD fdwPitchAndFamily, LPCTSTR lpszFace ) ;
+ALIAS: CreateFont CreateFontW
 ! FUNCTION: CreateHalftonePalette
 ! FUNCTION: CreateHatchBrush
 ! FUNCTION: CreateICA
@@ -262,7 +1498,8 @@ DESTRUCTOR: DeleteObject
 ! FUNCTION: ExtFloodFill
 ! FUNCTION: ExtSelectClipRgn
 ! FUNCTION: ExtTextOutA
-! FUNCTION: ExtTextOutW
+FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ;
+ALIAS: ExtTextOut ExtTextOutW
 ! FUNCTION: FillPath
 ! FUNCTION: FillRgn
 ! FUNCTION: FixBrushOrgEx
@@ -486,7 +1723,8 @@ FUNCTION: HGDIOBJ GetStockObject ( int fnObject ) ;
 ! FUNCTION: GetTextFaceAliasW
 ! FUNCTION: GetTextFaceW
 ! FUNCTION: GetTextMetricsA
-! FUNCTION: GetTextMetricsW
+FUNCTION: BOOL GetTextMetricsW ( HDC hdc, LPTEXTMETRIC lptm ) ;
+ALIAS: GetTextMetrics GetTextMetricsW
 ! FUNCTION: GetTransform
 ! FUNCTION: GetViewportExtEx
 ! FUNCTION: GetViewportOrgEx
@@ -569,15 +1807,15 @@ FUNCTION: HGDIOBJ SelectObject ( HDC hdc, HGDIOBJ hgdiobj ) ;
 ! FUNCTION: SetBitmapAttributes
 ! FUNCTION: SetBitmapBits
 ! FUNCTION: SetBitmapDimensionEx
-! FUNCTION: SetBkColor
+FUNCTION: COLORREF SetBkColor ( HDC hdc, COLORREF color ) ;
 ! FUNCTION: SetBkMode
 ! FUNCTION: SetBoundsRect
 ! FUNCTION: SetBrushAttributes
 ! FUNCTION: SetBrushOrgEx
 ! FUNCTION: SetColorAdjustment
 ! FUNCTION: SetColorSpace
-! FUNCTION: SetDCBrushColor
-! FUNCTION: SetDCPenColor
+FUNCTION: COLORREF SetDCBrushColor ( HDC hdc, COLORREF color ) ;
+FUNCTION: COLORREF SetDCPenColor ( HDC hdc, COLORREF color ) ;
 ! FUNCTION: SetDeviceGammaRamp
 ! FUNCTION: SetDIBColorTable
 ! FUNCTION: SetDIBits
@@ -608,7 +1846,8 @@ FUNCTION: BOOL SetPixelFormat ( HDC hDC, int iPixelFormat, PFD* ppfd ) ;
 ! FUNCTION: SetSystemPaletteUse
 ! FUNCTION: SetTextAlign
 ! FUNCTION: SetTextCharacterExtra
-! FUNCTION: SetTextColor
+FUNCTION: COLORREF SetTextColor ( HDC hdc, COLORREF crColor ) ;
+! FUNCTION: SetTextColor ( HDC hDC, 
 ! FUNCTION: SetTextJustification
 ! FUNCTION: SetViewportExtEx
 ! FUNCTION: SetViewportOrgEx
diff --git a/basis/windows/offscreen/offscreen-tests.factor b/basis/windows/offscreen/offscreen-tests.factor
new file mode 100755
index 0000000000..58273979b7
--- /dev/null
+++ b/basis/windows/offscreen/offscreen-tests.factor
@@ -0,0 +1,5 @@
+IN: windows.offscreen.tests
+USING: windows.offscreen effects tools.test kernel images ;
+
+{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as
+[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test
diff --git a/basis/windows/offscreen/offscreen.factor b/basis/windows/offscreen/offscreen.factor
old mode 100644
new mode 100755
index 4eee68c37a..6e65958220
--- a/basis/windows/offscreen/offscreen.factor
+++ b/basis/windows/offscreen/offscreen.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types kernel combinators sequences
 math windows.gdi32 windows.types images destructors
-accessors fry ;
+accessors fry locals ;
 IN: windows.offscreen
 
 : (bitmap-info) ( dim -- BITMAPINFO )
@@ -22,26 +22,32 @@ IN: windows.offscreen
         } 2cleave
     ] keep ;
 
-: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
-    f CreateCompatibleDC
+: make-bitmap ( dim dc -- hBitmap bits )
     [ nip ]
     [
         swap (bitmap-info) DIB_RGB_COLORS f <void*>
         [ f 0 CreateDIBSection ] keep *void*
     ] 2bi
-    [ 2dup SelectObject drop ] dip ;
+    [ [ SelectObject drop ] keep ] dip ;
+
+: make-offscreen-dc-and-bitmap ( dim -- dc hBitmap bits )
+    [ f CreateCompatibleDC ] dip over make-bitmap ;
 
 : bitmap>byte-array ( bits dim -- byte-array )
     product 4 * memory>byte-array ;
 
 : bitmap>image ( bits dim -- image )
     [ bitmap>byte-array ] keep
-    <image> swap >>dim swap >>bitmap XBGR >>component-order ;
+    <image>
+        swap >>dim
+        swap >>bitmap
+        BGRX >>component-order
+        t >>upside-down? ;
 
-: make-bitmap-image ( dim quot: ( hDC -- ) -- image )
-    '[
-        [
-            make-offscreen-dc-and-bitmap
-            [ &DeleteDC @ ] [ &DeleteObject drop ] [ ] tri*
-        ] keep bitmap>byte-array
-    ] with-destructors ; inline
\ No newline at end of file
+: with-memory-dc ( quot: ( hDC -- ) -- )
+    [ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline
+
+:: make-bitmap-image ( dim dc quot -- image )
+    dim dc make-bitmap [ &DeleteObject drop ] dip
+    quot dip
+    dim bitmap>image ; inline
\ No newline at end of file
diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor
index ee74e47fea..20bae06f30 100755
--- a/basis/windows/types/types.factor
+++ b/basis/windows/types/types.factor
@@ -1,6 +1,7 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.syntax namespaces kernel words ;
+USING: alien alien.c-types alien.syntax namespaces kernel words
+sequences math math.bitwise math.vectors colors ;
 IN: windows.types
 
 TYPEDEF: char                CHAR
@@ -244,14 +245,14 @@ C-STRUCT: RECT
     { "LONG" "right" }
     { "LONG" "bottom" } ;
 
-! C-STRUCT: PAINTSTRUCT
-    ! { "HDC" " hdc" }
-    ! { "BOOL" "fErase" }
-    ! { "RECT" "rcPaint" }
-    ! { "BOOL" "fRestore" }
-    ! { "BOOL" "fIncUpdate" }
-    ! { "BYTE[32]" "rgbReserved" }
-! ;
+C-STRUCT: PAINTSTRUCT
+    { "HDC" " hdc" }
+    { "BOOL" "fErase" }
+    { "RECT" "rcPaint" }
+    { "BOOL" "fRestore" }
+    { "BOOL" "fIncUpdate" }
+    { "BYTE[32]" "rgbReserved" }
+;
 
 C-STRUCT: BITMAPINFOHEADER
     { "DWORD"  "biSize" }
@@ -283,6 +284,10 @@ C-STRUCT: POINT
     { "LONG" "x" }
     { "LONG" "y" } ; 
 
+C-STRUCT: SIZE
+    { "LONG" "cx" }
+    { "LONG" "cy" } ; 
+
 C-STRUCT: MSG
     { "HWND" "hWnd" }
     { "UINT" "message" }
@@ -327,6 +332,14 @@ C-STRUCT: RECT
     { "LONG" "right" }
     { "LONG" "bottom" } ;
 
+: <RECT> ( loc dim -- RECT )
+    over v+
+    "RECT" <c-object>
+    over first over set-RECT-right
+    swap second over set-RECT-bottom
+    over first over set-RECT-left
+    swap second over set-RECT-top ;
+
 TYPEDEF: RECT* PRECT
 TYPEDEF: RECT* LPRECT
 TYPEDEF: PIXELFORMATDESCRIPTOR PFD
@@ -363,3 +376,36 @@ C-STRUCT: ACCEL
     { "WORD" "key" }
     { "WORD" "cmd" } ;
 TYPEDEF: ACCEL* LPACCEL
+
+TYPEDEF: DWORD COLORREF
+TYPEDEF: DWORD* LPCOLORREF
+
+: RGB ( r g b -- COLORREF )
+    { 16 8 0 } bitfield ; inline
+
+: color>RGB ( color -- COLORREF )
+    >rgba-components drop [ 255 * >integer ] tri@ RGB ;
+
+C-STRUCT: TEXTMETRICW
+    { "LONG" "tmHeight" }
+    { "LONG" "tmAscent" }
+    { "LONG" "tmDescent" }
+    { "LONG" "tmInternalLeading" }
+    { "LONG" "tmExternalLeading" }
+    { "LONG" "tmAveCharWidth" }
+    { "LONG" "tmMaxCharWidth" }
+    { "LONG" "tmWeight" }
+    { "LONG" "tmOverhang" }
+    { "LONG" "tmDigitizedAspectX" }
+    { "LONG" "tmDigitizedAspectY" }
+    { "WCHAR" "tmFirstChar" }
+    { "WCHAR" "tmLastChar" }
+    { "WCHAR" "tmDefaultChar" }
+    { "WCHAR" "tmBreakChar" }
+    { "BYTE" "tmItalic" }
+    { "BYTE" "tmUnderlined" }
+    { "BYTE" "tmStruckOut" }
+    { "BYTE" "tmPitchAndFamily" }
+    { "BYTE" "tmCharSet" } ;
+
+TYPEDEF: TEXTMETRICW* LPTEXTMETRIC
diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
old mode 100644
new mode 100755
index 5d24601555..cfd723ae8f
--- a/basis/windows/uniscribe/uniscribe.factor
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -1,65 +1,95 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel math sequences io.encodings.string io.encodings.utf16n
-accessors arrays destructors alien.c-types windows windows.usp10
-windows.offscreen ;
+USING: kernel assocs math sequences fry io.encodings.string
+io.encodings.utf16n accessors arrays combinators destructors
+cache namespaces init images.normalization alien.c-types locals
+windows windows.usp10 windows.offscreen windows.gdi32
+windows.ole32 windows.types windows.fonts ;
 IN: windows.uniscribe
 
-TUPLE: script-string pssa size image ;
+TUPLE: script-string metrics ssa size image string disposed ;
 
 : make-script-string ( dc string -- script-string )
     [ utf16n encode ] ! pString
     [ length ] bi ! cString
-    dup 1.5 * 16 + ! cGlyphs -- MSDN says this is "recommended size"
+    dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
     -1 ! iCharset -- Unicode
     SSA_GLYPHS ! dwFlags
-    ... ! iReqWidth
+    0 ! iReqWidth
     f ! psControl
     f ! psState
     f ! piDx
     f ! pTabdef
-    ... ! pbInClass
+    f ! pbInClass
     f <void*> ! pssa
     [ ScriptStringAnalyse ] keep
-    [ win32-error=0/f ] [ |ScriptStringFree ] bi* ;
+    [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
 
-: draw-script-string ( script-string -- bitmap )
+: draw-script-string ( script-string -- )
     ! ssa
     0 ! iX
     0 ! iY
-    ETO_OPAQUE ! uOptions ... ????
+    0 ! uOptions
     f ! prc
     0 ! iMinSel
     0 ! iMaxSel
-    f ! fDisabled
-    ScriptStringOut ;
+    FALSE ! fDisabled
+    ScriptStringOut ole32-error ;
 
-: <script-string> ( string -- script-string )
-    [
-        ... dim ... [
-            make-script-string |ScriptStringFree
-            [ ]
-            [ draw-script-string ]
-            [
-                ScriptString_pSize
-                dup win32-error=0/f
-                [ SIZE-cx ] [ SIZE-cy ] bi 2array
-            ] tri
-        ] make-bitmap-image
-        script-string boa
-    ] with-destructors ;
+: set-dc-font ( dc font -- )
+    [ cache-font SelectObject win32-error=0/f ]
+    [ background>> color>RGB SetBkColor drop ]
+    [ foreground>> color>RGB SetTextColor drop ] 2tri ;
 
-M: script-string dispose* pssa>> ScriptStringFree win32-error=0/f ;
+: script-string-size ( ssa -- dim )
+    ScriptString_pSize
+    dup win32-error=0/f
+    [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
 
-: line-offset>x ( offset script-string -- x )
-    pssa>> ! ssa
-    swap ! icp
-    ... ! fTrailing
-    0 <int> [ ScriptStringCPtoX win32-error=0/f ] keep *int ;
+: dc-metrics ( dc -- metrics )
+    "TEXTMETRICW" <c-object> [ GetTextMetrics drop ] keep
+    TEXTMETRIC>metrics ;
 
-: line-x>offset ( x script-string -- offset trailing )
-    pssa>> ! ssa
+:: <script-string> ( font string -- script-string )
+    #! Comments annotate BOA constructor arguments
+    [| dc |
+        dc font set-dc-font
+        dc dc-metrics ! metrics
+        dc string make-script-string dup :> ssa ! ssa
+        dup script-string-size ! size
+        dup dc [ ssa draw-script-string ] make-bitmap-image
+        normalize-image ! image
+        string ! string
+        f script-string boa
+    ] with-memory-dc ;
+
+: text-position ( script-string -- loc ) drop { 0 0 } ;
+
+M: script-string dispose* ssa>> <void*> ScriptStringFree ole32-error ;
+
+SYMBOL: cached-script-strings
+
+: cached-script-string ( string font -- script-string )
+    cached-script-strings get-global [ <script-string> ] 2cache ;
+
+[ <cache-assoc> cached-script-strings set-global ]
+"windows.uniscribe" add-init-hook
+
+: line-offset>x ( n script-string -- x )
+    2dup string>> length = [
+        ssa>> ! ssa
+        swap 1- ! icp
+        TRUE ! fTrailing
+    ] [
+        ssa>>
+        swap ! icp
+        FALSE ! fTrailing
+    ] if
+    0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
+
+: x>line-offset ( x script-string -- n trailing )
+    ssa>> ! ssa
     swap ! iX
     0 <int> ! pCh
     0 <int> ! piTrailing
-    [ ScriptStringXtoCP win32-error=0/f ] 2keep [ *int ] bi@ ;
\ No newline at end of file
+    [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
\ No newline at end of file

From dba42f92593b441f6c6cffac5d9e404adf578a20 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Thu, 2 Apr 2009 13:07:45 -0500
Subject: [PATCH 091/135] Remove DLL-downloading logic since we don't have
 external deps anymore

---
 basis/tools/deploy/windows/windows.factor |  9 +--------
 build-support/dlls.txt                    | 12 ------------
 build-support/factor.sh                   | 12 ------------
 extra/mason/child/child.factor            | 14 +-------------
 4 files changed, 2 insertions(+), 45 deletions(-)
 delete mode 100644 build-support/dlls.txt
 mode change 100644 => 100755 extra/mason/child/child.factor

diff --git a/basis/tools/deploy/windows/windows.factor b/basis/tools/deploy/windows/windows.factor
index bfa096ad2f..f21f4ac363 100755
--- a/basis/tools/deploy/windows/windows.factor
+++ b/basis/tools/deploy/windows/windows.factor
@@ -9,11 +9,6 @@ IN: tools.deploy.windows
 : copy-dll ( bundle-name -- )
     "resource:factor.dll" swap copy-file-into ;
 
-: copy-pango ( bundle-name -- )
-    "resource:build-support/dlls.txt" ascii file-lines
-    [ "resource:" prepend-path ] map
-    swap copy-files-into ;
-
 :: copy-vm ( executable bundle-name extension -- vm )
     vm "." split1-last drop extension append
     bundle-name executable ".exe" append append-path
@@ -22,9 +17,7 @@ IN: tools.deploy.windows
 : create-exe-dir ( vocab bundle-name -- vm )
     dup copy-dll
     deploy-ui? get [
-        [ copy-pango ]
-        [ "" copy-theme ]
-        [ ".exe" copy-vm ] tri
+        [ "" copy-theme ] [ ".exe" copy-vm ] bi
     ] [ ".com" copy-vm ] if ;
 
 M: winnt deploy*
diff --git a/build-support/dlls.txt b/build-support/dlls.txt
deleted file mode 100644
index 97d0cf6e9c..0000000000
--- a/build-support/dlls.txt
+++ /dev/null
@@ -1,12 +0,0 @@
-libcairo-2.dll
-libgio-2.0-0.dll
-libglib-2.0-0.dll
-libgmodule-2.0-0.dll
-libgobject-2.0-0.dll
-libgthread-2.0-0.dll
-libpango-1.0-0.dll
-libpangocairo-1.0-0.dll
-libpangowin32-1.0-0.dll
-libpng12-0.dll
-libtiff3.dll
-zlib1.dll
diff --git a/build-support/factor.sh b/build-support/factor.sh
index 61450dacb4..ad64c541fe 100755
--- a/build-support/factor.sh
+++ b/build-support/factor.sh
@@ -445,16 +445,6 @@ get_url() {
     check_ret $DOWNLOADER
 }
 
-maybe_download_dlls() {
-    if [[ $OS == winnt ]] ; then
-	for file in `cat build-support/dlls.txt`; do
-	    get_url http://factorcode.org/dlls/$file
-            chmod 777 *.dll
-            check_ret chmod
-	done
-    fi
-}
-
 get_config_info() {
     find_build_info
     check_installed_programs
@@ -472,7 +462,6 @@ install() {
     cd_factor
     make_factor
     get_boot_image
-    maybe_download_dlls
     bootstrap
 }
 
@@ -547,7 +536,6 @@ case "$1" in
     update) update; update_bootstrap ;;
     bootstrap) get_config_info; bootstrap ;;
     report) find_build_info ;;
-    dlls) get_config_info; maybe_download_dlls;;
     net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
     make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
     *) usage ;;
diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor
old mode 100644
new mode 100755
index 04c4a09f61..2ed9226524
--- a/extra/mason/child/child.factor
+++ b/extra/mason/child/child.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008, 2009 Eduardo Cavazos, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays calendar combinators.short-circuit
-continuations debugger http.client io.directories io.files io.launcher
+continuations debugger io.directories io.files io.launcher
 io.pathnames io.encodings.ascii kernel make mason.common mason.config
 mason.platform mason.report mason.email namespaces sequences ;
 IN: mason.child
@@ -9,20 +9,8 @@ IN: mason.child
 : make-cmd ( -- args )
     gnu-make platform 2array ;
 
-: dll-url ( -- url )
-    "http://factorcode.org/dlls/"
-    target-cpu get "x86.64" = [ "64/" append ] when ;
-
-: download-dlls ( -- )
-    target-os get "winnt" = [
-        dll-url "build-support/dlls.txt" ascii file-lines
-        [ append download ] with each
-    ] when ;
-
 : make-vm ( -- )
     "factor" [
-        download-dlls
-
         <process>
             make-cmd >>command
             "../compile-log" >>stdout

From 2c556fbb655f6aa93f83994671a9e5ca34e352e2 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Thu, 2 Apr 2009 13:11:06 -0500
Subject: [PATCH 092/135] Better error message printout in extra/descriptive

---
 extra/descriptive/descriptive.factor | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

diff --git a/extra/descriptive/descriptive.factor b/extra/descriptive/descriptive.factor
index ba3438e37d..ceadc9fe6e 100755
--- a/extra/descriptive/descriptive.factor
+++ b/extra/descriptive/descriptive.factor
@@ -1,13 +1,16 @@
 USING: words kernel sequences locals locals.parser
 locals.definitions accessors parser namespaces continuations
-summary definitions generalizations arrays ;
+summary definitions generalizations arrays prettyprint debugger io ;
 IN: descriptive
 
 ERROR: descriptive-error args underlying word ;
 
-M: descriptive-error summary
-    word>> "The " swap name>> " word encountered an error."
-    3append ;
+M: descriptive-error error.
+    "The word " write dup word>> pprint " encountered an error." print
+    "Arguments:" print
+    dup args>> stack.
+    "Error:" print
+    underlying>> error. ;
 
 <PRIVATE
 

From b357812589b393a2b53e1ee2c211e1d696ac21fc Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Thu, 2 Apr 2009 13:24:34 -0500
Subject: [PATCH 093/135] Fix Uniscribe font size

---
 basis/windows/fonts/fonts.factor | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/windows/fonts/fonts.factor b/basis/windows/fonts/fonts.factor
index b9fb48d840..a034856b34 100755
--- a/basis/windows/fonts/fonts.factor
+++ b/basis/windows/fonts/fonts.factor
@@ -1,4 +1,4 @@
-USING: assocs memoize locals kernel accessors init fonts
+USING: assocs memoize locals kernel accessors init fonts math
 combinators windows windows.types windows.gdi32 ;
 IN: windows.fonts
 
@@ -10,7 +10,7 @@ IN: windows.fonts
     } at-default ;
     
 MEMO:: (cache-font) ( font -- HFONT )
-    font size>> ! nHeight
+    font size>> neg ! nHeight
     0 0 0 ! nWidth, nEscapement, nOrientation
     font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
     font italic?>> TRUE FALSE ? ! fdwItalic

From e0a8def090a8ec4bfd0f51c02072f0e910c2165c Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Thu, 2 Apr 2009 13:48:53 -0500
Subject: [PATCH 094/135] Fix generate-help to not open thousands of windows in
 UI

---
 basis/help/html/html.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/help/html/html.factor b/basis/help/html/html.factor
index 66d864b2a0..d880af5b55 100644
--- a/basis/help/html/html.factor
+++ b/basis/help/html/html.factor
@@ -60,7 +60,7 @@ M: topic url-of topic>filename ;
 : help>html ( topic -- xml )
     [ article-title ]
     [ drop help-stylesheet ]
-    [ [ help ] with-html-writer ]
+    [ [ print-topic ] with-html-writer ]
     tri simple-page ;
           
 : generate-help-file ( topic -- )

From dfa27e0c174b0beda5fc8f1d613e4f878335de8a Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Thu, 2 Apr 2009 13:50:15 -0500
Subject: [PATCH 095/135] Add vocab meta-data for some of the new vocabs

---
 basis/ui/text/pango/summary.txt     | 1 +
 basis/ui/text/uniscribe/authors.txt | 1 +
 basis/ui/text/uniscribe/summary.txt | 1 +
 basis/ui/text/uniscribe/tags.txt    | 1 +
 basis/windows/offscreen/summary.txt | 1 +
 basis/windows/offscreen/tags.txt    | 1 +
 basis/windows/uniscribe/summary.txt | 1 +
 basis/windows/uniscribe/tags.txt    | 1 +
 8 files changed, 8 insertions(+)
 create mode 100755 basis/ui/text/pango/summary.txt
 create mode 100755 basis/ui/text/uniscribe/authors.txt
 create mode 100755 basis/ui/text/uniscribe/summary.txt
 create mode 100755 basis/ui/text/uniscribe/tags.txt
 create mode 100755 basis/windows/offscreen/summary.txt
 create mode 100755 basis/windows/offscreen/tags.txt
 create mode 100755 basis/windows/uniscribe/summary.txt
 create mode 100755 basis/windows/uniscribe/tags.txt

diff --git a/basis/ui/text/pango/summary.txt b/basis/ui/text/pango/summary.txt
new file mode 100755
index 0000000000..0e2e18c9d3
--- /dev/null
+++ b/basis/ui/text/pango/summary.txt
@@ -0,0 +1 @@
+UI text rendering implementation using cross-platform Pango library
diff --git a/basis/ui/text/uniscribe/authors.txt b/basis/ui/text/uniscribe/authors.txt
new file mode 100755
index 0000000000..56f4654064
--- /dev/null
+++ b/basis/ui/text/uniscribe/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
diff --git a/basis/ui/text/uniscribe/summary.txt b/basis/ui/text/uniscribe/summary.txt
new file mode 100755
index 0000000000..2480a4e98b
--- /dev/null
+++ b/basis/ui/text/uniscribe/summary.txt
@@ -0,0 +1 @@
+UI text rendering implementation using MS Windows Uniscribe library
diff --git a/basis/ui/text/uniscribe/tags.txt b/basis/ui/text/uniscribe/tags.txt
new file mode 100755
index 0000000000..6abe115b12
--- /dev/null
+++ b/basis/ui/text/uniscribe/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/windows/offscreen/summary.txt b/basis/windows/offscreen/summary.txt
new file mode 100755
index 0000000000..dd7040564e
--- /dev/null
+++ b/basis/windows/offscreen/summary.txt
@@ -0,0 +1 @@
+Utility words for memory DCs and bitmaps
diff --git a/basis/windows/offscreen/tags.txt b/basis/windows/offscreen/tags.txt
new file mode 100755
index 0000000000..6abe115b12
--- /dev/null
+++ b/basis/windows/offscreen/tags.txt
@@ -0,0 +1 @@
+unportable
diff --git a/basis/windows/uniscribe/summary.txt b/basis/windows/uniscribe/summary.txt
new file mode 100755
index 0000000000..7b71cf1fc9
--- /dev/null
+++ b/basis/windows/uniscribe/summary.txt
@@ -0,0 +1 @@
+High-level wrapper around Uniscribe binding
diff --git a/basis/windows/uniscribe/tags.txt b/basis/windows/uniscribe/tags.txt
new file mode 100755
index 0000000000..6abe115b12
--- /dev/null
+++ b/basis/windows/uniscribe/tags.txt
@@ -0,0 +1 @@
+unportable

From 7e0f271cf3f4eb428aa40a85369b54b338585572 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Thu, 2 Apr 2009 17:00:29 -0500
Subject: [PATCH 096/135] fix typo in docs

---
 basis/math/functions/functions.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/math/functions/functions.factor b/basis/math/functions/functions.factor
index 799bb04169..1eac321e3b 100644
--- a/basis/math/functions/functions.factor
+++ b/basis/math/functions/functions.factor
@@ -111,7 +111,7 @@ PRIVATE>
 : lcm ( a b -- c )
     [ * ] 2keep gcd nip /i ; foldable
 
-: divisor? ( x y -- ? )
+: divisor? ( m n -- ? )
     mod 0 = ;
 
 : mod-inv ( x n -- y )

From 0dcb38d86a2826a488ec91e6455e9bee45a10339 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Fri, 3 Apr 2009 06:58:36 -0500
Subject: [PATCH 097/135] Some more GDI32 bindings

---
 basis/windows/gdi32/gdi32.factor | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor
index 549286d4f0..794aa0e32e 100755
--- a/basis/windows/gdi32/gdi32.factor
+++ b/basis/windows/gdi32/gdi32.factor
@@ -1354,7 +1354,7 @@ FUNCTION: HRGN CreateRectRgn ( int x, int y, int w, int h ) ;
 ! FUNCTION: CreateRoundRectRgn
 ! FUNCTION: CreateScalableFontResourceA
 ! FUNCTION: CreateScalableFontResourceW
-! FUNCTION: CreateSolidBrush
+FUNCTION: HBRUSH CreateSolidBrush ( COLORREF colorref ) ;
 ! FUNCTION: DdEntry0
 ! FUNCTION: DdEntry1
 ! FUNCTION: DdEntry10
@@ -1501,6 +1501,7 @@ DESTRUCTOR: DeleteObject
 FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ;
 ALIAS: ExtTextOut ExtTextOutW
 ! FUNCTION: FillPath
+FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
 ! FUNCTION: FillRgn
 ! FUNCTION: FixBrushOrgEx
 ! FUNCTION: FlattenPath
@@ -1779,7 +1780,7 @@ ALIAS: GetTextMetrics GetTextMetricsW
 ! FUNCTION: PtVisible
 ! FUNCTION: QueryFontAssocStatus
 ! FUNCTION: RealizePalette
-! FUNCTION: Rectangle
+FUNCTION: BOOL Rectangle ( HDC hdc, int x, int y, int w, int h ) ;
 ! FUNCTION: RectInRegion
 ! FUNCTION: RectVisible
 ! FUNCTION: RemoveFontMemResourceEx

From 7f4784151cd52d327eae32f665d0e6d8903e2f01 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Fri, 3 Apr 2009 06:59:27 -0500
Subject: [PATCH 098/135] Paint selection, and create bitmap with power of 2
 size as an optimizaion

---
 basis/windows/uniscribe/uniscribe.factor | 165 +++++++++++++----------
 1 file changed, 94 insertions(+), 71 deletions(-)

diff --git a/basis/windows/uniscribe/uniscribe.factor b/basis/windows/uniscribe/uniscribe.factor
index cfd723ae8f..53d2d9918f 100755
--- a/basis/windows/uniscribe/uniscribe.factor
+++ b/basis/windows/uniscribe/uniscribe.factor
@@ -1,79 +1,13 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel assocs math sequences fry io.encodings.string
-io.encodings.utf16n accessors arrays combinators destructors
-cache namespaces init images.normalization alien.c-types locals
+io.encodings.utf16n accessors arrays combinators destructors locals
+cache namespaces init images.normalization fonts alien.c-types
 windows windows.usp10 windows.offscreen windows.gdi32
-windows.ole32 windows.types windows.fonts ;
+windows.ole32 windows.types windows.fonts opengl.textures ;
 IN: windows.uniscribe
 
-TUPLE: script-string metrics ssa size image string disposed ;
-
-: make-script-string ( dc string -- script-string )
-    [ utf16n encode ] ! pString
-    [ length ] bi ! cString
-    dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
-    -1 ! iCharset -- Unicode
-    SSA_GLYPHS ! dwFlags
-    0 ! iReqWidth
-    f ! psControl
-    f ! psState
-    f ! piDx
-    f ! pTabdef
-    f ! pbInClass
-    f <void*> ! pssa
-    [ ScriptStringAnalyse ] keep
-    [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
-
-: draw-script-string ( script-string -- )
-    ! ssa
-    0 ! iX
-    0 ! iY
-    0 ! uOptions
-    f ! prc
-    0 ! iMinSel
-    0 ! iMaxSel
-    FALSE ! fDisabled
-    ScriptStringOut ole32-error ;
-
-: set-dc-font ( dc font -- )
-    [ cache-font SelectObject win32-error=0/f ]
-    [ background>> color>RGB SetBkColor drop ]
-    [ foreground>> color>RGB SetTextColor drop ] 2tri ;
-
-: script-string-size ( ssa -- dim )
-    ScriptString_pSize
-    dup win32-error=0/f
-    [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
-
-: dc-metrics ( dc -- metrics )
-    "TEXTMETRICW" <c-object> [ GetTextMetrics drop ] keep
-    TEXTMETRIC>metrics ;
-
-:: <script-string> ( font string -- script-string )
-    #! Comments annotate BOA constructor arguments
-    [| dc |
-        dc font set-dc-font
-        dc dc-metrics ! metrics
-        dc string make-script-string dup :> ssa ! ssa
-        dup script-string-size ! size
-        dup dc [ ssa draw-script-string ] make-bitmap-image
-        normalize-image ! image
-        string ! string
-        f script-string boa
-    ] with-memory-dc ;
-
-: text-position ( script-string -- loc ) drop { 0 0 } ;
-
-M: script-string dispose* ssa>> <void*> ScriptStringFree ole32-error ;
-
-SYMBOL: cached-script-strings
-
-: cached-script-string ( string font -- script-string )
-    cached-script-strings get-global [ <script-string> ] 2cache ;
-
-[ <cache-assoc> cached-script-strings set-global ]
-"windows.uniscribe" add-init-hook
+TUPLE: script-string font string metrics ssa size image disposed ;
 
 : line-offset>x ( n script-string -- x )
     2dup string>> length = [
@@ -92,4 +26,93 @@ SYMBOL: cached-script-strings
     swap ! iX
     0 <int> ! pCh
     0 <int> ! piTrailing
-    [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
\ No newline at end of file
+    [ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
+
+<PRIVATE
+
+: make-script-string ( dc string -- script-string )
+    dup selection? [ string>> ] when
+    [ utf16n encode ] ! pString
+    [ length ] bi ! cString
+    dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
+    -1 ! iCharset -- Unicode
+    SSA_GLYPHS ! dwFlags
+    0 ! iReqWidth
+    f ! psControl
+    f ! psState
+    f ! piDx
+    f ! pTabdef
+    f ! pbInClass
+    f <void*> ! pssa
+    [ ScriptStringAnalyse ] keep
+    [ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
+
+: set-dc-colors ( dc font -- )
+    [ background>> color>RGB SetBkColor drop ]
+    [ foreground>> color>RGB SetTextColor drop ] 2bi ;
+
+: selection-start/end ( script-string -- iMinSel iMaxSel )
+    string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
+
+: (draw-script-string) ( script-string -- )
+    [
+        ssa>> ! ssa
+        0 ! iX
+        0 ! iY
+        0 ! uOptions
+        f ! prc
+    ]
+    [ selection-start/end ] bi
+    ! iMinSel
+    ! iMaxSel
+    FALSE ! fDisabled
+    ScriptStringOut ole32-error ;
+
+: draw-script-string ( dc script-string -- )
+    [ font>> set-dc-colors ] keep (draw-script-string) ;
+
+: script-string-bitmap-size ( script-string -- dim )
+    size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
+
+:: make-script-string-image ( dc script-string -- image )
+    script-string script-string-bitmap-size dc
+    [ dc script-string draw-script-string ] make-bitmap-image ;
+
+: set-dc-font ( dc font -- )
+    cache-font SelectObject win32-error=0/f ;
+
+: script-string-size ( script-string -- dim )
+    ssa>> ScriptString_pSize
+    dup win32-error=0/f
+    [ SIZE-cx ] [ SIZE-cy ] bi 2array ;
+
+: dc-metrics ( dc -- metrics )
+    "TEXTMETRICW" <c-object>
+    [ GetTextMetrics drop ] keep
+    TEXTMETRIC>metrics ;
+
+: <script-string> ( font string -- script-string )
+    [ script-string new ] 2dip
+        [ >>font ] [ >>string ] bi*
+    [
+        {
+            [ over font>> set-dc-font ]
+            [ dc-metrics >>metrics ]
+            [ over string>> make-script-string >>ssa ]
+            [ drop dup script-string-size >>size ]
+            [ over make-script-string-image >>image ]
+        } cleave
+    ] with-memory-dc ;
+
+PRIVATE>
+
+M: script-string dispose*
+    ssa>> <void*> ScriptStringFree ole32-error ;
+
+SYMBOL: cached-script-strings
+
+: cached-script-string ( string font -- script-string )
+    cached-script-strings get-global [ <script-string> ] 2cache ;
+
+[ <cache-assoc> cached-script-strings set-global ]
+"windows.uniscribe" add-init-hook
\ No newline at end of file

From 1731b57249318eab39565b2f10bd31badaf446cc Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Fri, 3 Apr 2009 07:01:22 -0500
Subject: [PATCH 099/135] Add textures without alpha channels, cropping; update
 usages of <texture>; don't ignore trailing in x>offset

---
 basis/images/images.factor               |  6 ++-
 basis/opengl/textures/textures.factor    | 60 ++++++++++++++----------
 basis/ui/images/images.factor            |  2 +-
 basis/ui/text/core-text/core-text.factor |  8 ++--
 basis/ui/text/pango/pango.factor         |  8 ++--
 basis/ui/text/uniscribe/summary.txt      |  2 +-
 basis/ui/text/uniscribe/uniscribe.factor |  9 ++--
 7 files changed, 56 insertions(+), 39 deletions(-)
 mode change 100644 => 100755 basis/images/images.factor
 mode change 100644 => 100755 basis/ui/images/images.factor

diff --git a/basis/images/images.factor b/basis/images/images.factor
old mode 100644
new mode 100755
index 08fbdd4e7e..b32953f67c
--- a/basis/images/images.factor
+++ b/basis/images/images.factor
@@ -1,11 +1,13 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: combinators kernel ;
+USING: combinators kernel accessors ;
 IN: images
 
 SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
 R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
 
+UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
+
 : bytes-per-pixel ( component-order -- n )
     {
         { L [ 1 ] }
@@ -29,4 +31,6 @@ TUPLE: image dim component-order upside-down? bitmap ;
 
 : <image> ( -- image ) image new ; inline
 
+: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
+
 GENERIC: load-image* ( path tuple -- image )
\ No newline at end of file
diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor
index 67094200d1..3efe924fb5 100755
--- a/basis/opengl/textures/textures.factor
+++ b/basis/opengl/textures/textures.factor
@@ -3,7 +3,7 @@
 USING: accessors assocs cache colors.constants destructors fry kernel
 opengl opengl.gl combinators images images.tesselation grouping
 specialized-arrays.float locals sequences math math.vectors
-math.matrices generalizations fry columns ;
+math.matrices generalizations fry columns arrays ;
 IN: opengl.textures
 
 : gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
@@ -25,7 +25,7 @@ GENERIC: draw-scaled-texture ( dim texture -- )
 
 <PRIVATE
 
-TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
+TUPLE: single-texture image loc dim texture-coords texture display-list disposed ;
 
 : repeat-last ( seq n -- seq' )
     over peek pad-tail concat ;
@@ -45,7 +45,7 @@ TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
     tri * group ; inline
 
 : power-of-2-image ( image -- image )
-    dup dim>> [ 0 = ] all? [
+    dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [
         clone dup
         [ image-rows ]
         [ dim>> [ next-power-of-2 ] map ]
@@ -93,26 +93,30 @@ TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
 
 : draw-textured-rect ( dim texture -- )
     [
-        (draw-textured-rect)
-        GL_TEXTURE_2D 0 glBindTexture
+        [ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
+        [ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
+        [ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
+        tri
     ] with-texturing ;
 
-: texture-coords ( dim -- coords )
-    [ dup next-power-of-2 /f ] map
-    { { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
+: texture-coords ( texture -- coords )
+    [
+        [ dim>> ] [ image>> dim>> ] bi v/
+        { { 0 0 } { 1 0 } { 1 1 } { 0 1 } }
+        [ v* ] with map
+    ] keep
+    image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when
     float-array{ } join ;
 
 : make-texture-display-list ( texture -- dlist )
     GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
 
-: <single-texture> ( image loc -- texture )
-   single-texture new swap >>loc
-    swap
-    [ dim>> >>dim ] keep
-    [ dim>> product 0 = ] keep '[
-        _
-        [ dim>> texture-coords >>texture-coords ]
-        [ power-of-2-image make-texture >>texture ] bi
+: <single-texture> ( image loc dim -- texture )
+    [ power-of-2-image ] 2dip
+    single-texture new swap >>dim swap >>loc swap >>image
+    dup image>> dim>> product 0 = [
+        dup texture-coords >>texture-coords
+        dup image>> make-texture >>texture
         dup make-texture-display-list >>display-list
     ] unless ;
 
@@ -134,19 +138,20 @@ TUPLE: multi-texture grid display-list loc disposed ;
 
 : <texture-grid> ( image-grid loc -- grid )
     [ dup image-locs ] dip
-    '[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
+    '[ [ _ v+ over dim>> <single-texture> |dispose ] 2map ] 2map ;
 
 : draw-textured-grid ( grid -- )
     [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
 
+: grid-has-alpha? ( grid -- ? )
+    first first image>> has-alpha? ;
+
 : make-textured-grid-display-list ( grid -- dlist )
     GL_COMPILE [
         [
-            [
-                [
-                    [ dim>> ] keep (draw-textured-rect)
-                ] each
-            ] each
+            [ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
+            [ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ]
+            [ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
             GL_TEXTURE_2D 0 glBindTexture
         ] with-texturing
     ] make-dlist ;
@@ -164,11 +169,14 @@ M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
 
 M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
 
-CONSTANT: max-texture-size { 256 256 }
+CONSTANT: max-texture-size { 512 512 }
 
 PRIVATE>
 
-: <texture> ( image loc -- texture )
-    over dim>> max-texture-size [ <= ] 2all?
+: small-texture? ( dim -- ? )
+    max-texture-size [ <= ] 2all? ;
+
+: <texture> ( image loc dim -- texture )
+    pick dim>> small-texture?
     [ <single-texture> ]
-    [ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
\ No newline at end of file
+    [ drop [ max-texture-size tesselate ] dip <multi-texture> ] if ;
\ No newline at end of file
diff --git a/basis/ui/images/images.factor b/basis/ui/images/images.factor
old mode 100644
new mode 100755
index 2b1caa8ab9..8e36f2a3b1
--- a/basis/ui/images/images.factor
+++ b/basis/ui/images/images.factor
@@ -20,7 +20,7 @@ PRIVATE>
 
 : rendered-image ( path -- texture )
     world get image-texture-cache
-    [ cached-image { 0 0 } <texture> ] cache ;
+    [ cached-image [ { 0 0 } ] keep dim>> <texture> ] cache ;
 
 : draw-image ( image-name -- )
     rendered-image draw-texture ;
diff --git a/basis/ui/text/core-text/core-text.factor b/basis/ui/text/core-text/core-text.factor
index 514d918e2f..404624da95 100755
--- a/basis/ui/text/core-text/core-text.factor
+++ b/basis/ui/text/core-text/core-text.factor
@@ -19,9 +19,11 @@ M: core-text-renderer flush-layout-cache
     cached-lines get purge-cache ;
 
 : rendered-line ( font string -- texture )
-    world get world-text-handle
-    [ cached-line [ image>> ] [ loc>> ] bi <texture> ]
-    2cache ;
+    world get world-text-handle [
+        cached-line
+        [ image>> ] [ loc>> ] [ image>> dim>> ] tri
+        <texture>
+    ] 2cache ;
 
 M: core-text-renderer draw-string ( font string -- )
     rendered-line draw-texture ;
diff --git a/basis/ui/text/pango/pango.factor b/basis/ui/text/pango/pango.factor
index 3f4808a208..46328d11d5 100755
--- a/basis/ui/text/pango/pango.factor
+++ b/basis/ui/text/pango/pango.factor
@@ -15,9 +15,11 @@ M: pango-renderer flush-layout-cache
     cached-layouts get purge-cache ;
 
 : rendered-layout ( font string -- texture )
-    world get world-text-handle
-    [ cached-layout [ image>> ] [ text-position vneg ] bi <texture> ]
-    2cache ;
+    world get world-text-handle [
+        cached-layout
+        [ image>> ] [ text-position vneg ] [ image>> dim>> ] tri
+        <texture>
+    ] 2cache ;
 
 M: pango-renderer draw-string ( font string -- )
     rendered-layout draw-texture ;
diff --git a/basis/ui/text/uniscribe/summary.txt b/basis/ui/text/uniscribe/summary.txt
index 2480a4e98b..6fe24d9f74 100755
--- a/basis/ui/text/uniscribe/summary.txt
+++ b/basis/ui/text/uniscribe/summary.txt
@@ -1 +1 @@
-UI text rendering implementation using MS Windows Uniscribe library
+UI text rendering implementation using the MS Windows Uniscribe library
diff --git a/basis/ui/text/uniscribe/uniscribe.factor b/basis/ui/text/uniscribe/uniscribe.factor
index f7d4207927..dcec4ab17e 100755
--- a/basis/ui/text/uniscribe/uniscribe.factor
+++ b/basis/ui/text/uniscribe/uniscribe.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors assocs cache kernel math.vectors sequences
+USING: accessors assocs cache kernel math math.vectors sequences fonts
 namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds 
 windows.uniscribe ;
 IN: ui.text.uniscribe
@@ -16,15 +16,16 @@ M: uniscribe-renderer flush-layout-cache
 
 : rendered-script-string ( font string -- texture )
     world get world-text-handle
-    [ cached-script-string [ image>> ] [ text-position vneg ] bi <texture> ]
+    [ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi <texture> ]
     2cache ;
 
 M: uniscribe-renderer draw-string ( font string -- )
-    [ drop ] [ rendered-script-string draw-texture ] if-empty ;
+    dup dup selection? [ string>> ] when empty?
+    [ 2drop ] [ rendered-script-string draw-texture ] if ;
 
 M: uniscribe-renderer x>offset ( x font string -- n )
     [ 2drop 0 ] [
-        cached-script-string x>line-offset drop
+        cached-script-string x>line-offset 0 = [ 1+ ] unless
     ] if-empty ;
 
 M: uniscribe-renderer offset>x ( n font string -- x )

From 1a35be8ae00360198c153dd23628dcc5504ca293 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 09:44:48 -0500
Subject: [PATCH 100/135] Add a new tip

---
 basis/help/tips/tips-docs.factor | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/basis/help/tips/tips-docs.factor b/basis/help/tips/tips-docs.factor
index 48ed65b318..030c546f0c 100644
--- a/basis/help/tips/tips-docs.factor
+++ b/basis/help/tips/tips-docs.factor
@@ -1,6 +1,6 @@
 IN: help.tips
 USING: help.markup help.syntax debugger prettyprint see help help.vocabs
-help.apropos tools.time stack-checker editors ;
+help.apropos tools.time stack-checker editors memory ;
 
 TIP: "To look at the most recent error, run " { $link :error } ". To look at the most recent error's callstack, run " { $link :c } "." ;
 
@@ -20,7 +20,9 @@ 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." ;
 
-TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $code "\"demos\" run" } ;
+TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $snippet "\"demos\" run" } ;
+
+TIP: "To save time on reloading big libraries such as the " { $vocab-link "furnace" } " web framework, save the image after loading them using the " { $link save } " word." ;
 
 HELP: TIP:
 { $syntax "TIP: content ;" }

From 73184698a88c6ff22ab817e890a25d61cbaf33d5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 09:45:02 -0500
Subject: [PATCH 101/135] Remove unused entry from using list

---
 basis/pack/pack.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/pack/pack.factor b/basis/pack/pack.factor
index 27cba6d6e7..3b9739fb0f 100755
--- a/basis/pack/pack.factor
+++ b/basis/pack/pack.factor
@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays assocs byte-arrays io
 io.binary io.streams.string kernel math math.parser namespaces
-make parser prettyprint quotations sequences strings vectors
+make parser quotations sequences strings vectors
 words macros math.functions math.bitwise fry generalizations
 combinators.smart io.streams.byte-array io.encodings.binary
 math.vectors combinators multiline endian ;

From 4f9ac11eedf2a5703fd5e8c0c1fffd49769583e0 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Fri, 3 Apr 2009 09:48:10 -0500
Subject: [PATCH 102/135] Remove unused dependency

---
 basis/windows/windows.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)
 mode change 100644 => 100755 basis/windows/windows.factor

diff --git a/basis/windows/windows.factor b/basis/windows/windows.factor
old mode 100644
new mode 100755
index 44db355c99..902b1bec8d
--- a/basis/windows/windows.factor
+++ b/basis/windows/windows.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.syntax alien.c-types alien.strings arrays
-combinators kernel math namespaces parser prettyprint sequences
+combinators kernel math namespaces parser sequences
 windows.errors windows.types windows.kernel32 words
 io.encodings.utf16n ;
 IN: windows

From 82317980a483948f87c52005295999c410118c07 Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Fri, 3 Apr 2009 09:48:16 -0500
Subject: [PATCH 103/135] Don't strip out superclass word prop since UI needs
 it

---
 basis/tools/deploy/shaker/shaker.factor | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 8ee0393091..7fe2db96a0 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -157,7 +157,8 @@ IN: tools.deploy.shaker
                 "specializer"
                 "step-into"
                 "step-into?"
-                "superclass"
+                ! UI needs this
+                ! "superclass"
                 "transform-n"
                 "transform-quot"
                 "tuple-dispatch-generic"

From 5a6bcbb2317375b983eb739bb440738bb269d94a Mon Sep 17 00:00:00 2001
From: "U-SLAVA-DFB8FF805\\Slava" <Slava@slava-dfb8ff805.(none)>
Date: Fri, 3 Apr 2009 09:48:45 -0500
Subject: [PATCH 104/135] Add empty file so that old builder continues to work

---
 build-support/dlls.txt | 0
 1 file changed, 0 insertions(+), 0 deletions(-)
 create mode 100644 build-support/dlls.txt

diff --git a/build-support/dlls.txt b/build-support/dlls.txt
new file mode 100644
index 0000000000..e69de29bb2

From 9907bd9fe26609a77654e4ae5f5a0c2c58c6fc2d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 10:16:25 -0500
Subject: [PATCH 105/135] Add fseek primitive so that c-streams can seek. This
 lets the UI work without native IO

---
 .../known-words/known-words.factor            |  2 ++
 core/bootstrap/primitives.factor              |  1 +
 core/io/streams/c/c.factor                    | 26 ++++++++++++-------
 vm/io.c                                       | 25 ++++++++++++++++++
 vm/io.h                                       |  1 +
 vm/primitives.c                               |  1 +
 6 files changed, 47 insertions(+), 9 deletions(-)

diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor
index a38bb42c7e..c55e69a8a2 100644
--- a/basis/stack-checker/known-words/known-words.factor
+++ b/basis/stack-checker/known-words/known-words.factor
@@ -605,6 +605,8 @@ M: object infer-call*
 
 \ fflush { alien } { } define-primitive
 
+\ fseek { alien integer integer } { } define-primitive
+
 \ fclose { alien } { } define-primitive
 
 \ <wrapper> { object } { wrapper } define-primitive
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index e3803f2150..4466bd9bfe 100644
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -510,6 +510,7 @@ tuple
     { "fputc" "io.streams.c" (( ch alien -- )) }
     { "fwrite" "io.streams.c" (( string alien -- )) }
     { "fflush" "io.streams.c" (( alien -- )) }
+    { "fseek" "io.streams.c" (( alien offset whence -- )) }
     { "fclose" "io.streams.c" (( alien -- )) }
     { "<wrapper>" "kernel" (( obj -- wrapper )) }
     { "(clone)" "kernel" (( obj -- newobj )) }
diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor
index eb23a627b9..bec3bdc6bf 100755
--- a/core/io/streams/c/c.factor
+++ b/core/io/streams/c/c.factor
@@ -1,11 +1,24 @@
-! Copyright (C) 2004, 2008 Slava Pestov.
+! Copyright (C) 2004, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel kernel.private namespaces make io io.encodings
 sequences math generic threads.private classes io.backend
-io.files continuations destructors byte-arrays accessors ;
+io.files continuations destructors byte-arrays accessors
+combinators ;
 IN: io.streams.c
 
-TUPLE: c-writer handle disposed ;
+TUPLE: c-stream handle disposed ;
+
+M: c-stream dispose* handle>> fclose ;
+
+M: c-stream stream-seek
+    handle>> swap {
+        { seek-absolute [ 0 ] }
+        { seek-relative [ 1 ] }
+        { seek-end [ 2 ] }
+        [ bad-seek-type ]
+    } case fseek ;
+
+TUPLE: c-writer < c-stream ;
 
 : <c-writer> ( handle -- stream ) f c-writer boa ;
 
@@ -17,9 +30,7 @@ M: c-writer stream-write dup check-disposed handle>> fwrite ;
 
 M: c-writer stream-flush dup check-disposed handle>> fflush ;
 
-M: c-writer dispose* handle>> fclose ;
-
-TUPLE: c-reader handle disposed ;
+TUPLE: c-reader < c-stream ;
 
 : <c-reader> ( handle -- stream ) f c-reader boa ;
 
@@ -43,9 +54,6 @@ M: c-reader stream-read-until
     [ swap read-until-loop ] B{ } make swap
     over empty? over not and [ 2drop f f ] when ;
 
-M: c-reader dispose*
-    handle>> fclose ;
-
 M: c-io-backend init-io ;
 
 : stdin-handle ( -- alien ) 11 getenv ;
diff --git a/vm/io.c b/vm/io.c
index bad4854775..950b1ed080 100755
--- a/vm/io.c
+++ b/vm/io.c
@@ -163,6 +163,31 @@ void primitive_fwrite(void)
 	}
 }
 
+void primitive_fseek(void)
+{
+	int whence = to_fixnum(dpop());
+	FILE *file = unbox_alien();
+	off_t offset = to_signed_8(dpop());
+
+	switch(whence)
+	{
+	case 0: whence = SEEK_SET; break;
+	case 1: whence = SEEK_CUR; break;
+	case 2: whence = SEEK_END; break;
+	default:
+		critical_error("Bad value for whence",whence);
+		break;
+	}
+
+	if(fseeko(file,offset,whence) == -1)
+	{
+		io_error();
+
+		/* Still here? EINTR */
+		critical_error("Don't know what to do; EINTR from fseek()?",0);
+	}
+}
+
 void primitive_fflush(void)
 {
 	FILE *file = unbox_alien();
diff --git a/vm/io.h b/vm/io.h
index dc7d69edee..63a9c35490 100755
--- a/vm/io.h
+++ b/vm/io.h
@@ -9,6 +9,7 @@ void primitive_fread(void);
 void primitive_fputc(void);
 void primitive_fwrite(void);
 void primitive_fflush(void);
+void primitive_fseek(void);
 void primitive_fclose(void);
 
 /* Platform specific primitives */
diff --git a/vm/primitives.c b/vm/primitives.c
index 00103ac047..80b672d9d2 100755
--- a/vm/primitives.c
+++ b/vm/primitives.c
@@ -121,6 +121,7 @@ void *primitives[] = {
 	primitive_fputc,
 	primitive_fwrite,
 	primitive_fflush,
+	primitive_fseek,
 	primitive_fclose,
 	primitive_wrapper,
 	primitive_clone,

From f42c23de9d150daebefc833087708b2f79c5d2d9 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 10:16:40 -0500
Subject: [PATCH 106/135] Copy UI theme over to deployed binaries

---
 basis/tools/deploy/macosx/macosx.factor | 11 ++++++-----
 1 file changed, 6 insertions(+), 5 deletions(-)

diff --git a/basis/tools/deploy/macosx/macosx.factor b/basis/tools/deploy/macosx/macosx.factor
index 11e2b8957b..f753e38fb2 100755
--- a/basis/tools/deploy/macosx/macosx.factor
+++ b/basis/tools/deploy/macosx/macosx.factor
@@ -42,11 +42,12 @@ IN: tools.deploy.macosx
 
 : create-app-dir ( vocab bundle-name -- vm )
     [
-        nip
-        [ copy-dll ]
-        [ copy-nib ]
-        [ "Contents/Resources" append-path make-directories ]
-        tri
+        nip {
+            [ copy-dll ]
+            [ copy-nib ]
+            [ "Contents/Resources" append-path make-directories ]
+            [ "Contents/Resources" copy-theme ]
+        } cleave
     ]
     [ create-app-plist ]
     [ "Contents/MacOS/" append-path copy-vm ] 2tri

From 535850f3ea5d31f44bd9d08fa9ac1700a15b48b8 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 10:16:56 -0500
Subject: [PATCH 107/135] Fix vocab: and word name stripping in deployed
 binaries

---
 basis/tools/deploy/shaker/shaker.factor | 1 -
 vm/factor.c                             | 7 ++++---
 2 files changed, 4 insertions(+), 4 deletions(-)

diff --git a/basis/tools/deploy/shaker/shaker.factor b/basis/tools/deploy/shaker/shaker.factor
index 8ee0393091..0284891ebe 100755
--- a/basis/tools/deploy/shaker/shaker.factor
+++ b/basis/tools/deploy/shaker/shaker.factor
@@ -276,7 +276,6 @@ IN: tools.deploy.shaker
                 lexer-factory
                 print-use-hook
                 root-cache
-                vocab-roots
                 vocabs:dictionary
                 vocabs:load-vocab-hook
                 word
diff --git a/vm/factor.c b/vm/factor.c
index d9042c9455..9b5d3de602 100755
--- a/vm/factor.c
+++ b/vm/factor.c
@@ -132,9 +132,7 @@ void init_factor(F_PARAMETERS *p)
 	userenv[CPU_ENV] = tag_object(from_char_string(FACTOR_CPU_STRING));
 	userenv[OS_ENV] = tag_object(from_char_string(FACTOR_OS_STRING));
 	userenv[CELL_SIZE_ENV] = tag_fixnum(sizeof(CELL));
-	userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
-	userenv[EXECUTABLE_ENV] = (p->executable_path ?
-		tag_object(from_native_string(p->executable_path)) : F);
+	userenv[EXECUTABLE_ENV] = (p->executable_path ? tag_object(from_native_string(p->executable_path)) : F);
 	userenv[ARGS_ENV] = F;
 	userenv[EMBEDDED_ENV] = F;
 
@@ -142,7 +140,10 @@ void init_factor(F_PARAMETERS *p)
 	gc_off = false;
 
 	if(!stage2)
+	{
+		userenv[STACK_TRACES_ENV] = tag_boolean(p->stack_traces);
 		do_stage1_init();
+	}
 }
 
 /* May allocate memory */

From f7ba7b4bfa6801073029f0579b7222d422078afa Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 10:20:42 -0500
Subject: [PATCH 108/135] Fix deploy descriptor for color picker

---
 extra/color-picker/deploy.factor | 21 ++++++++++++---------
 1 file changed, 12 insertions(+), 9 deletions(-)

diff --git a/extra/color-picker/deploy.factor b/extra/color-picker/deploy.factor
index fcb4dbd69d..eeeb63dd7d 100755
--- a/extra/color-picker/deploy.factor
+++ b/extra/color-picker/deploy.factor
@@ -1,12 +1,15 @@
 USING: tools.deploy.config ;
-V{
-    { deploy-ui? t }
-    { deploy-io 1 }
-    { deploy-reflection 1 }
-    { deploy-compiler? t }
-    { deploy-math? t }
-    { deploy-word-props? f }
-    { deploy-c-types? f }
-    { "stop-after-last-window?" t }
+H{
     { deploy-name "Color Picker" }
+    { deploy-word-props? f }
+    { deploy-ui? t }
+    { deploy-threads? t }
+    { deploy-unicode? f }
+    { deploy-c-types? f }
+    { deploy-word-defs? f }
+    { deploy-compiler? t }
+    { deploy-io 2 }
+    { deploy-reflection 1 }
+    { "stop-after-last-window?" t }
+    { deploy-math? t }
 }

From 34c8e07900277a88659d600e036ebfbad8e210e2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 3 Apr 2009 10:35:43 -0500
Subject: [PATCH 109/135] make FSEEK macro for using _fseeki64 instead of
 fseeko on windows

---
 vm/io.c         | 2 +-
 vm/os-genunix.h | 1 +
 vm/os-windows.h | 1 +
 3 files changed, 3 insertions(+), 1 deletion(-)

diff --git a/vm/io.c b/vm/io.c
index 950b1ed080..d88f1bab50 100755
--- a/vm/io.c
+++ b/vm/io.c
@@ -179,7 +179,7 @@ void primitive_fseek(void)
 		break;
 	}
 
-	if(fseeko(file,offset,whence) == -1)
+	if(FSEEK(file,offset,whence) == -1)
 	{
 		io_error();
 
diff --git a/vm/os-genunix.h b/vm/os-genunix.h
index 7afc68998d..9a00758c8a 100644
--- a/vm/os-genunix.h
+++ b/vm/os-genunix.h
@@ -1,5 +1,6 @@
 #define DLLEXPORT
 #define NULL_DLL NULL
+#define FSEEK fseeko
 
 void c_to_factor_toplevel(CELL quot);
 void init_signals(void);
diff --git a/vm/os-windows.h b/vm/os-windows.h
index 0704459dd0..f47ca951ee 100755
--- a/vm/os-windows.h
+++ b/vm/os-windows.h
@@ -20,6 +20,7 @@ typedef wchar_t F_CHAR;
 #define STRNCMP wcsncmp
 #define STRDUP _wcsdup
 #define MIN(a,b) ((a)>(b)?(b):(a))
+#define FSEEK _fseeki64
 
 #ifdef WIN64
 	#define CELL_FORMAT "%Iu"

From 4f3e8be3f6a3ad28e602fcd9ebf152abf80a2f05 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 12:26:04 -0500
Subject: [PATCH 110/135] move FSEEK definition from os-genuinx.h to os-unix.h

---
 vm/os-genunix.h | 1 -
 vm/os-unix.h    | 2 ++
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/vm/os-genunix.h b/vm/os-genunix.h
index 9a00758c8a..7afc68998d 100644
--- a/vm/os-genunix.h
+++ b/vm/os-genunix.h
@@ -1,6 +1,5 @@
 #define DLLEXPORT
 #define NULL_DLL NULL
-#define FSEEK fseeko
 
 void c_to_factor_toplevel(CELL quot);
 void init_signals(void);
diff --git a/vm/os-unix.h b/vm/os-unix.h
index d2f34b4bc4..35abfee41c 100755
--- a/vm/os-unix.h
+++ b/vm/os-unix.h
@@ -23,6 +23,8 @@ typedef char F_SYMBOL;
 #define STRNCMP strncmp
 #define STRDUP strdup
 
+#define FSEEK fseeko
+
 #define FIXNUM_FORMAT "%ld"
 #define CELL_FORMAT "%lu"
 #define CELL_HEX_FORMAT "%lx"

From a42b872a23859635459e11522d11b20217df0997 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 12:40:45 -0500
Subject: [PATCH 111/135] fix bug in take-sequence

---
 extra/html/parser/state/state-tests.factor |  3 +++
 extra/html/parser/state/state.factor       | 11 +++++++++--
 2 files changed, 12 insertions(+), 2 deletions(-)

diff --git a/extra/html/parser/state/state-tests.factor b/extra/html/parser/state/state-tests.factor
index 75db1a373e..c8a8a95892 100644
--- a/extra/html/parser/state/state-tests.factor
+++ b/extra/html/parser/state/state-tests.factor
@@ -99,3 +99,6 @@ IN: html.parser.state.tests
 
 [ "" ]
 [ "abc" <state-parser> dup "abc" take-sequence drop take-rest ] unit-test
+
+[ f ]
+[ "abc" <state-parser> "abcdefg" take-sequence ] unit-test
diff --git a/extra/html/parser/state/state.factor b/extra/html/parser/state/state.factor
index 5f845ce810..2bcd08be5f 100644
--- a/extra/html/parser/state/state.factor
+++ b/extra/html/parser/state/state.factor
@@ -51,9 +51,16 @@ TUPLE: state-parser sequence n ;
 : take-while ( state-parser quot: ( obj -- ? ) -- sequence/f )
     [ not ] compose take-until ; inline
 
+: <safe-slice> ( from to seq -- slice/f )
+    3dup {
+        [ 2drop 0 < ]
+        [ [ drop ] 2dip length > ]
+        [ drop > ]
+    } 3|| [ 3drop f ] [ slice boa ] if ; inline
+
 :: take-sequence ( state-parser sequence -- obj/f )
-    state-parser [ n>> dup sequence length + ] [ sequence>> ] bi <slice>
-    sequence sequence= [
+    state-parser [ n>> dup sequence length + ] [ sequence>> ] bi
+    <safe-slice> sequence sequence= [
         sequence
         state-parser [ sequence length + ] change-n drop
     ] [

From c780457ddb8c74e1d5289313da6fe9aaffb518cc Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 12:54:34 -0500
Subject: [PATCH 112/135] Fix up ui.offscreen

---
 extra/ui/offscreen/offscreen-docs.factor | 10 +++++-----
 extra/ui/offscreen/offscreen.factor      | 18 ++++++++++++------
 2 files changed, 17 insertions(+), 11 deletions(-)

diff --git a/extra/ui/offscreen/offscreen-docs.factor b/extra/ui/offscreen/offscreen-docs.factor
index 4123a83675..b9d68ffaeb 100644
--- a/extra/ui/offscreen/offscreen-docs.factor
+++ b/extra/ui/offscreen/offscreen-docs.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: help.markup help.syntax kernel quotations ui.gadgets
-images.bitmap strings ui.gadgets.worlds ;
+images strings ui.gadgets.worlds ;
 IN: ui.offscreen
 
 HELP: <offscreen-world>
@@ -26,9 +26,9 @@ HELP: do-offscreen
 HELP: gadget>bitmap
 { $values
      { "gadget" gadget }
-     { "bitmap" bitmap }
+     { "image" image }
 }
-{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates a " { $link bitmap } " from its contents." } ;
+{ $description "Renders " { $snippet "gadget" } " to an " { $link offscreen-world } " and creates an " { $link image } " from its contents." } ;
 
 HELP: offscreen-world
 { $class-description "The class of " { $link world } " objects that render to an offscreen buffer." } ;
@@ -36,9 +36,9 @@ HELP: offscreen-world
 HELP: offscreen-world>bitmap
 { $values
      { "world" offscreen-world }
-     { "bitmap" bitmap }
+     { "image" image }
 }
-{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link bitmap } " object." } ;
+{ $description "Saves a copy of the contents of " { $snippet "world" } " to a " { $link image } " object." } ;
 
 HELP: open-offscreen
 { $values
diff --git a/extra/ui/offscreen/offscreen.factor b/extra/ui/offscreen/offscreen.factor
index f0b81ccacd..8d197eb844 100755
--- a/extra/ui/offscreen/offscreen.factor
+++ b/extra/ui/offscreen/offscreen.factor
@@ -1,7 +1,7 @@
 ! (c) 2008 Joe Groff, see license for details
-USING: accessors continuations images.bitmap kernel math
+USING: accessors alien.c-types continuations images kernel math
 sequences ui.gadgets ui.gadgets.private ui.gadgets.worlds
-ui.private ui ui.backend destructors ;
+ui.private ui ui.backend destructors locals ;
 IN: ui.offscreen
 
 TUPLE: offscreen-world < world ;
@@ -19,18 +19,24 @@ M: offscreen-world ungraft*
 
 : open-offscreen ( gadget -- world )
     "" f <offscreen-world>
-    [ open-world-window dup relayout-1 ] keep
+    [ open-world-window ] [ relayout-1 ] [ ] tri
     notify-queued ;
 
 : close-offscreen ( world -- )
     ungraft notify-queued ;
 
-: offscreen-world>bitmap ( world -- bitmap )
-    offscreen-pixels bgra>bitmap ;
+:: bgrx>bitmap ( alien w h -- image )
+    <image>
+        { w h } >>dim
+        alien w h * 4 * memory>byte-array >>bitmap
+        BGRX >>component-order ;
+
+: offscreen-world>bitmap ( world -- image )
+    offscreen-pixels bgrx>bitmap ;
 
 : do-offscreen ( gadget quot: ( offscreen-world -- ) -- )
     [ open-offscreen ] dip
     over [ slip ] [ close-offscreen ] [ ] cleanup ; inline
 
-: gadget>bitmap ( gadget -- bitmap )
+: gadget>bitmap ( gadget -- image )
     [ offscreen-world>bitmap ] do-offscreen ;

From 2ff6c7ed072bd090ea7b51a0d6af9cf80f90c80f Mon Sep 17 00:00:00 2001
From: Doug Coleman <doug.coleman@gmail.com>
Date: Fri, 3 Apr 2009 14:59:46 -0500
Subject: [PATCH 113/135] use fseek on windows instead of _fseeki64

---
 vm/os-windows.h | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/vm/os-windows.h b/vm/os-windows.h
index f47ca951ee..36d350f50d 100755
--- a/vm/os-windows.h
+++ b/vm/os-windows.h
@@ -20,7 +20,7 @@ typedef wchar_t F_CHAR;
 #define STRNCMP wcsncmp
 #define STRDUP _wcsdup
 #define MIN(a,b) ((a)>(b)?(b):(a))
-#define FSEEK _fseeki64
+#define FSEEK fseek
 
 #ifdef WIN64
 	#define CELL_FORMAT "%Iu"

From 775ca0a95647db832105fa163166e45d34076a7a Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 16:30:59 -0500
Subject: [PATCH 114/135] mason: run factor.com on windows

---
 extra/mason/child/child-tests.factor | 8 ++++++++
 extra/mason/child/child.factor       | 7 +++++--
 2 files changed, 13 insertions(+), 2 deletions(-)

diff --git a/extra/mason/child/child-tests.factor b/extra/mason/child/child-tests.factor
index 104360e1fa..27bb42ed07 100644
--- a/extra/mason/child/child-tests.factor
+++ b/extra/mason/child/child-tests.factor
@@ -32,3 +32,11 @@ USING: mason.child mason.config tools.test namespaces ;
         boot-cmd
     ] with-scope
 ] unit-test
+
+[ { "./factor.com" "-i=boot.x86.32.image" "-no-user-init" } ] [
+    [
+        "winnt" target-os set
+        "x86.32" target-cpu set
+        boot-cmd
+    ] with-scope
+] unit-test
diff --git a/extra/mason/child/child.factor b/extra/mason/child/child.factor
index 2ed9226524..feb11933fb 100755
--- a/extra/mason/child/child.factor
+++ b/extra/mason/child/child.factor
@@ -25,8 +25,11 @@ IN: mason.child
     builds-factor-image "." copy-file-into
     builds-factor-image "factor" copy-file-into ;
 
+: factor-vm ( -- string )
+    target-os get "winnt" = "./factor.com" "./factor" ? ;
+
 : boot-cmd ( -- cmd )
-    "./factor"
+    factor-vm
     "-i=" boot-image-name append
     "-no-user-init"
     3array ;
@@ -42,7 +45,7 @@ IN: mason.child
         try-process
     ] with-directory ;
 
-: test-cmd ( -- cmd ) { "./factor" "-run=mason.test" } ;
+: test-cmd ( -- cmd ) factor-vm "-run=mason.test" 2array ;
 
 : test ( -- )
     "factor" [

From 32954b75ad46980d4a0f1e90c683bc2242de9fd3 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 17:28:31 -0500
Subject: [PATCH 115/135] use functors to define human-sort

---
 basis/sorting/human/human-docs.factor |  2 +-
 basis/sorting/human/human.factor      | 17 ++---------------
 2 files changed, 3 insertions(+), 16 deletions(-)

diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor
index 5952b3e3f9..606eef670a 100644
--- a/basis/sorting/human/human-docs.factor
+++ b/basis/sorting/human/human-docs.factor
@@ -35,7 +35,7 @@ HELP: human-compare
 HELP: human-sort
 { $values
      { "seq" sequence }
-     { "seq'" sequence }
+     { "sortedseq" sequence }
 }
 { $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
 
diff --git a/basis/sorting/human/human.factor b/basis/sorting/human/human.factor
index c07ed8758b..b3dae45a9b 100644
--- a/basis/sorting/human/human.factor
+++ b/basis/sorting/human/human.factor
@@ -1,22 +1,9 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: peg.ebnf math.parser kernel assocs sorting fry
-math.order sequences ascii splitting.monotonic ;
+USING: math.parser peg.ebnf sorting.functor ;
 IN: sorting.human
 
 : find-numbers ( string -- seq )
     [EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
 
-: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
-
-: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
-
-: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; inline
-
-: human-sort ( seq -- seq' ) [ human<=> ] sort ;
-
-: human-sort-keys ( seq -- sortedseq )
-    [ [ first ] human-compare ] sort ;
-
-: human-sort-values ( seq -- sortedseq )
-    [ [ second ] human-compare ] sort ;
+<< "human" [ find-numbers ] define-sorting >>

From ce73c17c1d350a2743b1b3a96fea255aa9535c3b Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 17:28:55 -0500
Subject: [PATCH 116/135] add sorting.functor

---
 basis/sorting/functor/authors.txt    |  1 +
 basis/sorting/functor/functor.factor | 24 ++++++++++++++++++++++++
 2 files changed, 25 insertions(+)
 create mode 100644 basis/sorting/functor/authors.txt
 create mode 100644 basis/sorting/functor/functor.factor

diff --git a/basis/sorting/functor/authors.txt b/basis/sorting/functor/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/sorting/functor/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/sorting/functor/functor.factor b/basis/sorting/functor/functor.factor
new file mode 100644
index 0000000000..022ef3fb0d
--- /dev/null
+++ b/basis/sorting/functor/functor.factor
@@ -0,0 +1,24 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors kernel math.order sequences sorting ;
+IN: sorting.functor
+
+FUNCTOR: define-sorting ( NAME QUOT -- )
+
+NAME<=> DEFINES ${NAME}<=>
+NAME>=< DEFINES ${NAME}>=<
+NAME-compare DEFINES ${NAME}-compare
+NAME-sort DEFINES ${NAME}-sort
+NAME-sort-keys DEFINES ${NAME}-sort-keys
+NAME-sort-values DEFINES ${NAME}-sort-values
+
+WHERE
+
+: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
+: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
+: NAME-compare ( obj1 obj2 quot -- <=> ) bi@ NAME<=> ; inline
+: NAME-sort ( seq -- sortedseq ) [ NAME<=> ] sort ;
+: NAME-sort-keys ( seq -- sortedseq ) [ [ first ] NAME-compare ] sort ;
+: NAME-sort-values ( seq -- sortedseq ) [ [ second ] NAME-compare ] sort ;
+
+;FUNCTOR

From 2e1652db6d5d9927e64e4d844b6a0efb04e73ad7 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 17:38:21 -0500
Subject: [PATCH 117/135] simplify sorting.slots a bit

---
 basis/sorting/slots/slots.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor
index 56b6a115f0..bce9442e44 100644
--- a/basis/sorting/slots/slots.factor
+++ b/basis/sorting/slots/slots.factor
@@ -20,7 +20,7 @@ PRIVATE>
 
 MACRO: compare-slots ( sort-specs -- <=> )
     #! sort-spec: { accessors comparator }
-    [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
+    '[ _ [ slot-comparator ] map 2|| +eq+ or ] ;
 
 : sort-by-slots ( seq sort-specs -- seq' )
     '[ _ compare-slots ] sort ;

From 73a2fa49c53ad715bcfc625f164db36cf4fac742 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 18:19:45 -0500
Subject: [PATCH 118/135] add title sort for use with joe's mp3 player

---
 basis/sorting/title/authors.txt        |  1 +
 basis/sorting/title/title-tests.factor | 40 ++++++++++++++++++++++++++
 basis/sorting/title/title.factor       |  7 +++++
 3 files changed, 48 insertions(+)
 create mode 100644 basis/sorting/title/authors.txt
 create mode 100644 basis/sorting/title/title-tests.factor
 create mode 100644 basis/sorting/title/title.factor

diff --git a/basis/sorting/title/authors.txt b/basis/sorting/title/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/basis/sorting/title/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/basis/sorting/title/title-tests.factor b/basis/sorting/title/title-tests.factor
new file mode 100644
index 0000000000..34d9e90b38
--- /dev/null
+++ b/basis/sorting/title/title-tests.factor
@@ -0,0 +1,40 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test sorting.title ;
+IN: sorting.title.tests
+
+: sort-me ( -- seq )
+    {
+        "The Beatles"
+        "A river runs through it"
+        "Another"
+        "la vida loca"
+        "Basketball"
+        "racquetball"
+        "Los Fujis"
+        "los Fujis"
+        "La cucaracha"
+        "a day to remember"
+        "of mice and men"
+        "on belay"
+        "for the horde"
+    } ;
+[
+    {
+        "Another"
+        "Basketball"
+        "The Beatles"
+        "La cucaracha"
+        "a day to remember"
+        "for the horde"
+        "Los Fujis"
+        "los Fujis"
+        "of mice and men"
+        "on belay"
+        "racquetball"
+        "A river runs through it"
+        "la vida loca"
+    }
+] [
+    sort-me title-sort
+] unit-test
diff --git a/basis/sorting/title/title.factor b/basis/sorting/title/title.factor
new file mode 100644
index 0000000000..dbdbf8a8fb
--- /dev/null
+++ b/basis/sorting/title/title.factor
@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: sorting.functor regexp kernel accessors sequences
+unicode.case ;
+IN: sorting.title
+
+<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >>

From 3137d12f12e3823a46a5350dad2c52639dbbdab3 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 19:30:07 -0500
Subject: [PATCH 119/135] Fix some minor UI bugs

---
 .../gadgets/line-support/line-support.factor  |  3 +++
 basis/ui/gadgets/scrollers/scrollers.factor   |  1 +
 basis/ui/gadgets/tables/tables.factor         | 25 ++++++++-----------
 3 files changed, 15 insertions(+), 14 deletions(-)

diff --git a/basis/ui/gadgets/line-support/line-support.factor b/basis/ui/gadgets/line-support/line-support.factor
index 80feb31ad2..b9fe10c530 100644
--- a/basis/ui/gadgets/line-support/line-support.factor
+++ b/basis/ui/gadgets/line-support/line-support.factor
@@ -30,6 +30,9 @@ M: line-gadget line-height font>> font-metrics height>> ceiling ;
 : validate-line ( m gadget -- n )
     control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
 
+: valid-line? ( n gadget -- ? )
+    control-value length 1- 0 swap between? ;
+
 : visible-line ( gadget quot -- n )
     '[
         [ clip get @ origin get [ second ] bi@ - ] dip
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index 64e035c81b..b80940bd4a 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -58,6 +58,7 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
     {
         [ scroller-value vneg offset-rect ]
         [ viewport>> dim>> rect-min ]
+        [ viewport>> loc>> offset-rect ]
         [ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
         [ scroller-value v+ ]
         [ scroll ]
diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor
index f2ed5b10e0..312cb59efd 100644
--- a/basis/ui/gadgets/tables/tables.factor
+++ b/basis/ui/gadgets/tables/tables.factor
@@ -261,19 +261,20 @@ M: table model-changed
     row-rect [ { 0 1 } v* ] change-dim ;
 
 : (select-row) ( table n -- )
-    [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
+    [ dup [ [ thin-row-rect dup unparse show ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
     [ >>selected-index relayout-1 ]
     2bi ;
 
 : mouse-row ( table -- n )
     [ hand-rel second ] keep y>line ;
 
+: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
+    [ [ mouse-row ] keep 2dup valid-line? ]
+    [ ] [ '[ nip @ ] ] tri* if ; inline
+
 : table-button-down ( table -- )
     dup takes-focus?>> [ dup request-focus ] when
-    dup control-value empty? [ drop ] [
-        dup [ mouse-row ] keep validate-line
-        [ >>mouse-index ] [ (select-row) ] bi
-    ] if ;
+    [ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
 
 PRIVATE>
 
@@ -283,11 +284,14 @@ PRIVATE>
     [ 2drop ]
     if ;
 
+: row-action? ( table -- ? )
+    [ [ mouse-row ] keep valid-line? ]
+    [ single-click?>> hand-click# get 2 = or ] bi and ;
+
 <PRIVATE
 
 : table-button-up ( table -- )
-    dup single-click?>> hand-click# get 2 = or
-    [ row-action ] [ update-selected-value ] if ;
+    dup row-action? [ row-action ] [ update-selected-value ] if ;
 
 : select-row ( table n -- )
     over validate-line
@@ -320,13 +324,6 @@ PRIVATE>
 : next-page ( table -- )
     1 prev/next-page ;
 
-: valid-row? ( row table -- ? )
-    control-value length 1- 0 swap between? ;
-
-: if-mouse-row ( table true false -- )
-    [ [ mouse-row ] keep 2dup valid-row? ]
-    [ ] [ '[ nip @ ] ] tri* if ; inline
-
 : show-mouse-help ( table -- )
     [
         swap

From 695b97e6e6a593839b5f5f4f7b723de6ca815867 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 19:35:22 -0500
Subject: [PATCH 120/135] Remove debug stuff

---
 basis/ui/gadgets/tables/tables.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/basis/ui/gadgets/tables/tables.factor b/basis/ui/gadgets/tables/tables.factor
index 312cb59efd..77249149ae 100644
--- a/basis/ui/gadgets/tables/tables.factor
+++ b/basis/ui/gadgets/tables/tables.factor
@@ -261,7 +261,7 @@ M: table model-changed
     row-rect [ { 0 1 } v* ] change-dim ;
 
 : (select-row) ( table n -- )
-    [ dup [ [ thin-row-rect dup unparse show ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
+    [ dup [ [ thin-row-rect ] [ drop ] 2bi scroll>rect ] [ 2drop ] if ]
     [ >>selected-index relayout-1 ]
     2bi ;
 

From 8fdb3bb27aeb1969315585630d8d6c5c9caeba89 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 19:43:10 -0500
Subject: [PATCH 121/135] define a sort-by to take a sequence of comparators
 without slots

---
 basis/sorting/slots/slots-tests.factor | 18 +++++++++++++++++-
 basis/sorting/slots/slots.factor       | 14 ++++++++++++--
 2 files changed, 29 insertions(+), 3 deletions(-)

diff --git a/basis/sorting/slots/slots-tests.factor b/basis/sorting/slots/slots-tests.factor
index 46824c6fdb..83900461c3 100644
--- a/basis/sorting/slots/slots-tests.factor
+++ b/basis/sorting/slots/slots-tests.factor
@@ -1,7 +1,8 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors math.order sorting.slots tools.test
-sorting.human arrays sequences kernel assocs multiline ;
+sorting.human arrays sequences kernel assocs multiline
+sorting.functor ;
 IN: sorting.literals.tests
 
 TUPLE: sort-test a b c tuple2 ;
@@ -76,6 +77,9 @@ TUPLE: tuple2 d ;
 [ { } ]
 [ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
 
+[ { } ]
+[ { } { } sort-by-slots ] unit-test
+
 [
     {
         T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
@@ -143,3 +147,15 @@ TUPLE: tuple2 d ;
         T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
     } { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
 ] unit-test
+
+
+[ { "a" "b" "c" } ] [ { "b" "c" "a" } { <=> <=> } sort-by ] unit-test
+[ { "b" "c" "a" } ] [ { "b" "c" "a" } { } sort-by ] unit-test
+
+<< "length-test" [ length ] define-sorting >>
+
+[ { { 1 } { 1 2 3 } { 1 3 2 } { 3 2 1 } } ]
+[
+    { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
+    { length-test<=> <=> } sort-by
+] unit-test
diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor
index bce9442e44..4b6743af5c 100644
--- a/basis/sorting/slots/slots.factor
+++ b/basis/sorting/slots/slots.factor
@@ -7,6 +7,9 @@ IN: sorting.slots
 
 <PRIVATE
 
+: short-circuit-comparator ( word -- quot )
+    '[ _ execute dup +eq+ eq? [ drop f ] when ] ; inline
+
 : slot-comparator ( seq -- quot )
     [
         but-last-slice
@@ -20,11 +23,18 @@ PRIVATE>
 
 MACRO: compare-slots ( sort-specs -- <=> )
     #! sort-spec: { accessors comparator }
-    '[ _ [ slot-comparator ] map 2|| +eq+ or ] ;
+    [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
 
-: sort-by-slots ( seq sort-specs -- seq' )
+: sort-by-slots ( seq sort-specs -- sortedseq )
     '[ _ compare-slots ] sort ;
 
+MACRO: compare-seq ( seq -- quot )
+    [ short-circuit-comparator ] map '[ _ 2|| +eq+ or ] ;
+
+: sort-by ( seq sort-seq -- sortedseq )
+    '[ _ compare-seq ] sort ;
+
+
 MACRO: split-by-slots ( accessor-seqs -- quot )
     [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
     '[ [ _ 2&& ] slice monotonic-slice ] ;

From c97ca399d8ea5434b332c30ba1d25ab04d14c109 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 19:49:49 -0500
Subject: [PATCH 122/135] refactor a bit, document sort-by

---
 basis/sorting/slots/slots-docs.factor | 15 ++++++++++++---
 basis/sorting/slots/slots.factor      |  7 +++----
 2 files changed, 15 insertions(+), 7 deletions(-)

diff --git a/basis/sorting/slots/slots-docs.factor b/basis/sorting/slots/slots-docs.factor
index a3bdbf9ac1..cc89d497e7 100644
--- a/basis/sorting/slots/slots-docs.factor
+++ b/basis/sorting/slots/slots-docs.factor
@@ -14,7 +14,7 @@ HELP: compare-slots
 HELP: sort-by-slots
 { $values
      { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
-     { "seq'" sequence }
+     { "sortedseq" sequence }
 }
 { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
 { $examples
@@ -39,11 +39,20 @@ HELP: split-by-slots
 }
 { $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
 
+HELP: sort-by
+{ $values
+    { "seq" sequence } { "sort-seq" "a sequence of comparators" }
+    { "sortedseq" sequence }
+}
+{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
+
 ARTICLE: "sorting.slots" "Sorting by slots"
 "The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
 "Comparing two objects by a sequence of slots:"
 { $subsection compare-slots }
-"Sorting a sequence by a sequence of slots:"
-{ $subsection sort-by-slots } ;
+"Sorting a sequence of tuples by a slot/comparator pairs:"
+{ $subsection sort-by-slots }
+"Sorting a sequence by a sequence of comparators:"
+{ $subsection sort-by } ;
 
 ABOUT: "sorting.slots"
diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor
index 4b6743af5c..2dccc60821 100644
--- a/basis/sorting/slots/slots.factor
+++ b/basis/sorting/slots/slots.factor
@@ -8,7 +8,7 @@ IN: sorting.slots
 <PRIVATE
 
 : short-circuit-comparator ( word -- quot )
-    '[ _ execute dup +eq+ eq? [ drop f ] when ] ; inline
+    execute dup +eq+ eq? [ drop f ] when ; inline
 
 : slot-comparator ( seq -- quot )
     [
@@ -16,7 +16,7 @@ IN: sorting.slots
         [ '[ [ _ execute ] bi@ ] ] map concat
     ] [
         peek
-        '[ @ _ execute dup +eq+ eq? [ drop f ] when ]
+        '[ @ _ short-circuit-comparator ]
     ] bi ;
 
 PRIVATE>
@@ -29,12 +29,11 @@ MACRO: compare-slots ( sort-specs -- <=> )
     '[ _ compare-slots ] sort ;
 
 MACRO: compare-seq ( seq -- quot )
-    [ short-circuit-comparator ] map '[ _ 2|| +eq+ or ] ;
+    [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
 
 : sort-by ( seq sort-seq -- sortedseq )
     '[ _ compare-seq ] sort ;
 
-
 MACRO: split-by-slots ( accessor-seqs -- quot )
     [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
     '[ [ _ 2&& ] slice monotonic-slice ] ;

From bae79235946230bab13e48dadd7890a6defcf633 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 19:50:46 -0500
Subject: [PATCH 123/135] Fix more cosmetic issues

---
 basis/ui/gadgets/editors/editors.factor              | 2 +-
 basis/ui/gadgets/scrollers/scrollers.factor          | 1 -
 basis/ui/tools/listener/completion/completion.factor | 1 +
 3 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/basis/ui/gadgets/editors/editors.factor b/basis/ui/gadgets/editors/editors.factor
index f5b7f63d22..3eb40a5135 100755
--- a/basis/ui/gadgets/editors/editors.factor
+++ b/basis/ui/gadgets/editors/editors.factor
@@ -141,7 +141,7 @@ M: editor ungraft*
 : scroll>caret ( editor -- )
     dup graft-state>> second [
         [
-            [ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
+            [ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
         ] keep scroll>rect
     ] [ drop ] if ;
 
diff --git a/basis/ui/gadgets/scrollers/scrollers.factor b/basis/ui/gadgets/scrollers/scrollers.factor
index b80940bd4a..a526cc618b 100644
--- a/basis/ui/gadgets/scrollers/scrollers.factor
+++ b/basis/ui/gadgets/scrollers/scrollers.factor
@@ -54,7 +54,6 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
     2dup control-value = [ 2drop ] [ set-control-value ] if ;
 
 : (scroll>rect) ( rect scroller -- )
-    [ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
     {
         [ scroller-value vneg offset-rect ]
         [ viewport>> dim>> rect-min ]
diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor
index 022a2daabf..ba66121bc2 100644
--- a/basis/ui/tools/listener/completion/completion.factor
+++ b/basis/ui/tools/listener/completion/completion.factor
@@ -141,6 +141,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
         t >>selection-required?
         t >>single-click?
         30 >>min-cols
+        10 >>min-rows
         10 >>max-rows
         dup '[ _ accept-completion ] >>action ;
 

From 4c7b2f93379cf5925550747780f10d654d4577c2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 20:05:19 -0500
Subject: [PATCH 124/135] fix deriving urls in spider

---
 extra/spider/spider.factor | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index aeb4676767..5398e32ff4 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -84,7 +84,7 @@ TUPLE: unique-deque assoc deque ;
 
 : normalize-hrefs ( links spider -- links' )
     currently-spidering>> present swap
-    [ dup url-absolute? [ derive-url ] [ url-append-path >url ] if ] with map ;
+    [ [ >url ] bi@ derive-url ] with map ;
 
 : print-spidering ( url depth -- )
     "depth: " write number>string write

From 8875c2ba26c8adeaf72e9bfeb6f58d40f59a3dde Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 21:15:52 -0500
Subject: [PATCH 125/135] return links as URL objects in html vocab

---
 extra/html/parser/analyzer/analyzer.factor | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/extra/html/parser/analyzer/analyzer.factor b/extra/html/parser/analyzer/analyzer.factor
index 54b8c8fc69..2196f1baaa 100755
--- a/extra/html/parser/analyzer/analyzer.factor
+++ b/extra/html/parser/analyzer/analyzer.factor
@@ -127,11 +127,13 @@ TUPLE: link attributes clickable ;
         [ name>> "a" = ]
         [ attributes>> "href" swap key? ] bi and ] filter
     ] map sift
-    [ [ attributes>> "href" swap at ] map ] map concat ;
+    [ [ attributes>> "href" swap at ] map ] map concat
+    [ >url ] map ;
 
 : find-frame-links ( vector -- vector' )
     [ name>> "frame" = ] find-between-all
-    [ [ attributes>> "src" swap at ] map sift ] map concat sift ;
+    [ [ attributes>> "src" swap at ] map sift ] map concat sift
+    [ >url ] map ;
 
 : find-all-links ( vector -- vector' )
     [ find-hrefs ] [ find-frame-links ] bi append prune ;

From 1ee52e2090aa1cf2aa223fbcf849b97bee4d0868 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Fri, 3 Apr 2009 21:16:08 -0500
Subject: [PATCH 126/135] refactoring spider

---
 extra/spider/spider.factor | 38 +++++++++++++++++++-------------------
 1 file changed, 19 insertions(+), 19 deletions(-)

diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index 5398e32ff4..07989860ff 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -4,15 +4,15 @@ USING: accessors fry html.parser html.parser.analyzer
 http.client kernel tools.time sets assocs sequences
 concurrency.combinators io threads namespaces math multiline
 math.parser inspector urls logging combinators.short-circuit
-continuations calendar prettyprint dlists deques locals
-present ;
+continuations calendar prettyprint dlists deques locals ;
 IN: spider
 
 TUPLE: spider base count max-count sleep max-depth initial-links
-filters spidered todo nonmatching quiet currently-spidering ;
+filters spidered todo nonmatching quiet currently-spidering
+#threads follow-robots ;
 
-TUPLE: spider-result url depth headers fetch-time parsed-html
-links processing-time timestamp ;
+TUPLE: spider-result url depth headers
+fetched-in parsed-html links processed-in fetched-at ;
 
 TUPLE: todo-url url depth ;
 
@@ -51,7 +51,8 @@ TUPLE: unique-deque assoc deque ;
         0 >>max-depth
         0 >>count
         1/0. >>max-count
-        H{ } clone >>spidered ;
+        H{ } clone >>spidered
+        1 >>#threads ;
 
 <PRIVATE
 
@@ -79,12 +80,8 @@ TUPLE: unique-deque assoc deque ;
     [ add-nonmatching ]
     [ tuck [ apply-filters ] 2dip add-todo ] 2bi ;
 
-: url-absolute? ( url -- ? )
-    present "http://" head? ;
-
-: normalize-hrefs ( links spider -- links' )
-    currently-spidering>> present swap
-    [ [ >url ] bi@ derive-url ] with map ;
+: normalize-hrefs ( base links -- links' )
+    [ derive-url ] with map ;
 
 : print-spidering ( url depth -- )
     "depth: " write number>string write
@@ -94,7 +91,9 @@ TUPLE: unique-deque assoc deque ;
     f url spider spidered>> set-at
     [ url http-get ] benchmark :> fetch-time :> html :> headers
     [
-        html parse-html [ ] [ find-all-links spider normalize-hrefs ] bi
+        html parse-html
+        spider currently-spidering>>
+        over find-all-links normalize-hrefs
     ] benchmark :> processing-time :> links :> parsed-html
     url depth headers fetch-time parsed-html links processing-time
     now spider-result boa ;
@@ -107,11 +106,12 @@ TUPLE: unique-deque assoc deque ;
 
 \ spider-page ERROR add-error-logging
 
-: spider-sleep ( spider -- )
-    sleep>> [ sleep ] when* ;
+: spider-sleep ( spider -- ) sleep>> [ sleep ] when* ;
 
-:: queue-initial-links ( spider -- spider )
-    spider initial-links>> spider normalize-hrefs 0 spider add-todo spider ;
+: queue-initial-links ( spider -- )
+    [
+        [ currently-spidering>> ] [ initial-links>> ] bi normalize-hrefs 0
+    ] keep add-todo ;
 
 : spider-page? ( spider -- ? )
     {
@@ -121,7 +121,7 @@ TUPLE: unique-deque assoc deque ;
     } 1&& ;
 
 : setup-next-url ( spider -- spider url depth )
-    dup todo>> peek-url url>> present >>currently-spidering
+    dup todo>> peek-url url>> >>currently-spidering
     dup todo>> pop-url [ url>> ] [ depth>> ] bi ;
 
 : spider-next-page ( spider -- )
@@ -138,5 +138,5 @@ PRIVATE>
 
 : run-spider ( spider -- spider )
     "spider" [
-        queue-initial-links [ run-spider-loop ] keep
+        dup queue-initial-links [ run-spider-loop ] keep
     ] with-logging ;

From 95f304bee0a8aa0654c1369bf0a06b15745dbcea Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@slava-pestovs-macbook-pro.local>
Date: Fri, 3 Apr 2009 21:16:27 -0500
Subject: [PATCH 127/135] Check in spider.report

---
 extra/spider/report/authors.txt   |   1 +
 extra/spider/report/report.factor | 113 ++++++++++++++++++++++++++++++
 2 files changed, 114 insertions(+)
 create mode 100644 extra/spider/report/authors.txt
 create mode 100644 extra/spider/report/report.factor

diff --git a/extra/spider/report/authors.txt b/extra/spider/report/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/extra/spider/report/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/extra/spider/report/report.factor b/extra/spider/report/report.factor
new file mode 100644
index 0000000000..8bb4f91f82
--- /dev/null
+++ b/extra/spider/report/report.factor
@@ -0,0 +1,113 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays assocs combinators kernel math
+math.statistics namespaces sequences sorting xml.syntax
+spider ;
+IN: spider.report
+
+SYMBOL: network-failures
+SYMBOL: broken-pages
+SYMBOL: timings
+
+: record-broken-page ( url spider-result -- )
+    headers>> [ code>> ] [ message>> ] bi 2array 2array
+    broken-pages push ;
+
+: record-page-timings ( url spider-result -- )
+    fetch-time>> 2array timings get push ;
+
+: record-network-failure ( url -- )
+    network-failures get push ;
+
+: process-result ( url spider-result -- )
+    {
+        { f [ record-network-failure ] }
+        [
+            dup headers>> code>> 200 =
+            [ record-page-timings ] [ record-broken-page ] if
+        ]
+    } case ;
+
+CONSTANT: slowest 5
+
+SYMBOL: slowest-pages
+SYMBOL: mean-time
+SYMBOL: median-time
+SYMBOL: time-std
+
+: process-timings ( -- )
+    timings get sort-values
+    [ slowest short tail* reverse slowest-pages set ]
+    [
+        values
+        [ mean 1000000 /f mean-time set ]
+        [ median 1000000 /f median-time set ]
+        [ std 1000000 /f time-std set ] tri
+    ] bi ;
+
+: process-results ( results -- )
+    V{ } clone network-failures set
+    V{ } clone broken-pages set
+    V{ } clone timings set
+    [ process-result ] assoc-each
+    process-timings ;
+
+: info-table ( alist -- html )
+    [
+        first2 dupd 1000000 /f
+        [XML
+        <tr><td><a href=<->><-></a></td><td><-> seconds</td></tr>
+        XML]
+    ] map [XML <table border="1"><-></table> XML] ;
+
+: report-broken-pages ( -- html )
+    broken-pages get info-table ;
+
+: report-network-failures ( -- html )
+    network-failures get [
+        dup [XML <li><a href=<->><-></a></li> XML]
+    ] map [XML <ul><-></ul> XML] ;
+
+: slowest-pages-table ( -- html )
+    slowest-pages get info-table ;
+
+: timing-summary-table ( -- html )
+    mean-time get
+    median-time get
+    time-std get
+    [XML
+    <table border="1">
+    <tr><th>Mean</th><td><-> seconds</td></tr>
+    <tr><th>Median</th><td><-> seconds</td></tr>
+    <tr><th>Standard deviation</th><td><-> seconds</td></tr>
+    </table>
+    XML] ;
+
+: report-timings ( -- html )
+    slowest-pages-table
+    timing-summary-table
+    [XML
+    <h2>Slowest pages</h2>
+    <->
+
+    <h2>Summary</h2>
+    <->
+    XML] ;
+
+: generate-report ( -- html )
+    report-broken-pages
+    report-network-failures
+    report-timings
+    [XML
+    <h1>Broken pages</h1>
+    <->
+
+    <h1>Network failures</h1>
+    <->
+
+    <h1>Load times</h1>
+    <->
+    XML] ;
+
+: spider-report ( spider -- html )
+    [ spidered>> process-results generate-report ] with-scope ;

From 6f2c4fc02a137c92edc0ae7a677f9e0bcc11f3fb Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 4 Apr 2009 00:02:15 -0500
Subject: [PATCH 128/135] slim down the sorting.functor using more combinators

---
 basis/sorting/functor/functor.factor   |  8 ------
 basis/sorting/human/human-docs.factor  | 35 --------------------------
 basis/sorting/human/human-tests.factor |  4 +--
 basis/sorting/slots/slots.factor       | 10 ++++++--
 basis/sorting/title/title-tests.factor |  4 +--
 5 files changed, 12 insertions(+), 49 deletions(-)

diff --git a/basis/sorting/functor/functor.factor b/basis/sorting/functor/functor.factor
index 022ef3fb0d..7f46af4c92 100644
--- a/basis/sorting/functor/functor.factor
+++ b/basis/sorting/functor/functor.factor
@@ -7,18 +7,10 @@ FUNCTOR: define-sorting ( NAME QUOT -- )
 
 NAME<=> DEFINES ${NAME}<=>
 NAME>=< DEFINES ${NAME}>=<
-NAME-compare DEFINES ${NAME}-compare
-NAME-sort DEFINES ${NAME}-sort
-NAME-sort-keys DEFINES ${NAME}-sort-keys
-NAME-sort-values DEFINES ${NAME}-sort-values
 
 WHERE
 
 : NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
 : NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
-: NAME-compare ( obj1 obj2 quot -- <=> ) bi@ NAME<=> ; inline
-: NAME-sort ( seq -- sortedseq ) [ NAME<=> ] sort ;
-: NAME-sort-keys ( seq -- sortedseq ) [ [ first ] NAME-compare ] sort ;
-: NAME-sort-values ( seq -- sortedseq ) [ [ second ] NAME-compare ] sort ;
 
 ;FUNCTOR
diff --git a/basis/sorting/human/human-docs.factor b/basis/sorting/human/human-docs.factor
index 606eef670a..4bb62b1313 100644
--- a/basis/sorting/human/human-docs.factor
+++ b/basis/sorting/human/human-docs.factor
@@ -25,46 +25,11 @@ HELP: human>=<
 }
 { $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ;
 
-HELP: human-compare
-{ $values
-     { "obj1" object } { "obj2" object } { "quot" quotation }
-     { "<=>" "an ordering specifier" }
-}
-{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
-
-HELP: human-sort
-{ $values
-     { "seq" sequence }
-     { "sortedseq" sequence }
-}
-{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
-
-HELP: human-sort-keys
-{ $values
-     { "seq" "an alist" }
-     { "sortedseq" "a new sorted sequence" }
-}
-{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ;
-
-HELP: human-sort-values
-{ $values
-     { "seq" "an alist" }
-     { "sortedseq" "a new sorted sequence" }
-}
-{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ;
-
-{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
-
 ARTICLE: "sorting.human" "Human-friendly sorting"
 "The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
 "Comparing two objects:"
 { $subsection human<=> }
 { $subsection human>=< }
-{ $subsection human-compare }
-"Sort a sequence:"
-{ $subsection human-sort }
-{ $subsection human-sort-keys }
-{ $subsection human-sort-values }
 "Splitting a string into substrings and integers:"
 { $subsection find-numbers } ;
 
diff --git a/basis/sorting/human/human-tests.factor b/basis/sorting/human/human-tests.factor
index 0e20b54c2f..519e0064b6 100644
--- a/basis/sorting/human/human-tests.factor
+++ b/basis/sorting/human/human-tests.factor
@@ -1,6 +1,6 @@
-USING: sorting.human tools.test ;
+USING: sorting.human tools.test sorting.slots ;
 IN: sorting.human.tests
 
 \ human-sort must-infer
 
-[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } human-sort ] unit-test
+[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor
index 2dccc60821..26458bb22c 100644
--- a/basis/sorting/slots/slots.factor
+++ b/basis/sorting/slots/slots.factor
@@ -7,8 +7,8 @@ IN: sorting.slots
 
 <PRIVATE
 
-: short-circuit-comparator ( word -- quot )
-    execute dup +eq+ eq? [ drop f ] when ; inline
+: short-circuit-comparator ( obj1 obj2 word --  comparator/? )
+    execute dup +eq+ eq? [ drop f ] when ;
 
 : slot-comparator ( seq -- quot )
     [
@@ -34,6 +34,12 @@ MACRO: compare-seq ( seq -- quot )
 : sort-by ( seq sort-seq -- sortedseq )
     '[ _ compare-seq ] sort ;
 
+: sort-keys-by ( seq sort-seq -- sortedseq )
+    '[ [ first ] bi@ _ compare-seq ] sort ;
+
+: sort-values-by ( seq sort-seq -- sortedseq )
+    '[ [ second ] bi@ _ compare-seq ] sort ;
+
 MACRO: split-by-slots ( accessor-seqs -- quot )
     [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
     '[ [ _ 2&& ] slice monotonic-slice ] ;
diff --git a/basis/sorting/title/title-tests.factor b/basis/sorting/title/title-tests.factor
index 34d9e90b38..65a58e463d 100644
--- a/basis/sorting/title/title-tests.factor
+++ b/basis/sorting/title/title-tests.factor
@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test sorting.title ;
+USING: tools.test sorting.title sorting.slots ;
 IN: sorting.title.tests
 
 : sort-me ( -- seq )
@@ -36,5 +36,5 @@ IN: sorting.title.tests
         "la vida loca"
     }
 ] [
-    sort-me title-sort
+    sort-me { title<=> } sort-by
 ] unit-test

From e929c397d1e8b12096bb4a05e9c06a37c54a488b Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 4 Apr 2009 11:57:23 -0500
Subject: [PATCH 129/135] refactoring spider

---
 extra/spider/report/report.factor             |  2 +-
 extra/spider/spider.factor                    | 29 ++++---------------
 extra/spider/unique-deque/authors.txt         |  1 +
 extra/spider/unique-deque/unique-deque.factor | 24 +++++++++++++++
 4 files changed, 31 insertions(+), 25 deletions(-)
 create mode 100644 extra/spider/unique-deque/authors.txt
 create mode 100644 extra/spider/unique-deque/unique-deque.factor

diff --git a/extra/spider/report/report.factor b/extra/spider/report/report.factor
index 8bb4f91f82..43952701d5 100644
--- a/extra/spider/report/report.factor
+++ b/extra/spider/report/report.factor
@@ -14,7 +14,7 @@ SYMBOL: timings
     broken-pages push ;
 
 : record-page-timings ( url spider-result -- )
-    fetch-time>> 2array timings get push ;
+    fetched-in>> 2array timings get push ;
 
 : record-network-failure ( url -- )
     network-failures get push ;
diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index 07989860ff..39ee3b5d7b 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -4,12 +4,13 @@ USING: accessors fry html.parser html.parser.analyzer
 http.client kernel tools.time sets assocs sequences
 concurrency.combinators io threads namespaces math multiline
 math.parser inspector urls logging combinators.short-circuit
-continuations calendar prettyprint dlists deques locals ;
+continuations calendar prettyprint dlists deques locals
+spider.unique-deque ;
 IN: spider
 
 TUPLE: spider base count max-count sleep max-depth initial-links
 filters spidered todo nonmatching quiet currently-spidering
-#threads follow-robots ;
+#threads follow-robots? robots ;
 
 TUPLE: spider-result url depth headers
 fetched-in parsed-html links processed-in fetched-at ;
@@ -21,26 +22,6 @@ TUPLE: todo-url url depth ;
         swap >>depth
         swap >>url ;
 
-TUPLE: unique-deque assoc deque ;
-
-: <unique-deque> ( -- unique-deque )
-    H{ } clone <dlist> unique-deque boa ;
-
-: url-exists? ( url unique-deque -- ? )
-    [ url>> ] [ assoc>> ] bi* key? ;
-
-: push-url ( url depth unique-deque -- )
-    [ <todo-url> ] dip 2dup url-exists? [
-        2drop
-    ] [
-        [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
-        [ deque>> push-back ] 2bi
-    ] if ;
-
-: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
-
-: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;
-
 : <spider> ( base -- spider )
     >url
     spider new
@@ -89,13 +70,13 @@ TUPLE: unique-deque assoc deque ;
 
 :: new-spidered-result ( spider url depth -- spider-result )
     f url spider spidered>> set-at
-    [ url http-get ] benchmark :> fetch-time :> html :> headers
+    [ url http-get ] benchmark :> fetched-at :> html :> headers
     [
         html parse-html
         spider currently-spidering>>
         over find-all-links normalize-hrefs
     ] benchmark :> processing-time :> links :> parsed-html
-    url depth headers fetch-time parsed-html links processing-time
+    url depth headers fetched-at parsed-html links processing-time
     now spider-result boa ;
 
 :: spider-page ( spider url depth -- )
diff --git a/extra/spider/unique-deque/authors.txt b/extra/spider/unique-deque/authors.txt
new file mode 100644
index 0000000000..b4bd0e7b35
--- /dev/null
+++ b/extra/spider/unique-deque/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
\ No newline at end of file
diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor
new file mode 100644
index 0000000000..28d92633d1
--- /dev/null
+++ b/extra/spider/unique-deque/unique-deque.factor
@@ -0,0 +1,24 @@
+! Copyright (C) 2009 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors assocs deques dlists kernel spider ;
+IN: spider.unique-deque
+
+TUPLE: unique-deque assoc deque ;
+
+: <unique-deque> ( -- unique-deque )
+    H{ } clone <dlist> unique-deque boa ;
+
+: url-exists? ( url unique-deque -- ? )
+    [ url>> ] [ assoc>> ] bi* key? ;
+
+: push-url ( url depth unique-deque -- )
+    [ <todo-url> ] dip 2dup url-exists? [
+        2drop
+    ] [
+        [ [ [ t ] dip url>> ] [ assoc>> ] bi* set-at ]
+        [ deque>> push-back ] 2bi
+    ] if ;
+
+: pop-url ( unique-deque -- todo-url ) deque>> pop-front ;
+
+: peek-url ( unique-deque -- todo-url ) deque>> peek-front ;

From 12fa6ac5a523b6647657bcddf0de451c94b14d12 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 4 Apr 2009 14:24:44 -0500
Subject: [PATCH 130/135] remove empty file

---
 basis/core-graphics/core-graphics-docs.factor | 0
 1 file changed, 0 insertions(+), 0 deletions(-)
 delete mode 100644 basis/core-graphics/core-graphics-docs.factor

diff --git a/basis/core-graphics/core-graphics-docs.factor b/basis/core-graphics/core-graphics-docs.factor
deleted file mode 100644
index e69de29bb2..0000000000

From a4f4abe19e4d22e43f4d44d0d9cefc4281d5f05c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 4 Apr 2009 14:25:37 -0500
Subject: [PATCH 131/135] remove empty file

---
 build-support/dlls.txt | 0
 1 file changed, 0 insertions(+), 0 deletions(-)
 delete mode 100644 build-support/dlls.txt

diff --git a/build-support/dlls.txt b/build-support/dlls.txt
deleted file mode 100644
index e69de29bb2..0000000000

From b549bd6cc9dd82ce1aeab6925d8128cf86a79932 Mon Sep 17 00:00:00 2001
From: "Jose A. Ortega Ruiz" <jao@gnu.org>
Date: Sat, 4 Apr 2009 22:34:21 +0200
Subject: [PATCH 132/135] FUEL: More robust extract word refactoring (catching
 empty region case).

---
 misc/fuel/fuel-refactor.el | 55 +++++++++++++++++++++-----------------
 1 file changed, 31 insertions(+), 24 deletions(-)

diff --git a/misc/fuel/fuel-refactor.el b/misc/fuel/fuel-refactor.el
index 942d439466..a410bb5047 100644
--- a/misc/fuel/fuel-refactor.el
+++ b/misc/fuel/fuel-refactor.el
@@ -36,7 +36,7 @@
       (let ((name (match-string-no-properties 2))
             (body (match-string-no-properties 4))
             (end (match-end 0)))
-        (list (split-string body nil t) name pos end)))))
+        (list (split-string (or body "") nil t) name pos end)))))
 
 (defun fuel-refactor--find (code to)
   (let ((candidate) (result))
@@ -88,7 +88,7 @@
 (defun fuel-refactor--insert-word (word stack-effect code)
   (let ((start (goto-char (fuel-refactor--insertion-point))))
     (open-line 1)
-    (insert ": " word " " stack-effect "\n" code " ;\n")
+    (insert ": " word " " stack-effect "\n" (or code " ") " ;\n")
     (indent-region start (point))
     (move-overlay fuel-stack--overlay start (point))))
 
@@ -103,39 +103,46 @@
     (delete-overlay fuel-stack--overlay)))
 
 (defun fuel-refactor--extract (begin end)
-  (unless (< begin end) (error "No proper region to extract"))
-  (let* ((code (buffer-substring begin end))
-         (existing (fuel-refactor--reuse-existing code))
-         (code-str (or existing (fuel--region-to-string begin end)))
+  (let* ((rp (< begin end))
+         (code (and rp (buffer-substring begin end)))
+         (existing (and code (fuel-refactor--reuse-existing code)))
+         (code-str (and code (or existing (fuel--region-to-string begin end))))
          (word (or (car existing) (read-string "New word name: ")))
          (stack-effect (or existing
-                           (fuel-stack--infer-effect code-str)
+                           (and code-str (fuel-stack--infer-effect code-str))
                            (read-string "Stack effect: "))))
-    (goto-char begin)
-    (delete-region begin end)
-    (insert word)
-    (indent-region begin (point))
+    (when rp
+      (goto-char begin)
+      (delete-region begin end)
+      (insert word)
+      (indent-region begin (point)))
     (save-excursion
       (let ((start (or (cadr existing) (point))))
         (unless existing
           (fuel-refactor--insert-word word stack-effect code))
-        (fuel-refactor--extract-other start
-                                      (or (car (cddr existing)) (point))
-                                      code)))))
+        (if rp
+            (fuel-refactor--extract-other start
+                                          (or (car (cddr existing)) (point))
+                                          code)
+          (unwind-protect
+              (sit-for fuel-stack-highlight-period)
+            (delete-overlay fuel-stack--overlay)))))))
 
 (defun fuel-refactor-extract-region (begin end)
   "Extracts current region as a separate word."
   (interactive "r")
-  (let ((begin (save-excursion
-                 (goto-char begin)
-                 (when (zerop (skip-syntax-backward "w"))
-                   (skip-syntax-forward "-"))
-                 (point)))
-        (end (save-excursion
-               (goto-char end)
-               (skip-syntax-forward "w")
-               (point))))
-    (fuel-refactor--extract begin end)))
+  (if (= begin end)
+      (fuel-refactor--extract begin end)
+    (let ((begin (save-excursion
+                   (goto-char begin)
+                   (when (zerop (skip-syntax-backward "w"))
+                     (skip-syntax-forward "-"))
+                   (point)))
+          (end (save-excursion
+                 (goto-char end)
+                 (skip-syntax-forward "w")
+                 (point))))
+      (fuel-refactor--extract begin end))))
 
 (defun fuel-refactor-extract-sexp ()
   "Extracts current innermost sexp (up to point) as a separate

From 5fd9f446e7aa6b6720e46e8ad16df7a769b32f4d Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 4 Apr 2009 15:45:56 -0500
Subject: [PATCH 133/135] use more macros in sorting, fix test

---
 basis/sorting/human/human-tests.factor |  2 --
 basis/sorting/slots/slots.factor       | 14 +++++++-------
 2 files changed, 7 insertions(+), 9 deletions(-)

diff --git a/basis/sorting/human/human-tests.factor b/basis/sorting/human/human-tests.factor
index 519e0064b6..20a607188c 100644
--- a/basis/sorting/human/human-tests.factor
+++ b/basis/sorting/human/human-tests.factor
@@ -1,6 +1,4 @@
 USING: sorting.human tools.test sorting.slots ;
 IN: sorting.human.tests
 
-\ human-sort must-infer
-
 [ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
diff --git a/basis/sorting/slots/slots.factor b/basis/sorting/slots/slots.factor
index 26458bb22c..efec960c27 100644
--- a/basis/sorting/slots/slots.factor
+++ b/basis/sorting/slots/slots.factor
@@ -8,7 +8,7 @@ IN: sorting.slots
 <PRIVATE
 
 : short-circuit-comparator ( obj1 obj2 word --  comparator/? )
-    execute dup +eq+ eq? [ drop f ] when ;
+    execute dup +eq+ eq? [ drop f ] when ; inline
 
 : slot-comparator ( seq -- quot )
     [
@@ -25,19 +25,19 @@ MACRO: compare-slots ( sort-specs -- <=> )
     #! sort-spec: { accessors comparator }
     [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
 
-: sort-by-slots ( seq sort-specs -- sortedseq )
-    '[ _ compare-slots ] sort ;
+MACRO: sort-by-slots ( sort-specs -- quot )
+    '[ [ _ compare-slots ] sort ] ;
 
 MACRO: compare-seq ( seq -- quot )
     [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
 
-: sort-by ( seq sort-seq -- sortedseq )
-    '[ _ compare-seq ] sort ;
+MACRO: sort-by ( sort-seq -- quot )
+    '[ [ _ compare-seq ] sort ] ;
 
-: sort-keys-by ( seq sort-seq -- sortedseq )
+MACRO: sort-keys-by ( sort-seq -- quot )
     '[ [ first ] bi@ _ compare-seq ] sort ;
 
-: sort-values-by ( seq sort-seq -- sortedseq )
+MACRO: sort-values-by ( sort-seq -- quot )
     '[ [ second ] bi@ _ compare-seq ] sort ;
 
 MACRO: split-by-slots ( accessor-seqs -- quot )

From 26dccb5b1683102c74b799c30fb5a6d2a1045ee5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 4 Apr 2009 15:46:18 -0500
Subject: [PATCH 134/135] human-sort is now { human<=> } sort-by

---
 extra/color-table/color-table.factor | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/extra/color-table/color-table.factor b/extra/color-table/color-table.factor
index 13a516eaf1..0865dabcf7 100644
--- a/extra/color-table/color-table.factor
+++ b/extra/color-table/color-table.factor
@@ -1,7 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel accessors combinators.smart sorting.human
-models colors.constants present
+models colors.constants present sorting.slots
 ui ui.gadgets.tables ui.gadgets.scrollers ;
 IN: color-table
 
@@ -29,7 +29,7 @@ M: color-renderer row-value
     drop named-color ;
 
 : <color-table> ( -- table )
-    named-colors human-sort <model>
+    named-colors { human<=> } sort-by <model>
     color-renderer
     <table>
         5 >>gap
@@ -40,4 +40,4 @@ M: color-renderer row-value
 : color-table-demo ( -- )
     [ <color-table> <scroller> "Colors" open-window ] with-ui ;
 
-MAIN: color-table-demo
\ No newline at end of file
+MAIN: color-table-demo

From 284511a2e796953306ed66217fc8a889b5abb8f5 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jobim.local>
Date: Sat, 4 Apr 2009 15:47:17 -0500
Subject: [PATCH 135/135] fix load erro

---
 extra/spider/spider.factor                    | 7 -------
 extra/spider/unique-deque/unique-deque.factor | 7 +++++++
 2 files changed, 7 insertions(+), 7 deletions(-)

diff --git a/extra/spider/spider.factor b/extra/spider/spider.factor
index 39ee3b5d7b..49d6c33f8f 100644
--- a/extra/spider/spider.factor
+++ b/extra/spider/spider.factor
@@ -15,13 +15,6 @@ filters spidered todo nonmatching quiet currently-spidering
 TUPLE: spider-result url depth headers
 fetched-in parsed-html links processed-in fetched-at ;
 
-TUPLE: todo-url url depth ;
-
-: <todo-url> ( url depth -- todo-url )
-    todo-url new
-        swap >>depth
-        swap >>url ;
-
 : <spider> ( base -- spider )
     >url
     spider new
diff --git a/extra/spider/unique-deque/unique-deque.factor b/extra/spider/unique-deque/unique-deque.factor
index 28d92633d1..ad46abdad3 100644
--- a/extra/spider/unique-deque/unique-deque.factor
+++ b/extra/spider/unique-deque/unique-deque.factor
@@ -3,6 +3,13 @@
 USING: accessors assocs deques dlists kernel spider ;
 IN: spider.unique-deque
 
+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 )