Merge git://spitspat.com/git/factor

core/combinators/combinators.factor

@@ -78,7 +78,11 @@ M: sequence hashcode*
 : hash-case>quot ( default assoc -- quot )
     dup empty? [
         drop
+    ] [
+        dup length 4 <= [
+            case>quot
         ] [
             hash-case-table hash-dispatch-quot
             [ dup hashcode >fixnum ] swap append
+        ] if
     ] if ;

core/compiler/compiler.factor

@@ -16,9 +16,10 @@ M: object inference-error-major? drop t ;
 
 : begin-batch ( seq -- )
     batch-mode on
-    [
+    "quiet" get [ drop ] [
-        "Compiling " % length # " words..." %
+        [ "Compiling " % length # " words..." % ] "" make
-    ] "" make print flush
+        print flush
+    ] if
     V{ } clone compile-errors set-global ;
 
 : compile-error. ( pair -- )

core/compiler/test/curry.factor

@@ -50,7 +50,7 @@ IN: temporary
     global keys =
 ] unit-test
 
-[ 3 ] [ 1 2 [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test
+[ 3 ] [ 1 [ 2 ] [ curry [ 3 ] [ 4 ] if ] compile-1 ] unit-test
 
 [ 3 ] [ t [ 3 [ ] curry 4 [ ] curry if ] compile-1 ] unit-test
 

core/compiler/test/simple.factor

@@ -56,3 +56,8 @@ IN: temporary
 \ recursive compile
 
 [ ] [ t recursive ] unit-test
+
+! Make sure error reporting works
+
+[ [ dup ] compile-1 ] unit-test-fails
+[ [ drop ] compile-1 ] unit-test-fails

core/io/files/files.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: io.files
 USING: io.backend io.files.private io hashtables kernel math
-memory namespaces sequences strings arrays definitions system
+memory namespaces sequences strings assocs arrays definitions
-combinators splitting ;
+system combinators splitting ;
 
 HOOK: <file-reader> io-backend ( path -- stream )
 
@@ -126,3 +126,34 @@ TUPLE: pathname string ;
 C: <pathname> pathname
 
 M: pathname <=> [ pathname-string ] compare ;
+
+HOOK: library-roots io-backend ( -- seq )
+HOOK: binary-roots io-backend ( -- seq )
+
+: find-file ( seq str -- path/f )
+    [
+        [ path+ exists? ] curry find nip
+    ] keep over [ path+ ] [ drop ] if ;
+
+: find-library ( str -- path/f )
+    library-roots swap find-file ;
+
+: find-binary ( str -- path/f )
+    binary-roots swap find-file ;
+
+<PRIVATE
+: append-path ( path files -- paths )
+    [ path+ ] curry* map ;
+
+: get-paths ( dir -- paths )
+    dup directory keys append-path ;
+
+: (walk-dir) ( path -- )
+    dup directory? [
+        get-paths dup % [ (walk-dir) ] each
+    ] [
+        drop
+    ] if ;
+PRIVATE>
+
+: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;

core/optimizer/known-words/known-words.factor

@@ -8,7 +8,7 @@ assocs quotations sequences.private io.binary io.crc32
 io.streams.string layouts splitting math.intervals
 math.floats.private tuples tuples.private classes
 optimizer.def-use optimizer.backend optimizer.pattern-match
-float-arrays combinators.private ;
+float-arrays combinators.private combinators ;
 
 ! the output of <tuple> and <tuple-boa> has the class which is
 ! its second-to-last input
@@ -50,6 +50,20 @@ float-arrays combinators.private ;
     { [ dup disjoint-eq? ] [ [ f ] inline-literals ] }
 } define-optimizers
 
+: literal-member? ( #call -- ? )
+    node-in-d peek dup value?
+    [ value-literal sequence? ] [ drop f ] if ;
+
+: member-quot ( seq -- newquot )
+    [ [ t ] ] { } map>assoc [ drop f ] add [ nip case ] curry ;
+
+: expand-member ( #call -- )
+    dup node-in-d peek value-literal member-quot splice-quot ;
+
+\ member? {
+    { [ dup literal-member? ] [ expand-member ] }
+} define-optimizers
+
 ! if the result of eq? is t and the second input is a literal,
 ! the first input is equal to the second
 \ eq? [

core/optimizer/math/math.factor

@@ -111,7 +111,7 @@ optimizer.def-use generic.standard ;
 
 : post-process ( class interval node -- classes intervals )
     dupd won't-overflow?
-    [ >r dup { f integer } memq? [ drop fixnum ] when r> ] when
+    [ >r dup { f integer } member? [ drop fixnum ] when r> ] when
     [ dup [ 1array ] when ] 2apply ;
 
 : math-output-interval-1 ( node word -- interval )

extra/benchmark/reverse-complement/reverse-complement.factor

@@ -26,6 +26,8 @@ HINTS: do-trans-map string ;
         over push
     ] if ;
 
+HINTS: do-line vector string ;
+
 : (reverse-complement) ( seq -- )
     readln [ do-line (reverse-complement) ] [ show-seq ] if* ;
 

extra/calendar/calendar.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 
 USING: arrays hashtables io io.streams.string kernel math
-math.vectors math.functions math.parser
+math.vectors math.functions math.parser namespaces sequences
-namespaces sequences strings tuples system ;
+strings tuples system debugger ;
 IN: calendar
 
 TUPLE: timestamp year month day hour minute second gmt-offset ;
@@ -318,6 +318,27 @@ M: timestamp <=> ( ts1 ts2 -- n )
         (timestamp>rfc3339)
     ] string-out ;
 
+: expect read1 assert= ;
+
+: (rfc3339>timestamp) ( -- timestamp )
+    4 read string>number ! year
+    CHAR: - expect
+    2 read string>number ! month
+    CHAR: - expect
+    2 read string>number ! day
+    CHAR: T expect
+    2 read string>number ! hour
+    CHAR: : expect
+    2 read string>number ! minute
+    CHAR: : expect
+    2 read string>number ! second
+    0 <timestamp> ;
+
+: rfc3339>timestamp ( str -- timestamp )
+    [
+        (rfc3339>timestamp)
+    ] string-in ;
+
 : file-time-string ( timestamp -- string )
     [
         [ timestamp-month month-abbreviations nth write ] keep bl

extra/combinators/lib/lib.factor

@@ -70,9 +70,6 @@ MACRO: napply ( n -- )
 MACRO: nfirst ( n -- )
     [ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
 
-: seq>stack ( seq -- )
-    dup length nfirst ; inline
-
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
 : sigma ( seq quot -- n ) [ rot slip + ] curry 0 swap reduce ;

extra/delegate/delegate.factor

@@ -65,8 +65,8 @@ PROTOCOL: prettyprint-section-protocol
 
 : define-mimic ( group mimicker mimicked -- )
     >r >r group-words r> r> [
-        pick "methods" word-prop at
+        pick "methods" word-prop at dup
-        [ method-def <method> spin define-method ] [ 3drop ] if*
+        [ method-def <method> spin define-method ] [ 3drop ] if
     ] 2curry each ; 
 
 : MIMIC:

extra/editors/editpadpro/editpadpro.factor

@@ -1,8 +1,15 @@
 USING: definitions kernel parser words sequences math.parser
-namespaces editors io.launcher ;
+namespaces editors io.launcher windows.shell32 io.files
+io.paths strings ;
 IN: editors.editpadpro
 
+: editpadpro-path
+    \ editpadpro-path get-global [
+        program-files "JGsoft" path+ walk-dir
+        [ >lower "editpadpro.exe" tail? ] find nip
+    ] unless* ;
+
 : editpadpro ( file line -- )
-    [ "editpadpro.exe /l" % # " \"" % % "\"" % ] "" make run-process ;
+    [ editpadpro-path % " /l" % # " \"" % % "\"" % ] "" make run-detached ;
 
 [ editpadpro ] edit-hook set-global

extra/editors/editplus/editplus.factor

@@ -1,12 +1,15 @@
-USING: editors io.launcher math.parser namespaces ;
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 ;
 IN: editors.editplus
 
+: editplus-path ( -- path )
+    \ editplus-path get-global [
+        program-files "\\EditPlus 2\\editplus.exe" append
+    ] unless* ;
+
 : editplus ( file line -- )
     [
-        \ editplus get-global % " -cursor " % # " " % %
+        editplus-path % " -cursor " % # " " % %
     ] "" make run-detached ;
 
-! Put in your .factor-boot-rc
-! "c:\\Program Files\\EditPlus\\editplus.exe" \ editplus set-global
-
 [ editplus ] edit-hook set-global

extra/editors/emeditor/emeditor.factor

@@ -1,9 +1,15 @@
-USING: editors io.launcher kernel math.parser namespaces ;
+USING: editors hardware-info.windows io.files io.launcher
+kernel math.parser namespaces sequences windows.shell32 ;
 IN: editors.emeditor
 
+: emeditor-path ( -- path )
+    \ emeditor-path get-global [
+        program-files "\\EmEditor\\EmEditor.exe" path+
+    ] unless* ;
+
 : emeditor ( file line -- )
     [
-        \ emeditor get-global % " /l " % #
+        emeditor-path % " /l " % #
         " " % "\"" % % "\"" %
     ] "" make run-detached ;
 

extra/editors/notepadpp/notepadpp.factor

@@ -1,13 +1,15 @@
-USING: editors io.launcher math.parser namespaces ;
+USING: editors io.files io.launcher kernel math.parser
+namespaces windows.shell32 ;
 IN: editors.notepadpp
 
+: notepadpp-path
+    \ notepadpp-path get-global [
+        program-files "notepad++\\notepad++.exe" path+
+    ] unless* ;
+
 : notepadpp ( file line -- )
     [
-        \ notepadpp get-global % " -n" % # " " % %
+        notepadpp-path % " -n" % # " " % %
     ] "" make run-detached ;
 
-! Put in your .factor-boot-rc
-! "c:\\Program Files\\notepad++\\notepad++.exe" \ notepadpp set-global
-! "k:\\Program Files (x86)\\notepad++\\notepad++.exe" \ notepadpp set-global
-
 [ notepadpp ] edit-hook set-global

extra/editors/ted-notepad/ted-notepad.factor

@@ -1,9 +1,15 @@
-USING: editors io.launcher kernel math.parser namespaces ;
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 ;
 IN: editors.ted-notepad
 
+: ted-notepad-path
+    \ ted-notepad-path get-global [
+        program-files "\\TED Notepad\\TedNPad.exe" path+
+    ] unless* ;
+
 : ted-notepad ( file line -- )
     [
-        \ ted-notepad get-global % " /l" % #
+        ted-notepad-path % " /l" % #
         " " % %
     ] "" make run-detached ;
 

extra/editors/ultraedit/ultraedit.factor

@@ -1,12 +1,17 @@
-USING: editors io.launcher kernel math.parser namespaces ;
+USING: editors io.files io.launcher kernel math.parser
+namespaces sequences windows.shell32 ;
 IN: editors.ultraedit
 
+: ultraedit-path ( -- path )
+    \ ultraedit-path get-global [
+        program-files
+        "\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" path+
+    ] unless* ;
+
 : ultraedit ( file line -- )
     [
-        \ ultraedit get-global % " " % swap % "/" % # "/1" %
+        ultraedit-path % " " % swap % "/" % # "/1" %
     ] "" make run-detached ;
 
-! Put the path in your .factor-boot-rc
-! "K:\\Program Files (x86)\\IDM Computer Solutions\\UltraEdit-32\\uedit32.exe" \ ultraedit set-global
 
 [ ultraedit ] edit-hook set-global

extra/editors/wordpad/authors.txt

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

extra/editors/wordpad/summary.txt

@@ -0,0 +1 @@
+Wordpad editor integration

extra/editors/wordpad/wordpad.factor

@@ -0,0 +1,15 @@
+USING: editors hardware-info.windows io.launcher kernel
+math.parser namespaces sequences windows.shell32 ;
+IN: editors.wordpad
+
+: wordpad-path ( -- path )
+    \ wordpad-path get [
+        program-files "\\Windows NT\\Accessories\\wordpad.exe" append
+    ] unless* ;
+
+: wordpad ( file line -- )
+    [
+        wordpad-path % drop " " % "\"" % % "\"" %
+    ] "" make run-detached ;
+
+[ wordpad ] edit-hook set-global

extra/furnace/furnace.factor

@@ -5,7 +5,7 @@ USING: kernel vectors io assocs quotations splitting strings
        continuations tuples classes io.files 
        http http.server.templating http.basic-authentication 
        webapps.callback html html.elements 
-       http.server.responders furnace.validator ;
+       http.server.responders furnace.validator vocabs ;
 IN: furnace
 
 SYMBOL: default-action
@@ -101,36 +101,14 @@ SYMBOL: request-params
 
 : service-post ( url -- ) "response" get swap service-request ;
 
-: explode-tuple ( tuple -- )
+: send-resource ( name -- )
-    dup tuple-slots swap class "slot-names" word-prop
+    template-path get swap path+ resource-path <file-reader>
-    [ set ] 2each ;
+    stdio get stream-copy ;
 
-SYMBOL: model
+: render-template ( template -- )
-
+    template-path get swap path+
-: call-template ( model template -- )
+    ".furnace" append resource-path
-    [
+    run-template-file ;
-        >r [ dup model set explode-tuple ] when* r>
-        ".furnace" append resource-path run-template-file
-    ] with-scope ;
-
-: render-template ( model template -- )
-    template-path get swap path+ call-template ;
-
-: render-page* ( model body-template head-template -- )
-    [
-        [ render-template ] [ f rot render-template ] html-document 
-    ] serve-html ;
-
-: render-titled-page* ( model body-template head-template title -- )
-    [ 
-        [ render-template ] swap [ <title> write </title> f rot render-template ] curry html-document
-    ] serve-html ;
-
-
-: render-page ( model template title -- )
-    [
-        [ render-template ] simple-html-document
-    ] serve-html ;
 
 : web-app ( name default path -- )
     [
@@ -141,3 +119,22 @@ SYMBOL: model
         [ service-post ] "post" set
         ! [ service-head ] "head" set
     ] make-responder ;
+
+: explode-tuple ( tuple -- )
+    dup tuple-slots swap class "slot-names" word-prop
+    [ set ] 2each ;
+
+SYMBOL: model
+
+: with-slots ( model quot -- )
+    [
+        >r [ dup model set explode-tuple ] when* r> call
+    ] with-scope ;
+
+: render-component ( model template -- )
+    swap [ render-template ] with-slots ;
+
+: browse-webapp-source ( vocab -- )
+    <a f >vocab-link browser-link-href =href a>
+        "Browse source" write
+    </a> ;

extra/hardware-info/windows/ce/ce.factor

@@ -1,7 +1,7 @@
-USING: alien.c-types hardware-info kernel math namespaces windows windows.kernel32 ;
+USING: alien.c-types hardware-info hardware-info.windows
+kernel math namespaces windows windows.kernel32 ;
 IN: hardware-info.windows.ce
 
-TUPLE: wince ;
 T{ wince } os set-global
 
 : memory-status ( -- MEMORYSTATUS )

extra/hardware-info/windows/nt/nt.factor

@@ -1,8 +1,8 @@
-USING: alien alien.c-types hardware-info kernel libc math namespaces
+USING: alien alien.c-types hardware-info hardware-info.windows
+kernel libc math namespaces
 windows windows.advapi32 windows.kernel32 ;
 IN: hardware-info.windows.nt
 
-TUPLE: winnt ;
 T{ winnt } os set-global
 
 : memory-status ( -- MEMORYSTATUSEX )

extra/hardware-info/windows/windows.factor

@@ -1,5 +1,6 @@
 USING: alien alien.c-types kernel libc math namespaces
-windows windows.kernel32 windows.advapi32 hardware-info ;
+windows windows.kernel32 windows.advapi32 hardware-info
+words ;
 IN: hardware-info.windows
 
 TUPLE: wince ;
@@ -53,6 +54,22 @@ M: windows cpus ( -- n )
 : sse3? ( -- ? )
     PF_SSE3_INSTRUCTIONS_AVAILABLE feature-present? ;
 
+: <u16-string-object> ( n -- obj )
+    "ushort" <c-array> ;
+
+: get-directory ( word -- str )
+    >r MAX_UNICODE_PATH [ <u16-string-object> ] keep dupd r>
+    execute win32-error=0/f alien>u16-string ; inline
+
+: windows-directory ( -- str )
+    \ GetWindowsDirectory get-directory ;
+
+: system-directory ( -- str )
+    \ GetSystemDirectory get-directory ;
+
+: system-windows-directory ( -- str )
+    \ GetSystemWindowsDirectory get-directory ;
+
 USE-IF: wince? hardware-info.windows.ce
 USE-IF: winnt? hardware-info.windows.nt
 

extra/help/handbook/handbook.factor

@@ -235,6 +235,7 @@ ARTICLE: "changes" "Changes in the latest release"
     { "New, efficient implementations of " { $link bit? } " and " { $link log2 } " runs in constant time for large bignums" }
     { "New " { $link big-random } " word for generating large random numbers quickly" }
     { "Improved profiler no longer has to be explicitly enabled and disabled with a full recompile; instead, the " { $link profile } " word can be used at any time, and it dynamically patches words to increment call counts. There is no overhead when the profiler is not in use." }
+    { "Calls to " { $link member? } " with a literal sequence are now open-coded. If there are four or fewer elements, a series of conditionals are generated; if there are more than four elements, there is a hash dispatch followed by conditionals in each branch." }
 }
 { $subheading "IO" }
 { $list
@@ -247,7 +248,7 @@ ARTICLE: "changes" "Changes in the latest release"
     { { $vocab-link "io.server" } " - improved logging support, logs to a file by default" }
     { { $vocab-link "io.files" } " - several new file system manipulation words added" }
     { { $vocab-link "tar" } " - tar file extraction in pure Factor (Doug Coleman)" }
-    { { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $vocab-link "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." }
+    { { $vocab-link "unix.linux" } ", " { $vocab-link "raptor" } " - ``Raptor Linux'', a set of alien bindings to low-level Linux features, such as network interface configuration, file system mounting/unmounting, etc, together with experimental boot scripts intended to entirely replace " { $snippet "/sbin/init" } ", " { $snippet "/etc/inittab" } " and " { $snippet "/etc/init.d/" } " (Eduardo Cavazos)." }
 }
 { $subheading "Tools" }
 { $list
@@ -264,7 +265,7 @@ ARTICLE: "changes" "Changes in the latest release"
     { "Windows can be closed on request now using " { $link close-window } }
     { "New icons (Elie Chaftari)" }
 }
-{ $subheading "Other" }
+{ $subheading "Libraries" }
 { $list
     { "The " { $snippet "queues" } " vocabulary has been removed because its functionality is a subset of " { $vocab-link "dlists" } }
     { "The " { $vocab-link "webapps.cgi" } " vocabulary implements CGI support for the Factor HTTP server." }
@@ -273,11 +274,19 @@ ARTICLE: "changes" "Changes in the latest release"
     { { $vocab-link "channels" } " - concurrent message passing over message channels" }
     { { $vocab-link "destructors" } " - deterministic scope-based resource deallocation (Doug Coleman)" }
     { { $vocab-link "dlists" } " - various updates (Doug Coleman)" }
+    { { $vocab-link "editors.emeditor" } " - EmEditor integration (Doug Coleman)" }
+    { { $vocab-link "editors.editplus" } " - EditPlus integration (Aaron Schaefer)" }
     { { $vocab-link "editors.notepadpp" } " - Notepad++ integration (Doug Coleman)" }
+    { { $vocab-link "editors.ted-notepad" } " - TED Notepad integration (Doug Coleman)" }
+    { { $vocab-link "editors.ultraedit" } " - UltraEdit integration (Doug Coleman)" }
+    { { $vocab-link "globs" } " - simple Unix shell-style glob patterns" }
     { { $vocab-link "heaps" } " - updated for new module system and cleaned up (Doug Coleman)" }
     { { $vocab-link "peg" } " - Parser Expression Grammars, a new appoach to parser construction, similar to parser combinators (Chris Double)" }
     { { $vocab-link "regexp" } " - revived from " { $snippet "unmaintained/" } " and completely redesigned (Doug Coleman)" }
-    { { $vocab-link "tuple.lib" } " - some utility words for working with tuples (Doug Coleman)" }
+    { { $vocab-link "rss" } " - add Atom feed generation (Daniel Ehrenberg)" }
+    { { $vocab-link "tuples.lib" } " - some utility words for working with tuples (Doug Coleman)" }
+    { { $vocab-link "webapps.pastebin" } " - improved appearance, add Atom feed generation, add syntax highlighting using " { $vocab-link "xmode" } }
+    { { $vocab-link "webapps.planet" } " - add Atom feed generation" }
 }
 { $heading "Factor 0.90" }
 { $subheading "Core" }

extra/http/http.factor

@@ -20,7 +20,7 @@ IN: http
     dup letter?
     over LETTER? or
     over digit? or
-    swap "/_?." member? or ; foldable
+    swap "/_-?." member? or ; foldable
 
 : url-encode ( str -- str )
     [

extra/id3/id3.factor

@@ -2,7 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 
-USING: arrays combinators io io.binary io.files io.utf16 kernel math math.parser namespaces sequences splitting strings assocs ;
+USING: arrays combinators io io.binary io.files io.paths
+io.utf16 kernel math math.parser namespaces sequences
+splitting strings assocs ;
 
 IN: id3
 
@@ -121,18 +123,6 @@ C: <extended-header> extended-header
 : id3v2 ( filename -- tag/f )
   <file-reader> [ read-tag ] with-stream ;
 
-: append-path ( path files -- paths )
-  [ path+ ] curry* map ;
-
-: get-paths ( dir -- paths )
-  dup directory keys append-path ;
-
-: (walk-dir) ( path -- )
-  dup directory? [ get-paths dup % [ (walk-dir) ] each ] [ drop ] if ;
-
-: walk-dir ( path -- seq )
-  [ (walk-dir) ] { } make ;
-
 : file? ( path -- ? )
   stat 3drop not ;
 

extra/io/paths/paths.factor

@@ -0,0 +1,24 @@
+USING: assocs io.files kernel namespaces sequences ;
+IN: io.paths
+
+: find-file ( seq str -- path/f )
+    [
+        [ path+ exists? ] curry find nip
+    ] keep over [ path+ ] [ drop ] if ;
+
+<PRIVATE
+: append-path ( path files -- paths )
+    [ path+ ] curry* map ;
+
+: get-paths ( dir -- paths )
+    dup directory keys append-path ;
+
+: (walk-dir) ( path -- )
+    dup directory? [
+        get-paths dup % [ (walk-dir) ] each
+    ] [
+        drop
+    ] if ;
+PRIVATE>
+
+: walk-dir ( path -- seq ) [ (walk-dir) ] { } make ;

extra/io/windows/ce/files/files.factor

@@ -7,7 +7,8 @@ IN: windows.ce.files
 ! M: windows-ce-io normalize-pathname ( string -- string )
     ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
 
-M: windows-ce-io CreateFile-flags ( -- DWORD ) FILE_ATTRIBUTE_NORMAL ;
+M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
+    FILE_ATTRIBUTE_NORMAL bitor ;
 M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
 
 : finish-read ( port status bytes-ret -- )

extra/io/windows/launcher/launcher.factor

@@ -87,9 +87,9 @@ TUPLE: CreateProcess-args
     pass-environment? [
         [
             get-environment
-            [ swap % "=" % % "\0" % ] assoc-each
+            [ "=" swap 3append string>u16-alien % ] assoc-each
             "\0" %
-        ] "" make >c-ushort-array
+        ] { } make >c-ushort-array
         over set-CreateProcess-args-lpEnvironment
     ] when ;
 

extra/io/windows/mmap/mmap.factor

@@ -62,7 +62,7 @@ M: windows-ce-io with-privileges
 
 : mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
     { "SeCreateGlobalPrivilege" "SeLockMemoryPrivilege" } [
-        >r >r open-file dup f r> 0 0 f
+        >r >r 0 open-file dup f r> 0 0 f
         CreateFileMapping [ win32-error=0/f ] keep
         dup close-later
         dup

extra/io/windows/nt/backend/backend.factor

@@ -27,7 +27,7 @@ M: windows-nt-io normalize-pathname ( string -- string )
         { [ dup ".\\" head? ] [
             >r unicode-prefix cwd r> 1 tail 3append
         ] }
-        ! c:\\
+        ! c:\\foo
         { [ dup 1 tail ":" head? ] [ >r unicode-prefix r> append ] }
         ! \\\\?\\c:\\foo
         { [ dup unicode-prefix head? ] [ ] }
@@ -38,7 +38,8 @@ M: windows-nt-io normalize-pathname ( string -- string )
                 dup first CHAR: \\ = [ CHAR: \\ , ] unless %
             ] "" make
         ] }
-    } cond [ "/\\." member? ] right-trim ;
+    } cond [ "/\\." member? ] right-trim
+    dup peek CHAR: : = [ "\\" append ] when ;
 
 SYMBOL: io-hash
 

extra/io/windows/nt/files/files.factor

@@ -3,8 +3,8 @@ io.windows.nt io.windows.nt.backend kernel libc math
 threads windows windows.kernel32 ;
 IN: io.windows.nt.files
 
-M: windows-nt-io CreateFile-flags ( -- DWORD )
+M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
-    FILE_FLAG_OVERLAPPED ;
+    FILE_FLAG_OVERLAPPED bitor ;
 
 M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
     make-overlapped ;

extra/io/windows/windows.factor

@@ -4,7 +4,7 @@ USING: alien alien.c-types arrays destructors io io.backend
 io.buffers io.files io.nonblocking io.sockets io.binary
 io.sockets.impl windows.errors strings io.streams.duplex kernel
 math namespaces sequences windows windows.kernel32
-windows.winsock splitting ;
+windows.shell32 windows.winsock splitting ;
 IN: io.windows
 
 TUPLE: windows-nt-io ;
@@ -23,7 +23,7 @@ TUPLE: win32-file handle ptr overlapped ;
 : <win32-duplex-stream> ( in out -- stream )
     >r f <win32-file> r> f <win32-file> handle>duplex-stream ;
 
-HOOK: CreateFile-flags io-backend ( -- DWORD )
+HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
 HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
 HOOK: add-completion io-backend ( port -- )
 
@@ -31,7 +31,8 @@ M: windows-io normalize-directory ( string -- string )
     "\\" ?tail drop "\\*" append ;
 
 : share-mode ( -- fixnum )
-    FILE_SHARE_READ FILE_SHARE_WRITE bitor ; inline
+    FILE_SHARE_READ FILE_SHARE_WRITE bitor
+    FILE_SHARE_DELETE bitor ; foldable
 
 M: win32-file init-handle ( handle -- )
     drop ;
@@ -40,24 +41,25 @@ M: win32-file close-handle ( handle -- )
     win32-file-handle CloseHandle drop ;
 
 ! Clean up resources (open handle) if add-completion fails
-: open-file ( path access-mode create-mode -- handle )
+: open-file ( path access-mode create-mode flags -- handle )
     [
-        >r share-mode f r> CreateFile-flags f CreateFile
+        >r >r >r normalize-pathname r>
+        share-mode f r> r> CreateFile-flags f CreateFile
         dup invalid-handle? dup close-later
         dup add-completion
     ] with-destructors ;
 
 : open-pipe-r/w ( path -- handle )
-    GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING open-file ;
+    GENERIC_READ GENERIC_WRITE bitor OPEN_EXISTING 0 open-file ;
 
 : open-read ( path -- handle length )
-    normalize-pathname GENERIC_READ OPEN_EXISTING open-file 0 ;
+    GENERIC_READ OPEN_EXISTING 0 open-file 0 ;
 
 : open-write ( path -- handle length )
-    normalize-pathname GENERIC_WRITE CREATE_ALWAYS open-file 0 ;
+    GENERIC_WRITE CREATE_ALWAYS 0 open-file 0 ;
 
 : (open-append) ( path -- handle )
-    normalize-pathname GENERIC_WRITE OPEN_ALWAYS open-file ;
+    GENERIC_WRITE OPEN_ALWAYS 0 open-file ;
 
 : set-file-pointer ( handle length -- )
     dupd d>w/w <uint> FILE_BEGIN SetFilePointer

extra/nehe/4/4.factor

@@ -57,11 +57,11 @@ M: nehe4-gadget draw-gadget* ( gadget -- )
   dup nehe4-gadget-rquad 0.15 - swap set-nehe4-gadget-rquad ;
 
 : nehe4-update-thread ( gadget -- )
-  dup nehe4-gadget-quit? [
+  dup nehe4-gadget-quit? [ drop ] [
     redraw-interval sleep
     dup relayout-1
     nehe4-update-thread
-  ] unless ;
+  ] if ;
 
 M: nehe4-gadget graft* ( gadget -- )
   [ f swap set-nehe4-gadget-quit? ] keep

extra/parser-combinators/parser-combinators.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2004 Chris Double.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: lazy-lists promises kernel sequences strings math
-arrays splitting quotations combinators ;
+arrays splitting quotations combinators namespaces ;
 IN: parser-combinators
 
 ! Parser combinator protocol
@@ -30,16 +30,32 @@ C: <parse-result> parse-result
         rot slice-seq <slice>
     ] if ;
 
-TUPLE: token-parser string ;
+: string= ( str1 str2 ignore-case -- ? )
+    [ [ >upper ] 2apply ] when sequence= ;
 
-C: token token-parser ( string -- parser )
+: string-head? ( str head ignore-case -- ? )
+    pick pick shorter? [
+        3drop f
+    ] [
+        >r [ length head-slice ] keep r> string=
+    ] if ;
+
+: ?string-head ( str head ignore-case -- newstr ? )
+    >r 2dup r> string-head?
+    [ length tail-slice t ] [ drop f ] if ;
+
+TUPLE: token-parser string ignore-case? ;
+
+C: <token-parser> token-parser
+
+: token ( string -- parser ) f <token-parser> ;
+
+: case-insensitive-token ( string -- parser ) t <token-parser> ;
 
 M: token-parser parse ( input parser -- list )
-    token-parser-string swap over ?head-slice [
+    dup token-parser-string swap token-parser-ignore-case?
-        <parse-result> 1list
+    >r tuck r> ?string-head
-    ] [
+    [ <parse-result> 1list ] [ 2drop nil ] if ;
-        2drop nil
-    ] if ;
 
 : 1token ( n -- parser ) 1string token ;
 
@@ -224,7 +240,7 @@ LAZY: <*> ( parser -- parser )
 
 LAZY: <?> ( parser -- parser )
     #! Return a parser that optionally uses the parser
-    #! if that parser would be successfull.
+    #! if that parser would be successful.
     [ 1array ] <@ f succeed <|> ;
 
 TUPLE: only-first-parser p1 ;
@@ -261,6 +277,10 @@ LAZY: <!?> ( parser -- parser )
     #! required.
     <?> only-first ;
 
+LAZY: <(?)> ( parser -- parser )
+    #! Like <?> but take shortest match first.
+    f succeed swap [ 1array ] <@ <|> ;
+
 LAZY: <(*)> ( parser -- parser )
     #! Like <*> but take shortest match first.
     #! Implementation by Matthew Willis.
@@ -290,8 +310,13 @@ LAZY: <(+)> ( parser -- parser )
 LAZY: surrounded-by ( parser start end -- parser' )
     [ token ] 2apply swapd pack ;
 
+: flatten* ( obj -- )
+    dup array? [ [ flatten* ] each ] [ , ] if ;
+
+: flatten [ flatten* ] { } make ;
+
 : exactly-n ( parser n -- parser' )
-    swap <repetition> <and-parser> ;
+    swap <repetition> <and-parser> [ flatten ] <@ ;
 
 : at-most-n ( parser n -- parser' )
     dup zero? [
@@ -305,4 +330,4 @@ LAZY: surrounded-by ( parser start end -- parser' )
     dupd exactly-n swap <*> <&> ;
 
 : from-m-to-n ( parser m n -- parser' )
-    >r [ exactly-n ] 2keep r> swap - at-most-n <&> ;
+    >r [ exactly-n ] 2keep r> swap - at-most-n <:&:> ;

extra/prolog/authors.txt

@@ -0,0 +1 @@
+Gavin Harrison

extra/prolog/prolog.factor

@@ -0,0 +1,84 @@
+! Copyright (C) 2007 Gavin Harrison
+! See http://factorcode.org/license.txt for BSD license.
+
+USING: kernel sequences arrays vectors namespaces math strings
+    combinators continuations quotations io assocs ;
+
+IN: prolog
+
+SYMBOL: pldb
+SYMBOL: plchoice
+
+: init-pl ( -- ) V{ } clone pldb set V{ } clone plchoice set ;
+
+: reset-choice ( -- ) V{ } clone plchoice set ;
+: remove-choice ( -- ) plchoice get pop drop ;
+: add-choice ( continuation -- ) 
+    dup continuation? [ plchoice get push ] [ drop ] if ;
+: last-choice ( -- ) plchoice get pop continue ;
+
+: rules ( -- vector ) pldb get ;
+: rule ( n -- rule ) dup rules length >= [ drop "No." ] [ rules nth ] if ;
+
+: var? ( pl-obj -- ? ) 
+    dup string? [ 0 swap nth LETTER? ] [ drop f ] if ;
+: const? ( pl-obj -- ? ) var? not ;
+
+: check-arity ( pat fact -- pattern fact ? ) 2dup [ length ] 2apply = ;
+: check-elements ( pat fact -- ? ) [ over var? [ 2drop t ] [ = ] if ] 2all? ;
+: (double-bound) ( key value assoc -- ? )
+    pick over at* [ pick = >r 3drop r> ] [ drop swapd set-at t ] if ;
+: single-bound? ( pat-d pat-f -- ? ) 
+    H{ } clone [ (double-bound) ] curry 2all? ;
+: match-pattern ( pat fact -- ? ) 
+    check-arity [ 2dup check-elements -rot single-bound? and ] [ 2drop f ] if ;
+: good-result? ( pat fact -- pat fact ? )
+    2dup dup "No." = [ 2drop t ] [ match-pattern ] if ;
+
+: add-rule ( name pat body -- ) 3array rules dup length swap set-nth ;
+
+: (lookup-rule) ( name num -- pat-f rules )
+    dup rule dup "No." = >r 0 swap nth swapd dupd = swapd r> or 
+    [ dup rule [ ] callcc0 add-choice ] when
+    dup number? [ 1+ (lookup-rule) ] [ 2nip ] if ;
+
+: add-bindings ( pat-d pat-f binds -- binds )
+    clone
+    [ over var? over const? or 
+        [ 2drop ] [ rot dup >r set-at r> ] if 
+    ] 2reduce ;
+: init-binds ( pat-d pat-f -- binds ) V{ } clone add-bindings >alist ;
+
+: replace-if-bound ( binds elt -- binds elt' ) 
+    over 2dup key? [ at ] [ drop ] if ;
+: deep-replace ( binds seq -- binds seq' )
+    [ dup var? [ replace-if-bound ] 
+        [ dup array? [ dupd deep-replace nip ] when ] if 
+    ] map ;
+
+: backtrace? ( result -- )
+    dup "No." = [ remove-choice last-choice ] 
+    [ [ last-choice ] unless ] if ;
+
+: resolve-rule ( pat-d pat-f rule-body -- binds )
+    >r 2dup init-binds r> [ deep-replace >quotation call dup backtrace?
+    dup t = [ drop ] when ] each ;
+
+: rule>pattern ( rule -- pattern ) 1 swap nth ;
+: rule>body ( rule -- body ) 2 swap nth ;
+
+: binds>fact ( pat-d pat-f binds -- fact )
+    [ 2dup key? [ at ] [ drop ] if ] curry map good-result? 
+    [ nip ] [ last-choice ] if ;
+
+: lookup-rule ( name pat -- fact )
+    swap 0 (lookup-rule) dup "No." =
+    [ nip ]
+    [ dup rule>pattern swapd check-arity 
+        [ rot rule>body resolve-rule dup -roll binds>fact nip ] [ last-choice ] if
+    ] if ;
+
+: binding-resolve ( binds name pat -- binds )
+    tuck lookup-rule dup backtrace? swap rot add-bindings ;
+
+: is ( binds val var -- binds ) rot [ set-at ] keep ;

extra/prolog/summary.txt

@@ -0,0 +1 @@
+Implementation of an embedded prolog for factor

extra/prolog/tags.txt

@@ -0,0 +1 @@
+prolog

extra/random-tester/random/random.factor

@@ -1,22 +1,12 @@
-USING: kernel math sequences namespaces errors hashtables words
+USING: kernel math sequences namespaces hashtables words
-arrays parser compiler syntax io tools prettyprint optimizer
+arrays parser compiler syntax io prettyprint optimizer
-inference ;
+random math.constants math.functions layouts random-tester.utils ;
 IN: random-tester
 
 ! Tweak me
 : max-length 15 ; inline
 : max-value 1000000000 ; inline
 
-: 10% ( -- bool ) 10 random 8 > ;
-: 20% ( -- bool ) 10 random 7 > ;
-: 30% ( -- bool ) 10 random 6 > ;
-: 40% ( -- bool ) 10 random 5 > ;
-: 50% ( -- bool ) 10 random 4 > ;
-: 60% ( -- bool ) 10 random 3 > ;
-: 70% ( -- bool ) 10 random 2 > ;
-: 80% ( -- bool ) 10 random 1 > ;
-: 90% ( -- bool ) 10 random 0 > ;
-
 ! varying bit-length random number
 : random-bits ( n -- int )
     random 2 swap ^ random ;
@@ -31,32 +21,29 @@ IN: random-tester
 SYMBOL: special-integers
 [ { -1 0 1 } % most-negative-fixnum , most-positive-fixnum , first-bignum , ] 
 { } make \ special-integers set-global
-: special-integers ( -- seq ) \ special-integers get ;
 SYMBOL: special-floats
 [ { 0.0 -0.0 } % e , pi , 1./0. , -1./0. , 0./0. , epsilon , epsilon neg , ]
 { } make \ special-floats set-global
-: special-floats ( -- seq ) \ special-floats get ;
 SYMBOL: special-complexes
 [ 
-    { -1 0 1 i -i } %
+    { -1 0 1 C{ 0 1 } C{ 0 -1 } } %
     e , e neg , pi , pi neg ,
     0 pi rect> , 0 pi neg rect> , pi neg 0 rect> , pi pi rect> ,
     pi pi neg rect> , pi neg pi rect> , pi neg pi neg rect> ,
     e neg e neg rect> , e e rect> ,
 ] { } make \ special-complexes set-global
-: special-complexes ( -- seq ) \ special-complexes get ;
 
 : random-fixnum ( -- fixnum )
-    most-positive-fixnum random 1+ coin-flip [ neg 1- ] when >fixnum ;
+    most-positive-fixnum random 1+ 50% [ neg 1- ] when >fixnum ;
 
 : random-bignum ( -- bignum )
-     400 random-bits first-bignum + coin-flip [ neg ] when ;
+     400 random-bits first-bignum + 50% [ neg ] when ;
     
 : random-integer ( -- n )
-    coin-flip [
+    50% [
         random-fixnum
     ] [
-        coin-flip [ random-bignum ] [ special-integers random ] if
+        50% [ random-bignum ] [ special-integers get random ] if
     ] if ;
 
 : random-positive-integer ( -- int )
@@ -67,12 +54,12 @@ SYMBOL: special-complexes
     ] if ;
 
 : random-ratio ( -- ratio )
-    1000000000 dup [ random ] 2apply 1+ / coin-flip [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
+    1000000000 dup [ random ] 2apply 1+ / 50% [ neg ] when dup [ drop random-ratio ] unless 10% [ drop 0 ] when ;
 
 : random-float ( -- float )
-    coin-flip [ random-ratio ] [ special-floats random ] if
+    50% [ random-ratio ] [ special-floats get random ] if
-    coin-flip 
+    50%
-    [ .0000000000000000001 /f ] [ coin-flip [ .00000000000000001 * ] when ] if
+    [ .0000000000000000001 /f ] [ 50% [ .00000000000000001 * ] when ] if
     >float ;
 
 : random-number ( -- number )

extra/random-tester/utils/utils.factor

@@ -1,5 +1,5 @@
 USING: arrays assocs combinators.lib continuations kernel
-math math.functions namespaces quotations random sequences
+math math.functions memoize namespaces quotations random sequences
 sequences.private shuffle ;
 
 IN: random-tester.utils
@@ -93,3 +93,14 @@ C: <p-list> p-list
     >r make-p-list r> (each-permutation) ;
 
 
+: builder-permutations ( n -- seq )
+    { [ compose ] [ swap curry ] } swap permutations
+    [ concat ] map ; foldable
+
+: all-quot-permutations ( seq -- newseq )
+    dup length 1- builder-permutations
+    swap [ 1quotation ] map dup length permutations
+    [ swap [ >r seq>stack r> call ] curry* map ] curry* map ;
+
+! clear { map sq 10 } all-quot-permutations [ [ [ [ [ call ] keep datastack length 2 = [ . .s nl ] when ] catch ] in-thread drop ] each ] each
+! clear { map sq sq 10 } all-quot-permutations [ [ [ [ [ call ] keep datastack length 2 = [ . .s nl ] when ] catch ] in-thread drop ] each ] each

extra/regexp/regexp-tests.factor

@@ -1,174 +1,201 @@
-USING: regexp tools.test ;
+USING: regexp tools.test kernel ;
 IN: regexp-tests
 
-[ f ] [ "b" "a*" matches? ] unit-test
+[ f ] [ "b" "a*" f <regexp> matches? ] unit-test
-[ t ] [ "" "a*" matches? ] unit-test
+[ t ] [ "" "a*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a*" matches? ] unit-test
+[ t ] [ "a" "a*" f <regexp> matches? ] unit-test
-[ t ] [ "aaaaaaa" "a*" matches? ] unit-test
+[ t ] [ "aaaaaaa" "a*" f <regexp> matches? ] unit-test
-[ f ] [ "ab" "a*" matches? ] unit-test
+[ f ] [ "ab" "a*" f <regexp> matches? ] unit-test
 
-[ t ] [ "abc" "abc" matches? ] unit-test
+[ t ] [ "abc" "abc" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a|b|c" matches? ] unit-test
+[ t ] [ "a" "a|b|c" f <regexp> matches? ] unit-test
-[ t ] [ "b" "a|b|c" matches? ] unit-test
+[ t ] [ "b" "a|b|c" f <regexp> matches? ] unit-test
-[ t ] [ "c" "a|b|c" matches? ] unit-test
+[ t ] [ "c" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "c" "d|e|f" matches? ] unit-test
+[ f ] [ "c" "d|e|f" f <regexp> matches? ] unit-test
 
-[ f ] [ "aa" "a|b|c" matches? ] unit-test
+[ f ] [ "aa" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "bb" "a|b|c" matches? ] unit-test
+[ f ] [ "bb" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "cc" "a|b|c" matches? ] unit-test
+[ f ] [ "cc" "a|b|c" f <regexp> matches? ] unit-test
-[ f ] [ "cc" "d|e|f" matches? ] unit-test
+[ f ] [ "cc" "d|e|f" f <regexp> matches? ] unit-test
 
-[ f ] [ "" "a+" matches? ] unit-test
+[ f ] [ "" "a+" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a+" matches? ] unit-test
+[ t ] [ "a" "a+" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "a+" matches? ] unit-test
+[ t ] [ "aa" "a+" f <regexp> matches? ] unit-test
 
-[ t ] [ "" "a?" matches? ] unit-test
+[ t ] [ "" "a?" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a?" matches? ] unit-test
+[ t ] [ "a" "a?" f <regexp> matches? ] unit-test
-[ f ] [ "aa" "a?" matches? ] unit-test
+[ f ] [ "aa" "a?" f <regexp> matches? ] unit-test
 
-[ f ] [ "" "." matches? ] unit-test
+[ f ] [ "" "." f <regexp> matches? ] unit-test
-[ t ] [ "a" "." matches? ] unit-test
+[ t ] [ "a" "." f <regexp> matches? ] unit-test
-[ t ] [ "." "." matches? ] unit-test
+[ t ] [ "." "." f <regexp> matches? ] unit-test
-! [ f ] [ "\n" "." matches? ] unit-test
+! [ f ] [ "\n" "." f <regexp> matches? ] unit-test
 
-[ f ] [ "" ".+" matches? ] unit-test
+[ f ] [ "" ".+" f <regexp> matches? ] unit-test
-[ t ] [ "a" ".+" matches? ] unit-test
+[ t ] [ "a" ".+" f <regexp> matches? ] unit-test
-[ t ] [ "ab" ".+" matches? ] unit-test
+[ t ] [ "ab" ".+" f <regexp> matches? ] unit-test
 
-[ t ] [ "" "a|b*|c+|d?" matches? ] unit-test
+[ t ] [ "" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a|b*|c+|d?" matches? ] unit-test
+[ t ] [ "a" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "c" "a|b*|c+|d?" matches? ] unit-test
+[ t ] [ "c" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "cc" "a|b*|c+|d?" matches? ] unit-test
+[ t ] [ "cc" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ f ] [ "ccd" "a|b*|c+|d?" matches? ] unit-test
+[ f ] [ "ccd" "a|b*|c+|d?" f <regexp> matches? ] unit-test
-[ t ] [ "d" "a|b*|c+|d?" matches? ] unit-test
+[ t ] [ "d" "a|b*|c+|d?" f <regexp> matches? ] unit-test
 
-[ t ] [ "foo" "foo|bar" matches? ] unit-test
+[ t ] [ "foo" "foo|bar" f <regexp> matches? ] unit-test
-[ t ] [ "bar" "foo|bar" matches? ] unit-test
+[ t ] [ "bar" "foo|bar" f <regexp> matches? ] unit-test
-[ f ] [ "foobar" "foo|bar" matches? ] unit-test
+[ f ] [ "foobar" "foo|bar" f <regexp> matches? ] unit-test
 
-[ f ] [ "" "(a)" matches? ] unit-test
+[ f ] [ "" "(a)" f <regexp> matches? ] unit-test
-[ t ] [ "a" "(a)" matches? ] unit-test
+[ t ] [ "a" "(a)" f <regexp> matches? ] unit-test
-[ f ] [ "aa" "(a)" matches? ] unit-test
+[ f ] [ "aa" "(a)" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "(a*)" matches? ] unit-test
+[ t ] [ "aa" "(a*)" f <regexp> matches? ] unit-test
 
-[ f ] [ "aababaaabbac" "(a|b)+" matches? ] unit-test
+[ f ] [ "aababaaabbac" "(a|b)+" f <regexp> matches? ] unit-test
-[ t ] [ "ababaaabba" "(a|b)+" matches? ] unit-test
+[ t ] [ "ababaaabba" "(a|b)+" f <regexp> matches? ] unit-test
 
-[ f ] [ "" "a{1}" matches? ] unit-test
+[ f ] [ "" "a{1}" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a{1}" matches? ] unit-test
+[ t ] [ "a" "a{1}" f <regexp> matches? ] unit-test
-[ f ] [ "aa" "a{1}" matches? ] unit-test
+[ f ] [ "aa" "a{1}" f <regexp> matches? ] unit-test
 
-[ f ] [ "a" "a{2,}" matches? ] unit-test
+[ f ] [ "a" "a{2,}" f <regexp> matches? ] unit-test
-[ t ] [ "aaa" "a{2,}" matches? ] unit-test
+[ t ] [ "aaa" "a{2,}" f <regexp> matches? ] unit-test
-[ t ] [ "aaaa" "a{2,}" matches? ] unit-test
+[ t ] [ "aaaa" "a{2,}" f <regexp> matches? ] unit-test
-[ t ] [ "aaaaa" "a{2,}" matches? ] unit-test
+[ t ] [ "aaaaa" "a{2,}" f <regexp> matches? ] unit-test
 
-[ t ] [ "" "a{,2}" matches? ] unit-test
+[ t ] [ "" "a{,2}" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a{,2}" matches? ] unit-test
+[ t ] [ "a" "a{,2}" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "a{,2}" matches? ] unit-test
+[ t ] [ "aa" "a{,2}" f <regexp> matches? ] unit-test
-[ f ] [ "aaa" "a{,2}" matches? ] unit-test
+[ f ] [ "aaa" "a{,2}" f <regexp> matches? ] unit-test
-[ f ] [ "aaaa" "a{,2}" matches? ] unit-test
+[ f ] [ "aaaa" "a{,2}" f <regexp> matches? ] unit-test
-[ f ] [ "aaaaa" "a{,2}" matches? ] unit-test
+[ f ] [ "aaaaa" "a{,2}" f <regexp> matches? ] unit-test
 
-[ f ] [ "" "a{1,3}" matches? ] unit-test
+[ f ] [ "" "a{1,3}" f <regexp> matches? ] unit-test
-[ t ] [ "a" "a{1,3}" matches? ] unit-test
+[ t ] [ "a" "a{1,3}" f <regexp> matches? ] unit-test
-[ t ] [ "aa" "a{1,3}" matches? ] unit-test
+[ t ] [ "aa" "a{1,3}" f <regexp> matches? ] unit-test
-[ t ] [ "aaa" "a{1,3}" matches? ] unit-test
+[ t ] [ "aaa" "a{1,3}" f <regexp> matches? ] unit-test
-[ f ] [ "aaaa" "a{1,3}" matches? ] unit-test
+[ f ] [ "aaaa" "a{1,3}" f <regexp> matches? ] unit-test
 
-[ f ] [ "" "[a]" matches? ] unit-test
+[ f ] [ "" "[a]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a]" matches? ] unit-test
+[ t ] [ "a" "[a]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[abc]" matches? ] unit-test
+[ t ] [ "a" "[abc]" f <regexp> matches? ] unit-test
-[ f ] [ "b" "[a]" matches? ] unit-test
+[ f ] [ "b" "[a]" f <regexp> matches? ] unit-test
-[ f ] [ "d" "[abc]" matches? ] unit-test
+[ f ] [ "d" "[abc]" f <regexp> matches? ] unit-test
-[ t ] [ "ab" "[abc]{1,2}" matches? ] unit-test
+[ t ] [ "ab" "[abc]{1,2}" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "[abc]{1,2}" matches? ] unit-test
+[ f ] [ "abc" "[abc]{1,2}" f <regexp> matches? ] unit-test
 
-[ f ] [ "" "[^a]" matches? ] unit-test
+[ f ] [ "" "[^a]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[^a]" matches? ] unit-test
+[ f ] [ "a" "[^a]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[^abc]" matches? ] unit-test
+[ f ] [ "a" "[^abc]" f <regexp> matches? ] unit-test
-[ t ] [ "b" "[^a]" matches? ] unit-test
+[ t ] [ "b" "[^a]" f <regexp> matches? ] unit-test
-[ t ] [ "d" "[^abc]" matches? ] unit-test
+[ t ] [ "d" "[^abc]" f <regexp> matches? ] unit-test
-[ f ] [ "ab" "[^abc]{1,2}" matches? ] unit-test
+[ f ] [ "ab" "[^abc]{1,2}" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "[^abc]{1,2}" matches? ] unit-test
+[ f ] [ "abc" "[^abc]{1,2}" f <regexp> matches? ] unit-test
 
-[ t ] [ "]" "[]]" matches? ] unit-test
+[ t ] [ "]" "[]]" f <regexp> matches? ] unit-test
-[ f ] [ "]" "[^]]" matches? ] unit-test
+[ f ] [ "]" "[^]]" f <regexp> matches? ] unit-test
 
-! [ "^" "[^]" matches? ] unit-test-fails
+! [ "^" "[^]" f <regexp> matches? ] unit-test-fails
-[ t ] [ "^" "[]^]" matches? ] unit-test
+[ t ] [ "^" "[]^]" f <regexp> matches? ] unit-test
-[ t ] [ "]" "[]^]" matches? ] unit-test
+[ t ] [ "]" "[]^]" f <regexp> matches? ] unit-test
 
-[ t ] [ "[" "[[]" matches? ] unit-test
+[ t ] [ "[" "[[]" f <regexp> matches? ] unit-test
-[ f ] [ "^" "[^^]" matches? ] unit-test
+[ f ] [ "^" "[^^]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^^]" matches? ] unit-test
+[ t ] [ "a" "[^^]" f <regexp> matches? ] unit-test
 
-[ t ] [ "-" "[-]" matches? ] unit-test
+[ t ] [ "-" "[-]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[-]" matches? ] unit-test
+[ f ] [ "a" "[-]" f <regexp> matches? ] unit-test
-[ f ] [ "-" "[^-]" matches? ] unit-test
+[ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^-]" matches? ] unit-test
+[ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
 
-[ t ] [ "-" "[-a]" matches? ] unit-test
+[ t ] [ "-" "[-a]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[-a]" matches? ] unit-test
+[ t ] [ "a" "[-a]" f <regexp> matches? ] unit-test
-[ t ] [ "-" "[a-]" matches? ] unit-test
+[ t ] [ "-" "[a-]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-]" matches? ] unit-test
+[ t ] [ "a" "[a-]" f <regexp> matches? ] unit-test
-[ f ] [ "b" "[a-]" matches? ] unit-test
+[ f ] [ "b" "[a-]" f <regexp> matches? ] unit-test
-[ f ] [ "-" "[^-]" matches? ] unit-test
+[ f ] [ "-" "[^-]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^-]" matches? ] unit-test
+[ t ] [ "a" "[^-]" f <regexp> matches? ] unit-test
 
-[ f ] [ "-" "[a-c]" matches? ] unit-test
+[ f ] [ "-" "[a-c]" f <regexp> matches? ] unit-test
-[ t ] [ "-" "[^a-c]" matches? ] unit-test
+[ t ] [ "-" "[^a-c]" f <regexp> matches? ] unit-test
-[ t ] [ "b" "[a-c]" matches? ] unit-test
+[ t ] [ "b" "[a-c]" f <regexp> matches? ] unit-test
-[ f ] [ "b" "[^a-c]" matches? ] unit-test
+[ f ] [ "b" "[^a-c]" f <regexp> matches? ] unit-test
 
-[ t ] [ "-" "[a-c-]" matches? ] unit-test
+[ t ] [ "-" "[a-c-]" f <regexp> matches? ] unit-test
-[ f ] [ "-" "[^a-c-]" matches? ] unit-test
+[ f ] [ "-" "[^a-c-]" f <regexp> matches? ] unit-test
 
-[ t ] [ "\\" "[\\\\]" matches? ] unit-test
+[ t ] [ "\\" "[\\\\]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[\\\\]" matches? ] unit-test
+[ f ] [ "a" "[\\\\]" f <regexp> matches? ] unit-test
-[ f ] [ "\\" "[^\\\\]" matches? ] unit-test
+[ f ] [ "\\" "[^\\\\]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^\\\\]" matches? ] unit-test
+[ t ] [ "a" "[^\\\\]" f <regexp> matches? ] unit-test
 
-[ t ] [ "0" "[\\d]" matches? ] unit-test
+[ t ] [ "0" "[\\d]" f <regexp> matches? ] unit-test
-[ f ] [ "a" "[\\d]" matches? ] unit-test
+[ f ] [ "a" "[\\d]" f <regexp> matches? ] unit-test
-[ f ] [ "0" "[^\\d]" matches? ] unit-test
+[ f ] [ "0" "[^\\d]" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[^\\d]" matches? ] unit-test
+[ t ] [ "a" "[^\\d]" f <regexp> matches? ] unit-test
 
-[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" matches? ] unit-test
+[ t ] [ "a" "[a-z]{1,}|[A-Z]{2,4}|b*|c|(f|g)*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" matches? ] unit-test
+[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}|b*|c|(f|g)*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" matches? ] unit-test
+[ t ] [ "a" "[a-z]{1,2}|[A-Z]{3,3}" f <regexp> matches? ] unit-test
 
-[ t ] [ "1000" "\\d{4,6}" matches? ] unit-test
+[ t ] [ "1000" "\\d{4,6}" f <regexp> matches? ] unit-test
-[ t ] [ "1000" "[0-9]{4,6}" matches? ] unit-test
+[ t ] [ "1000" "[0-9]{4,6}" f <regexp> matches? ] unit-test
 
-[ t ] [ "abc" "\\p{Lower}{3}" matches? ] unit-test
+[ t ] [ "abc" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
-[ f ] [ "ABC" "\\p{Lower}{3}" matches? ] unit-test
+[ f ] [ "ABC" "\\p{Lower}{3}" f <regexp> matches? ] unit-test
-[ t ] [ "ABC" "\\p{Upper}{3}" matches? ] unit-test
+[ t ] [ "ABC" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "\\p{Upper}{3}" matches? ] unit-test
+[ f ] [ "abc" "\\p{Upper}{3}" f <regexp> matches? ] unit-test
 
-[ f ] [ "abc" "[\\p{Upper}]{3}" matches? ] unit-test
+[ f ] [ "abc" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
-[ t ] [ "ABC" "[\\p{Upper}]{3}" matches? ] unit-test
+[ t ] [ "ABC" "[\\p{Upper}]{3}" f <regexp> matches? ] unit-test
 
-[ t ] [ "" "\\Q\\E" matches? ] unit-test
+[ t ] [ "" "\\Q\\E" f <regexp> matches? ] unit-test
-[ f ] [ "a" "\\Q\\E" matches? ] unit-test
+[ f ] [ "a" "\\Q\\E" f <regexp> matches? ] unit-test
-[ t ] [ "|*+" "\\Q|*+\\E" matches? ] unit-test
+[ t ] [ "|*+" "\\Q|*+\\E" f <regexp> matches? ] unit-test
-[ f ] [ "abc" "\\Q|*+\\E" matches? ] unit-test
+[ f ] [ "abc" "\\Q|*+\\E" f <regexp> matches? ] unit-test
 
-[ t ] [ "S" "\\0123" matches? ] unit-test
+[ t ] [ "S" "\\0123" f <regexp> matches? ] unit-test
-[ t ] [ "SXY" "\\0123XY" matches? ] unit-test
+[ t ] [ "SXY" "\\0123XY" f <regexp> matches? ] unit-test
-[ t ] [ "x" "\\x78" matches? ] unit-test
+[ t ] [ "x" "\\x78" f <regexp> matches? ] unit-test
-[ f ] [ "y" "\\x78" matches? ] unit-test
+[ f ] [ "y" "\\x78" f <regexp> matches? ] unit-test
-[ t ] [ "x" "\\u0078" matches? ] unit-test
+[ t ] [ "x" "\\u0078" f <regexp> matches? ] unit-test
-[ f ] [ "y" "\\u0078" matches? ] unit-test
+[ f ] [ "y" "\\u0078" f <regexp> matches? ] unit-test
 
-[ t ] [ "ab" "a+b" matches? ] unit-test
+[ t ] [ "ab" "a+b" f <regexp> matches? ] unit-test
-[ f ] [ "b" "a+b" matches? ] unit-test
+[ f ] [ "b" "a+b" f <regexp> matches? ] unit-test
-[ t ] [ "aab" "a+b" matches? ] unit-test
+[ t ] [ "aab" "a+b" f <regexp> matches? ] unit-test
-[ f ] [ "abb" "a+b" matches? ] unit-test
+[ f ] [ "abb" "a+b" f <regexp> matches? ] unit-test
 
-[ t ] [ "abbbb" "ab*" matches? ] unit-test
+[ t ] [ "abbbb" "ab*" f <regexp> matches? ] unit-test
-[ t ] [ "a" "ab*" matches? ] unit-test
+[ t ] [ "a" "ab*" f <regexp> matches? ] unit-test
-[ f ] [ "abab" "ab*" matches? ] unit-test
+[ f ] [ "abab" "ab*" f <regexp> matches? ] unit-test
 
-[ f ] [ "x" "\\." matches? ] unit-test
+[ f ] [ "x" "\\." f <regexp> matches? ] unit-test
-[ t ] [ "." "\\." matches? ] unit-test
+[ t ] [ "." "\\." f <regexp> matches? ] unit-test
+
+[ t ] [ "aaaab" "a+ab" f <regexp> matches? ] unit-test
+[ f ] [ "aaaxb" "a+ab" f <regexp> matches? ] unit-test
+[ t ] [ "aaacb" "a+cb" f <regexp> matches? ] unit-test
+[ f ] [ "aaaab" "a++ab" f <regexp> matches? ] unit-test
+[ t ] [ "aaacb" "a++cb" f <regexp> matches? ] unit-test
+
+[ 3 ] [ "aaacb" "a*" f <regexp> match-head ] unit-test
+[ 1 ] [ "aaacb" "a+?" f <regexp> match-head ] unit-test
+[ 2 ] [ "aaacb" "aa?" f <regexp> match-head ] unit-test
+[ 1 ] [ "aaacb" "aa??" f <regexp> match-head ] unit-test
+[ 3 ] [ "aacb" "aa?c" f <regexp> match-head ] unit-test
+[ 3 ] [ "aacb" "aa??c" f <regexp> match-head ] unit-test
+
+[ t ] [ "aaa" "AAA" t <regexp> matches? ] unit-test
+[ f ] [ "aax" "AAA" t <regexp> matches? ] unit-test
+[ t ] [ "aaa" "A*" t <regexp> matches? ] unit-test
+[ f ] [ "aaba" "A*" t <regexp> matches? ] unit-test
+[ t ] [ "b" "[AB]" t <regexp> matches? ] unit-test
+[ f ] [ "c" "[AB]" t <regexp> matches? ] unit-test
+[ t ] [ "c" "[A-Z]" t <regexp> matches? ] unit-test
+[ f ] [ "3" "[A-Z]" t <regexp> matches? ] unit-test
+
+[ ] [ 
+    "(0[lL]?|[1-9]\\d{0,9}(\\d{0,9}[lL])?|0[xX]\\p{XDigit}{1,8}(\\p{XDigit}{0,8}[lL])?|0[0-7]{1,11}([0-7]{0,11}[lL])?|([0-9]+\\.[0-9]*|\\.[0-9]+)([eE][+-]?[0-9]+)?[fFdD]?|[0-9]+([eE][+-]?[0-9]+[fFdD]?|([eE][+-]?[0-9]+)?[fFdD]))"
+    f <regexp> drop
+] unit-test

extra/regexp/regexp.factor

@@ -1,15 +1,36 @@
 USING: arrays combinators kernel lazy-lists math math.parser
 namespaces parser parser-combinators parser-combinators.simple
-promises quotations sequences combinators.lib strings macros
+promises quotations sequences combinators.lib strings
 assocs prettyprint.backend ;
 USE: io
 IN: regexp
 
+<PRIVATE
+
+SYMBOL: ignore-case?
+
+: char=-quot ( ch -- quot )
+    ignore-case? get
+    [ ch>upper [ swap ch>upper = ] ] [ [ = ] ] if
+    curry ;
+
+: char-between?-quot ( ch1 ch2 -- quot )
+    ignore-case? get
+    [ [ ch>upper ] 2apply [ >r >r ch>upper r> r> between? ] ]
+    [ [ between? ] ]
+    if 2curry ;
+
 : or-predicates ( quots -- quot )
     [ \ dup add* ] map [ [ t ] ] f short-circuit \ nip add ;
 
-MACRO: fast-member? ( str -- quot )
+: <@literal [ nip ] curry <@ ;
-    [ dup ] H{ } map>assoc [ key? ] curry ;
+
+: <@delay [ curry ] curry <@ ;
+
+PRIVATE>
+
+: ascii? ( n -- ? ) 
+    0 HEX: 7f between? ;
 
 : octal-digit? ( n -- ? )
     CHAR: 0 CHAR: 7 between? ;
@@ -19,30 +40,32 @@ MACRO: fast-member? ( str -- quot )
 
 : hex-digit? ( n -- ? )
     dup decimal-digit?
-    swap CHAR: a CHAR: f between? or ;
+    over CHAR: a CHAR: f between? or
+    swap CHAR: A CHAR: F between? or ;
 
 : control-char? ( n -- ? )
     dup 0 HEX: 1f between?
     swap HEX: 7f = or ;
 
 : punct? ( n -- ? )
-    "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" fast-member? ;
+    "!\"#$%&'()*+,-./:;<=>?@[\\]^_`{|}~" member? ;
 
 : c-identifier-char? ( ch -- ? )
     dup alpha? swap CHAR: _ = or ;
 
 : java-blank? ( n -- ? )
     {
+        CHAR: \s
         CHAR: \t CHAR: \n CHAR: \r
         HEX: c HEX: 7 HEX: 1b
-    } fast-member? ;
+    } member? ;
 
 : java-printable? ( n -- ? )
     dup alpha? swap punct? or ;
 
 : 'ordinary-char' ( -- parser )
-    [ "\\^*+?|(){}[$" fast-member? not ] satisfy
+    [ "\\^*+?|(){}[$" member? not ] satisfy
-    [ [ = ] curry ] <@ ;
+    [ char=-quot ] <@ ;
 
 : 'octal-digit' ( -- parser ) [ octal-digit? ] satisfy ;
 
@@ -58,7 +81,7 @@ MACRO: fast-member? ( str -- quot )
     [ hex> ] <@ ;
 
 : satisfy-tokens ( assoc -- parser )
-    [ >r token r> [ nip ] curry <@ ] { } assoc>map <or-parser> ;
+    [ >r token r> <@literal ] { } assoc>map <or-parser> ;
 
 : 'simple-escape-char' ( -- parser )
     {
@@ -69,7 +92,7 @@ MACRO: fast-member? ( str -- quot )
         { "f"  HEX: c   }
         { "a"  HEX: 7   }
         { "e"  HEX: 1b  }
-    } [ [ = ] curry ] assoc-map satisfy-tokens ;
+    } [ char=-quot ] assoc-map satisfy-tokens ;
 
 : 'predefined-char-class' ( -- parser )
     {
@@ -85,7 +108,7 @@ MACRO: fast-member? ( str -- quot )
     {
         { "Lower" [ letter? ] }
         { "Upper" [ LETTER? ] }
-        { "ASCII" [ 0 HEX: 7f between? ] }
+        { "ASCII" [ ascii? ] }
         { "Alpha" [ Letter? ] }
         { "Digit" [ digit? ] }
         { "Alnum" [ alpha? ] }
@@ -103,7 +126,7 @@ MACRO: fast-member? ( str -- quot )
     'hex' <|>
     "c" token [ LETTER? ] satisfy &> <|>
     any-char-parser <|>
-    [ [ = ] curry ] <@ ;
+    [ char=-quot ] <@ ;
 
 : 'escape' ( -- parser )
     "\\" token
@@ -113,7 +136,7 @@ MACRO: fast-member? ( str -- quot )
     'simple-escape' <|> &> ;
 
 : 'any-char'
-    "." token [ drop [ drop t ] ] <@ ;
+    "." token [ drop t ] <@literal ;
 
 : 'char'
     'any-char' 'escape' 'ordinary-char' <|> <|> [ satisfy ] <@ ;
@@ -124,21 +147,24 @@ TUPLE: group-result str ;
 
 C: <group-result> group-result
 
-: 'grouping'
+: 'non-capturing-group' ( -- parser )
+    'regexp' "(?:" ")" surrounded-by ;
+
+: 'group' ( -- parser )
     'regexp' [ [ <group-result> ] <@ ] <@
     "(" ")" surrounded-by ;
 
 : 'range' ( -- parser )
     any-char-parser "-" token <& any-char-parser <&>
-    [ first2 [ between? ] 2curry ] <@ ;
+    [ first2 char-between?-quot ] <@ ;
 
 : 'character-class-term' ( -- parser )
     'range'
     'escape' <|>
-    [ "\\]" member? not ] satisfy [ [ = ] curry ] <@ <|> ;
+    [ "\\]" member? not ] satisfy [ char=-quot ] <@ <|> ;
 
 : 'positive-character-class' ( -- parser )
-    "]" token [ drop [ CHAR: ] = ] ] <@ 'character-class-term' <*> <&:>
+    "]" token [ CHAR: ] = ] <@literal 'character-class-term' <*> <&:>
     'character-class-term' <+> <|>
     [ or-predicates ] <@ ;
 
@@ -151,66 +177,101 @@ C: <group-result> group-result
     "[" "]" surrounded-by [ satisfy ] <@ ;
 
 : 'escaped-seq' ( -- parser )
-    any-char-parser <*> [ token ] <@ "\\Q" "\\E" surrounded-by ;
+    any-char-parser <*>
+    [ ignore-case? get <token-parser> ] <@
+    "\\Q" "\\E" surrounded-by ;
 
 : 'simple' ( -- parser )
     'escaped-seq'
-    'grouping' <|>
+    'non-capturing-group' <|>
+    'group' <|>
     'char' <|>
     'character-class' <|> ;
 
+: 'exactly-n' ( -- parser )
+    'integer' [ exactly-n ] <@delay ;
+
+: 'at-least-n' ( -- parser )
+    'integer' "," token <& [ at-least-n ] <@delay ;
+
+: 'at-most-n' ( -- parser )
+    "," token 'integer' &> [ at-most-n ] <@delay ;
+
+: 'from-m-to-n' ( -- parser )
+    'integer' "," token <& 'integer' <&> [ first2 from-m-to-n ] <@delay ;
+
 : 'greedy-interval' ( -- parser )
-    'simple' 'integer' "{" "}" surrounded-by <&> [ first2 exactly-n ] <@
+    'exactly-n' 'at-least-n' <|> 'at-most-n' <|> 'from-m-to-n' <|> ;
-    'simple' 'integer' "{" ",}" surrounded-by <&> [ first2 at-least-n ] <@ <|>
-    'simple' 'integer' "{," "}" surrounded-by <&> [ first2 at-most-n ] <@ <|>
-    'simple' 'integer' "," token <& 'integer' <&> "{" "}" surrounded-by <&> [ first2 first2 from-m-to-n ] <@ <|> ;
 
 : 'interval' ( -- parser )
     'greedy-interval'
     'greedy-interval' "?" token <& [ "reluctant {}" print ] <@ <|>
-    'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|> ;
+    'greedy-interval' "+" token <& [ "possessive {}" print ] <@ <|>
-
+    "{" "}" surrounded-by ;
-: 'greedy-repetition' ( -- parser )
-    'simple' "*" token <& [ <*> ] <@
-    'simple' "+" token <& [ <+> ] <@ <|>
-    'simple' "?" token <& [ <?> ] <@ <|> ;
 
 : 'repetition' ( -- parser )
-    'greedy-repetition'
+    ! Posessive
-    'greedy-repetition' "?" token <& [ "reluctant" print ] <@ <|>
+    "*+" token [ <!*> ] <@literal
-    'greedy-repetition' "+" token <& [ "possessive" print ] <@ <|> ;
+    "++" token [ <!+> ] <@literal <|>
+    "?+" token [ <!?> ] <@literal <|>
+    ! Reluctant
+    "*?" token [ <(*)> ] <@literal <|>
+    "+?" token [ <(+)> ] <@literal <|>
+    "??" token [ <(?)> ] <@literal <|>
+    ! Greedy
+    "*" token [ <*> ] <@literal <|>
+    "+" token [ <+> ] <@literal <|>
+    "?" token [ <?> ] <@literal <|> ;
+
+: 'dummy' ( -- parser )
+    epsilon [ ] <@literal ;
 
 : 'term' ( -- parser )
-    'simple' 'repetition' 'interval' <|> <|>
+    'simple'
-    <+> [ <and-parser> ] <@ ;
+    'repetition' 'interval' 'dummy' <|> <|> <&> [ first2 call ] <@
+    <!+> [ <and-parser> ] <@ ;
 
 LAZY: 'regexp' ( -- parser )
-    'term' "|" token nonempty-list-of [ <or-parser> ] <@
+    'term' "|" token nonempty-list-of [ <or-parser> ] <@ ;
-    "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@
+!    "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@
-        &> [ "caret" print ] <@ <|>
+!        &> [ "caret" print ] <@ <|>
-    'term' "|" token nonempty-list-of [ <or-parser> ] <@
+!    'term' "|" token nonempty-list-of [ <or-parser> ] <@
-        "$" token <& [ "dollar" print ] <@ <|>
+!        "$" token <& [ "dollar" print ] <@ <|>
-    "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &>
+!    "^" token 'term' "|" token nonempty-list-of [ <or-parser> ] <@ &>
-        "$" token [ "caret dollar" print ] <@ <& <|> ;
+!        "$" token [ "caret dollar" print ] <@ <& <|> ;
 
-TUPLE: regexp source parser ;
+TUPLE: regexp source parser ignore-case? ;
 
-: <regexp> dup 'regexp' just parse-1 regexp construct-boa ;
+: <regexp> ( string ignore-case? -- regexp )
+    [
+        ignore-case? [
+            dup 'regexp' just parse-1
+        ] with-variable
+    ] keep regexp construct-boa ;
 
-GENERIC: >regexp ( obj -- parser )
+: do-ignore-case ( string regexp -- string regexp )
-
+    dup regexp-ignore-case? [ >r >upper r> ] when ;
-M: string >regexp <regexp> ;
-
-M: object >regexp ;
 
 : matches? ( string regexp -- ? )
-    >regexp regexp-parser just parse nil? not ;
+    do-ignore-case regexp-parser just parse nil? not ;
+
+: match-head ( string regexp -- end )
+    do-ignore-case regexp-parser parse dup nil?
+    [ drop f ] [ car parse-result-unparsed slice-from ] if ;
 
 ! Literal syntax for regexps
+: parse-options ( string -- ? )
+    #! Lame
+    {
+        { "" [ f ] }
+        { "i" [ t ] }
+    } case ;
+
 : parse-regexp ( accum end -- accum )
     lexer get dup skip-blank [
         [ index* dup 1+ swap ] 2keep swapd subseq swap
-    ] change-column  <regexp> parsed ;
+    ] change-column
+    lexer get (parse-token) parse-options <regexp> parsed ;
 
 : R! CHAR: ! parse-regexp ; parsing
 : R" CHAR: " parse-regexp ; parsing
@@ -240,4 +301,9 @@ M: object >regexp ;
     } swap [ subseq? not nip ] curry assoc-find drop ;
 
 M: regexp pprint*
-    dup regexp-source dup find-regexp-syntax pprint-string ;
+    [
+        dup regexp-source
+        dup find-regexp-syntax swap % swap % %
+        dup regexp-ignore-case? [ "i" % ] when
+    ] "" make
+    swap present-text ;

extra/rss/rss.factor

@@ -9,6 +9,9 @@ USING: xml.utilities kernel assocs
 : ?children>string ( tag/f -- string/f )
     [ children>string ] [ f ] if* ;
 
+: any-tag-named ( tag names -- tag-inside )
+    f -rot [ tag-named nip dup ] curry* find 2drop ;
+
 TUPLE: feed title link entries ;
 
 C: <feed> feed
@@ -17,50 +20,51 @@ TUPLE: entry title link description pub-date ;
 
 C: <entry> entry
 
+: rss1.0-entry ( tag -- entry )
+    [ "title" tag-named children>string ] keep   
+    [ "link" tag-named children>string ] keep
+    [ "description" tag-named children>string ] keep
+    f "date" "http://purl.org/dc/elements/1.1/" <name>
+    tag-named ?children>string
+    <entry> ;
+
 : rss1.0 ( xml -- feed )
     [
         "channel" tag-named
         [ "title" tag-named children>string ] keep
         "link" tag-named children>string
     ] keep
-    "item" tags-named [
+    "item" tags-named [ rss1.0-entry ] map <feed> ;
+
+: rss2.0-entry ( tag -- entry )
     [ "title" tag-named children>string ] keep
-        [ "link" tag-named children>string ] keep
+    [ "link" tag-named ] keep
+    [ "guid" tag-named dupd ? children>string ] keep
     [ "description" tag-named children>string ] keep
-        f "date" "http://purl.org/dc/elements/1.1/" <name>
+    "pubDate" tag-named children>string <entry> ;
-        tag-named ?children>string
-        <entry>
-    ] map <feed> ;
 
 : rss2.0 ( xml -- feed )
     "channel" tag-named 
     [ "title" tag-named children>string ] keep
     [ "link" tag-named children>string ] keep
-    "item" tags-named [
+    "item" tags-named [ rss2.0-entry ] map <feed> ;
+
+: atom1.0-entry ( tag -- entry )
     [ "title" tag-named children>string ] keep
-        [ "link" tag-named ] keep
+    [ "link" tag-named "href" swap at ] keep
-        [ "guid" tag-named dupd ? children>string ] keep
+    [
-        [ "description" tag-named children>string ] keep
+        { "content" "summary" } any-tag-named
-        "pubDate" tag-named children>string <entry>
+        dup tag-children [ string? not ] contains?
-    ] map <feed> ;
+        [ tag-children [ write-chunk ] string-out ]
+        [ children>string ] if
+    ] keep
+    { "published" "updated" "issued" "modified" } any-tag-named
+    children>string <entry> ;
 
 : atom1.0 ( xml -- feed )
     [ "title" tag-named children>string ] keep
     [ "link" tag-named "href" swap at ] keep
-    "entry" tags-named [
+    "entry" tags-named [ atom1.0-entry ] map <feed> ;
-        [ "title" tag-named children>string ] keep
-        [ "link" tag-named "href" swap at ] keep
-        [
-            dup "content" tag-named
-            [ nip ] [ "summary" tag-named ] if*
-            dup tag-children [ tag? ] contains?
-            [ tag-children [ write-chunk ] string-out ]
-            [ children>string ] if
-        ] keep
-        dup "published" tag-named
-        [ nip ] [ "updated" tag-named ] if*
-        children>string <entry>
-    ] map <feed> ;
 
 : xml>feed ( xml -- feed )
     dup name-tag {
@@ -74,7 +78,7 @@ C: <entry> entry
 
 : download-feed ( url -- feed )
     #! Retrieve an news syndication file, return as a feed tuple.
-    http-get rot 200 = [
+    http-get-stream rot 200 = [
         nip read-feed
     ] [
         2drop "Error retrieving newsfeed file" throw
@@ -84,12 +88,15 @@ C: <entry> entry
 : simple-tag, ( content name -- )
     [ , ] tag, ;
 
+: simple-tag*, ( content name attrs -- )
+    [ , ] tag*, ;
+
 : entry, ( entry -- )
     "entry" [
-        dup entry-title "title" simple-tag,
+        dup entry-title "title" { { "type" "html" } } simple-tag*,
         "link" over entry-link "href" associate contained*,
         dup entry-pub-date "published" simple-tag,
-        entry-description "content" simple-tag,
+        entry-description [ "content" { { "type" "html" } } simple-tag*, ] when*
     ] tag, ;
 
 : feed>xml ( feed -- xml )
@@ -99,5 +106,5 @@ C: <entry> entry
         feed-entries [ entry, ] each
     ] make-xml* ;
 
-: write-feed ( feed -- xml )
+: write-feed ( feed -- )
     feed>xml write-xml ;

extra/sequences/lib/lib-tests.factor

@@ -1,5 +1,5 @@
 USING: arrays kernel sequences sequences.lib math
-math.functions tools.test ;
+math.functions tools.test strings ;
 
 [ 4 ] [ { 1 2 } [ sq ] [ * ] map-reduce ] unit-test
 [ 36 ] [ { 2 3 } [ sq ] [ * ] map-reduce ] unit-test
@@ -42,3 +42,7 @@ math.functions tools.test ;
 
 [ { 1 9 25 } ] [ { 1 3 5 6 } [ sq ] [ even? ] map-until ] unit-test
 [ { 2 4 } ] [ { 2 4 1 3 } [ even? ] take-while ] unit-test
+
+[ { { 0 0 } { 1 0 } { 0 1 } { 1 1 } } ] [ 2 2 exact-strings ] unit-test
+[ t ] [ "ab" 4 strings [ >string ] map "abab" swap member? ] unit-test
+[ { { } { 1 } { 2 } { 1 2 } } ] [ { 1 2 } power-set ] unit-test

extra/sequences/lib/lib.factor

@@ -1,5 +1,5 @@
-USING: combinators.lib kernel sequences math namespaces
+USING: combinators.lib kernel sequences math namespaces assocs 
-random sequences.private shuffle ;
+random sequences.private shuffle math.functions mirrors ;
 IN: sequences.lib
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -74,3 +74,33 @@ IN: sequences.lib
     [ not ] compose
     [ find drop [ head-slice ] when* ] curry
     [ dup ] swap compose keep like ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+<PRIVATE
+: translate-string ( n alphabet out-len -- seq )
+    [ drop /mod ] curry* map nip  ;
+
+: map-alphabet ( alphabet seq[seq] -- seq[seq] )
+    [ [ swap nth ] curry* map ] curry* map ;
+
+: exact-number-strings ( n out-len -- seqs )
+    [ ^ ] 2keep [ translate-string ] 2curry map ;
+
+: number-strings ( n max-length -- seqs )
+    1+ [ exact-number-strings ] curry* map concat ;
+PRIVATE>
+
+: exact-strings ( alphabet length -- seqs )
+    >r dup length r> exact-number-strings map-alphabet ;
+
+: strings ( alphabet length -- seqs )
+    >r dup length r> number-strings map-alphabet ;
+
+: nths ( nths seq -- subseq )
+    ! nths is a sequence of ones and zeroes
+    >r [ length ] keep [ nth 1 = ] curry subset r>
+    [ nth ] curry { } map-as ;
+
+: power-set ( seq -- subsets )
+    2 over length exact-number-strings swap [ nths ] curry map ;

extra/shuffle/shuffle.factor

@@ -29,4 +29,6 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
 
 : 4dup ( a b c d -- a b c d a b c d ) 4 ndup ; inline
 
+: 4drop ( a b c d -- ) 3drop drop ; inline
+
 : tuckd ( x y z -- z x y z ) 2 ntuck ; inline

extra/shufflers/shufflers.factor

@@ -1,25 +1,14 @@
 USING: kernel sequences words math math.functions arrays 
 shuffle quotations parser math.parser strings namespaces 
-splitting effects ;
+splitting effects sequences.lib ;
 IN: shufflers
 
 : shuffle>string ( names shuffle -- string )
     swap [ [ nth ] curry map ] curry map
     first2 "-" swap 3append >string ;
 
-: translate ( n alphabet out-len -- seq )
-    [ drop /mod ] curry* map nip  ;
-
-: (combinations) ( alphabet out-len -- seq[seq] )
-    [ ^ ] 2keep [ translate ] 2curry map ;
-
-: combinations ( n max-out -- seq[seq] )
-    ! This returns a seq of length O(n^m)
-    ! where and m is max-out
-    1+ [ (combinations) ] curry* map concat ;
-
 : make-shuffles ( max-out max-in -- shuffles )
-    [ 1+ dup rot combinations [ 2array ] curry* map ]
+    [ 1+ dup rot strings [ 2array ] curry* map ]
     curry* map concat ;
 
 : shuffle>quot ( shuffle -- quot )

extra/ui/tools/tools.factor

@@ -67,11 +67,11 @@ M: workspace model-changed
 : com-profiler profiler-gadget select-tool ;
 
 workspace "tool-switching" f {
-    { T{ key-down f { C+ } "1" } com-listener }
+    { T{ key-down f { A+ } "1" } com-listener }
-    { T{ key-down f { C+ } "2" } com-browser }
+    { T{ key-down f { A+ } "2" } com-browser }
-    { T{ key-down f { C+ } "3" } com-inspector }
+    { T{ key-down f { A+ } "3" } com-inspector }
-    { T{ key-down f { C+ } "4" } com-walker }
+    { T{ key-down f { A+ } "4" } com-walker }
-    { T{ key-down f { C+ } "5" } com-profiler }
+    { T{ key-down f { A+ } "5" } com-profiler }
 } define-command-map
 
 \ workspace-window

extra/ui/windows/windows.factor

@@ -4,8 +4,8 @@ USING: alien alien.c-types arrays assocs ui ui.gadgets
 ui.backend ui.clipboards ui.gadgets.worlds ui.gestures io kernel
 math math.vectors namespaces prettyprint sequences strings
 vectors words windows.kernel32 windows.gdi32 windows.user32
-windows.opengl32 windows.messages windows.types windows.nt
+windows.opengl32 windows.messages windows.types
-windows threads timers libc combinators continuations
+windows.nt windows threads timers libc combinators continuations
 command-line shuffle opengl ui.render ;
 IN: ui.windows
 
@@ -210,6 +210,9 @@ SYMBOL: hWnd
     hWnd get window-focus send-gesture
     drop ;
 
+: handle-wm-syscommand ( hWnd uMsg wParam lParam -- n )
+    dup alpha? [ 4drop 0 ] [ DefWindowProc ] if ;
+
 : cleanup-window ( handle -- )
     dup win-title [ free ] when*
     dup win-hRC wglDeleteContext win32-error=0/f
@@ -257,14 +260,12 @@ M: windows-ui-backend (close-window)
 : prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
     nip >r mouse-event>gesture r> >lo-hi rot window ;
 
-: mouse-captured? ( -- ? )
-    mouse-captured get ;
-
 : set-capture ( hwnd -- )
     mouse-captured get [
         drop
     ] [
-        [ SetCapture drop ] keep mouse-captured set
+        [ SetCapture drop ] keep
+        mouse-captured set
     ] if ;
 
 : release-capture ( -- )
@@ -276,7 +277,7 @@ M: windows-ui-backend (close-window)
     prepare-mouse send-button-down ;
 
 : handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
-    mouse-captured? [ release-capture ] when
+    mouse-captured get [ release-capture ] when
     prepare-mouse send-button-up ;
 
 : make-TRACKMOUSEEVENT ( hWnd -- alien )
@@ -297,17 +298,17 @@ M: windows-ui-backend (close-window)
 
 : handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
     #! message sent if windows needs application to stop dragging
-    3drop drop release-capture ;
+    4drop release-capture ;
 
 : handle-wm-mouseleave ( hWnd uMsg wParam lParam -- )
     #! message sent if mouse leaves main application 
-    3drop drop forget-rollover ;
+    4drop forget-rollover ;
 
 ! return 0 if you handle the message, else just let DefWindowProc return its val
 : ui-wndproc ( -- object )
     "uint" { "void*" "uint" "long" "long" } "stdcall" [
         [
-        pick
+        pick ! global [ dup windows-message-name . ] bind
             {
                 { [ dup WM_CLOSE = ]    [ drop handle-wm-close 0 ] }
                 { [ dup WM_PAINT = ]
@@ -322,6 +323,7 @@ M: windows-ui-backend (close-window)
                 { [ dup WM_KEYUP = over WM_SYSKEYUP = or ]
                     [ drop 4dup handle-wm-keyup DefWindowProc ] }
 
+                { [ dup WM_SYSCOMMAND = ] [ drop handle-wm-syscommand ] }
                 { [ dup WM_SETFOCUS = ] [ drop handle-wm-set-focus 0 ] }
                 { [ dup WM_KILLFOCUS = ] [ drop handle-wm-kill-focus 0 ] }
 
@@ -434,7 +436,7 @@ M: windows-ui-backend flush-gl-context ( handle -- )
 ! Move window to front
 M: windows-ui-backend raise-window ( world -- )
     world-handle [
-        win-hWnd SetFocus drop release-capture
+        win-hWnd SetFocus drop
     ] when* ;
 
 M: windows-ui-backend set-title ( string world -- )

extra/webapps/article-manager/article-manager.factor

@@ -4,12 +4,17 @@
 USING: kernel furnace sqlite.tuple-db webapps.article-manager.database 
        sequences namespaces math arrays assocs quotations io.files
        http.server http.basic-authentication http.server.responders 
-       webapps.file ;
+       webapps.file html html.elements io ;
 IN: webapps.article-manager
 
 : current-site ( -- site )
   host get-site* ;
 
+: render-titled-page* ( model body-template head-template title -- )
+  [ 
+      [ render-component ] swap [ <title> write </title> f rot render-component ] curry html-document
+  ] serve-html ;
+
 TUPLE: template-args arg1 ;
   
 C: <template-args> template-args

extra/webapps/article-manager/furnace/article.furnace

@@ -1,12 +1,12 @@
 <% USING: kernel io http.server namespaces sequences math html.elements random furnace webapps.article-manager webapps.article-manager.database html.elements ; %>
     <div id="banner"><h1><% "arg1" get second article-title write %></h1></div>
-    <% f "navigation" render-template %>
+    <% "navigation" render-template %>
     <div id="article">
     <% 100 random 25 > [ "arg1" get first 100 random 50 > [ site-ad2 ] [ site-ad3 ] if write-html ] when %>
     <% "arg1" get second article-body write-html %>
 
 	<h1>Tags</h1>
-        <% "arg1" get second tags-for-article <template-args> "tags" render-template %>
+        <% "arg1" get second tags-for-article <template-args> "tags" render-component %>
 </div>
 <p class="footer"></p>
 <p id="copyright"><% "arg1" get first site-footer write %></p>

extra/webapps/article-manager/furnace/index.furnace

@@ -6,7 +6,7 @@
 </head>
     <body>
 	<div id="banner"><h1><% "title" get write %></h1></div>
-    <% f "navigation" render-template %>
+    <% "navigation" render-template %>
 <div id="article">
   <% "intro" get write-html %>
     <h1>Recent Articles</h1>
@@ -23,7 +23,7 @@
 	    but in the meantime, Google is likely to provide
 	    reasonable results.
 	</p>
-        <% host all-tags <template-args> "tags" render-template %>
+        <% host all-tags <template-args> "tags" render-component %>
 </div>
 <p class="footer"></p>
 <p id="copyright"><% "footer" get write %></p>

extra/webapps/article-manager/furnace/navigation.furnace

@@ -5,5 +5,5 @@
     </ul>
     <% current-site site-ad1 write-html %>
     <h1>Tags</h1>
-    <% host all-tags <template-args> "tags" render-template %>
+    <% host all-tags <template-args> "tags" render-component %>
     </div>

extra/webapps/article-manager/furnace/tag.furnace

@@ -1,7 +1,7 @@
 <% USING: kernel io http.server namespaces sequences math html furnace webapps.article-manager.database webapps.article-manager html.elements ; %>
 
 	<div id="banner"><h1><% "arg1" get second tag-title write %></h1></div>
-    <% f "navigation" render-template %>
+    <% "navigation" render-component %>
 	<div id="article">
 	<h1><% "arg1" get second tag-title write %></h1>
         <% "arg1" get second tag-description write-html %>

extra/webapps/file/file.factor

@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2006 Slava Pestov.
+! Copyright (C) 2004, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: calendar html io io.files kernel math math.parser
 http.server.responders http.server.templating namespaces parser
@@ -31,15 +31,23 @@ IN: webapps.file
     "304 Not Modified" response
     now timestamp>http-string "Date" associate print-header ;  
 
+! You can override how files are served in a custom responder
+SYMBOL: serve-file-hook
+
+[
+    file-response
+    stdio get stream-copy
+] serve-file-hook set-global
+
 : serve-static ( filename mime-type -- )
     over last-modified-matches? [
         2drop not-modified-response
     ] [
-        dupd file-response
         "method" get "head" = [
-            drop
+            file-response
         ] [
-            <file-reader> stdio get stream-copy
+            >r dup <file-reader> swap r>
+            serve-file-hook get call
         ] if 
     ] if ;
 
@@ -53,9 +61,13 @@ SYMBOL: page
 : include-page ( filename -- )
     "doc-root" get swap path+ run-page ;
 
+: serve-fhtml ( filename -- )
+    serving-html
+    "method" get "head" = [ drop ] [ run-page ] if ;
+
 : serve-file ( filename -- )
     dup mime-type dup "application/x-factor-server-page" =
-    [ drop serving-html run-page ] [ serve-static ] if ;
+    [ drop serve-fhtml ] [ serve-static ] if ;
 
 : file. ( name dirp -- )
     [ "/" append ] when

extra/webapps/fjsc/fjsc.factor

@@ -4,7 +4,7 @@
 USING: kernel furnace fjsc  parser-combinators namespaces
        lazy-lists io io.files furnace.validator sequences
        http.client http.server http.server.responders
-       webapps.file ;
+       webapps.file html ;
 IN: webapps.fjsc
 
 : compile ( code -- )
@@ -31,6 +31,11 @@ IN: webapps.fjsc
   { "url" v-required }
 } define-action
 
+: render-page* ( model body-template head-template -- )
+  [
+      [ render-component ] [ f rot render-component ] html-document 
+  ] serve-html ;
+
 : repl ( -- )
   #! The main 'repl' page.
   f "repl" "head" render-page* ;

extra/webapps/help/help.factor

@@ -82,4 +82,4 @@ PREDICATE: pathname resource-pathname
 M: resource-pathname browser-link-href
     pathname-string
     "resource:" ?head drop
-    "/responder/resources/" swap append ;
+    "/responder/source/" swap append ;

extra/webapps/pastebin/annotate-paste.furnace

@@ -1,4 +1,4 @@
-<% USING: io math math.parser namespaces ; %>
+<% USING: io math math.parser namespaces furnace ; %>
 
 <h1>Annotate</h1>
 
@@ -9,17 +9,22 @@
 <input type="hidden" name="n" value="<% "n" get number>string write %>" />
 
 <tr>
-<th>Your name:</th>
+<th align="right">Summary:</th>
-<td><input type="TEXT" name="author" value="" /></td>
-</tr>
-
-<tr>
-<th>Summary:</th>
 <td><input type="TEXT" name="summary" value="" /></td>
 </tr>
 
 <tr>
-<th valign="top">Contents:</th>
+<th align="right">Your name:</th>
+<td><input type="TEXT" name="author" value="" /></td>
+</tr>
+
+<tr>
+<th align="right">File type:</th>
+<td><% "modes" render-template %></td>
+</tr>
+
+<tr>
+<th align="right" valign="top">Content:</th>
 <td><textarea rows="24" cols="60" name="contents"></textarea></td>
 </tr>
 </table>

extra/webapps/pastebin/annotation.furnace

@@ -1,11 +1,11 @@
-<% USING: namespaces io ; %>
+<% USING: namespaces io furnace calendar ; %>
 
 <h2>Annotation: <% "summary" get write %></h2>
 
 <table>
 <tr><th>Annotation by:</th><td><% "author" get write %></td></tr>
 <tr><th>Channel:</th><td><% "channel" get write %></td></tr>
-<tr><th>Created:</th><td><% "date" get write %></td></tr>
+<tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr>
 </table>
 
-<pre><% "contents" get write %></pre>
+<% "syntax" render-template %>

extra/webapps/pastebin/footer.furnace

@@ -0,0 +1,3 @@
+</body>
+
+</html>

extra/webapps/pastebin/header.furnace

@@ -0,0 +1,23 @@
+<% USING: namespaces io furnace sequences xmode.code2html webapps.pastebin ; %>
+
+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
+	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+<head>
+	<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
+
+	<title><% "title" get write %></title>
+	<link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+	<% default-stylesheet %>
+    <link rel="alternate" type="application/atom+xml" title="Pastebin - Atom" href="feed.xml" />
+</head>
+
+<body id="index">
+
+    <div class="navbar">
+        <% [ paste-list ] "Paste list" render-link %> |
+        <% [ new-paste ] "New paste" render-link %> |
+        <% [ feed.xml ] "Syndicate" render-link %>
+    </div>
+    <h1 class="pastebin-title"><% "title" get write %></h1>

extra/webapps/pastebin/modes.furnace

@@ -0,0 +1,7 @@
+<% USING: xmode.catalog sequences kernel html.elements assocs io sorting ; %>
+
+<select name="mode">
+    <% modes keys natural-sort [
+        <option dup "factor" = [ "true" =selected ] when option> write </option>
+    ] each %>
+</select>

extra/webapps/pastebin/new-paste.furnace

@@ -1,27 +1,41 @@
+<% USING: furnace namespaces ; %>
+
+<%
+    "New paste" "title" set
+    "header" render-template
+%>
+
 <form method="POST" action="/responder/pastebin/submit-paste">
 
 <table>
 
 <tr>
-<th>Your name:</th>
+<th align="right">Summary:</th>
-<td><input type="TEXT" name="author" value="" /></td>
-</tr>
-
-<tr>
-<th>Summary:</th>
 <td><input type="TEXT" name="summary" value="" /></td>
 </tr>
 
 <tr>
-<th>Channel:</th>
+<th align="right">Your name:</th>
+<td><input type="TEXT" name="author" value="" /></td>
+</tr>
+
+<tr>
+<th align="right">File type:</th>
+<td><% "modes" render-template %></td>
+</tr>
+
+<tr>
+<th align="right">Channel:</th>
 <td><input type="TEXT" name="channel" value="#concatenative" /></td>
 </tr>
 
 <tr>
-<th valign="top">Contents:</th>
+<th align="right" valign="top">Content:</th>
 <td><textarea rows="24" cols="60" name="contents"></textarea></td>
 </tr>
 </table>
 
 <input type="SUBMIT" value="Submit paste" />
 </form>
+
+<% "footer" render-template %>

extra/webapps/pastebin/paste-list.furnace

@@ -1,7 +1,31 @@
 <% USING: namespaces furnace sequences ; %>
 
-<table  width="100%">
+<%
-<% "new-paste-quot" get "New paste" render-link %>
+    "Pastebin" "title" set
-<tr align="left"><th>&nbsp;</th><th>Summary:</th><th>Paste by:</th><th>Link</th><th>Date</th></tr>
+    "header" render-template
-<% "pastes" get <reversed> [ "paste-summary" render-template ] each %></table>
+%>
 
+<table width="100%" cellspacing="10">
+    <tr>
+        <td valign="top">
+            <table width="100%">
+                <tr align="left" class="pastebin-headings">
+                    <th width="50%">Summary:</th>
+                    <th width="100">Paste by:</th>
+                    <th width="200">Date:</th>
+                </tr>
+                <% "pastes" get <reversed> [ "paste-summary" render-component ] each %>
+            </table>
+        </td>
+        <td valign="top" width="25%" class="infobox">
+            <p>This pastebin is written in <a href="http://factorcode.org/">Factor</a>. It is inspired by <a href="http://paste.lisp.org">lisppaste</a>.
+            </p>
+            <p>It can be used for collaborative development over IRC. You can post code for review, and annotate other people's code. Syntax highlighting for over a hundred file types is supported.
+            </p>
+            <p>
+            <% "webapps.pastebin" browse-webapp-source %></p>
+        </td>
+    </tr>
+</table>
+
+<% "footer" render-template %>

extra/webapps/pastebin/paste-summary.furnace

@@ -1,9 +1,16 @@
-<% USING: continuations namespaces io kernel math math.parser furnace ; %>
+<% USING: continuations namespaces io kernel math math.parser
+furnace webapps.pastebin calendar sequences ; %>
 
 <tr>
-<td><% "n" get number>string write %></td>
+    <td>
-<td><% "summary" get write %></td>
+        <a href="<% model get paste-link write %>">
-<td><% "author" get write %></td>
+        <%
-<td><% "n" get number>string "show-paste-quot" get curry "Show" render-link %></td>
+            "summary" get
-<td><% "date" get print %></td>
+            dup empty? [ drop "- no title -" ] when
+            write
+        %>
+        </a>
+    </td>
+    <td><% "author" get write %></td>
+    <td><% "date" get timestamp>string print %></td>
 </tr>

extra/webapps/pastebin/pastebin.factor

@@ -1,5 +1,6 @@
-USING: calendar furnace furnace.validator io.files kernel namespaces
+USING: calendar furnace furnace.validator io.files kernel
-sequences store ;
+namespaces sequences store http.server.responders html
+math.parser rss xml.writer ;
 IN: webapps.pastebin
 
 TUPLE: pastebin pastes ;
@@ -7,23 +8,17 @@ TUPLE: pastebin pastes ;
 : <pastebin> ( -- pastebin )
     V{ } clone pastebin construct-boa ;
 
-TUPLE: paste n summary article author channel contents date annotations ;
+TUPLE: paste
+summary author channel mode contents date
+annotations n ;
 
-: <paste> ( summary author channel contents -- paste )
+: <paste> ( summary author channel mode contents -- paste )
-    V{ } clone
+    f V{ } clone f paste construct-boa ;
-    {
-        set-paste-summary
-        set-paste-author
-        set-paste-channel
-        set-paste-contents
-        set-paste-annotations
-    } paste construct ;
 
-TUPLE: annotation summary author contents ;
+TUPLE: annotation summary author mode contents ;
 
 C: <annotation> annotation
 
-
 SYMBOL: store
 
 "pastebin.store" resource-path load-store store set-global
@@ -34,49 +29,70 @@ SYMBOL: store
     pastebin get pastebin-pastes nth ;
 
 : show-paste ( n -- )
-    get-paste "show-paste" "Paste" render-page ;
+    serving-html
+    get-paste
+    [ "show-paste" render-component ] with-html-stream ;
 
 \ show-paste { { "n" v-number } } define-action
 
 : new-paste ( -- )
-    f "new-paste" "New paste" render-page ;
+    serving-html
+    [ "new-paste" render-template ] with-html-stream ;
 
 \ new-paste { } define-action
 
 : paste-list ( -- )
+    serving-html
     [
         [ show-paste ] "show-paste-quot" set
         [ new-paste ] "new-paste-quot" set
-        pastebin get "paste-list" "Pastebin" render-page
+        pastebin get "paste-list" render-component
-    ] with-scope ;
+    ] with-html-stream ;
 
 \ paste-list { } define-action
 
+: paste-link ( paste -- link )
+    paste-n number>string [ show-paste ] curry quot-link ;
 
+: paste-feed ( -- entries )
+    pastebin get pastebin-pastes [
+        {
+            paste-summary
+            paste-link
+            paste-date
+        } get-slots timestamp>rfc3339 f swap <entry>
+    ] map ;
+
+: feed.xml ( -- )
+    "text/xml" serving-content
+    "pastebin"
+    "http://pastebin.factorcode.org"
+    paste-feed <feed> feed>xml write-xml ;
+
+\ feed.xml { } define-action
 
 : save-pastebin-store ( -- )
     store get-global save-store ;
 
 : add-paste ( paste pastebin -- )
-    >r now timestamp>http-string over set-paste-date r>
+    >r now over set-paste-date r>
-    pastebin-pastes
+    pastebin-pastes 2dup length swap set-paste-n push ;
-    [ length over set-paste-n ] keep push ;
 
-: submit-paste ( summary author channel contents -- )
+: submit-paste ( summary author channel mode contents -- )
-    <paste>
+    <paste> [
         \ pastebin get-global add-paste
-    save-pastebin-store ;
+        save-pastebin-store
+    ] keep paste-link permanent-redirect ;
 
 \ submit-paste {
     { "summary" v-required }
     { "author" v-required }
     { "channel" "#concatenative" v-default }
+    { "mode" "factor" v-default }
     { "contents" v-required }
 } define-action
 
-\ submit-paste [ paste-list ] define-redirect
+: annotate-paste ( n summary author mode contents -- )
-
-: annotate-paste ( n summary author contents -- )
     <annotation> swap get-paste
     paste-annotations push
     save-pastebin-store ;
@@ -85,9 +101,16 @@ SYMBOL: store
     { "n" v-required v-number }
     { "summary" v-required }
     { "author" v-required }
+    { "mode" "factor" v-default }
     { "contents" v-required }
 } define-action
 
 \ annotate-paste [ "n" show-paste ] define-redirect
 
+: style.css ( -- )
+    "text/css" serving-content
+    "style.css" send-resource ;
+
+\ style.css { } define-action
+
 "pastebin" "paste-list" "extra/webapps/pastebin" web-app

extra/webapps/pastebin/show-paste.furnace

@@ -1,15 +1,21 @@
-<% USING: namespaces io furnace sequences ; %>
+<% USING: namespaces io furnace sequences xmode.code2html calendar ; %>
 
-<h1>Paste: <% "summary" get write %></h1>
+<%
+    "Paste: " "summary" get append "title" set
+    "header" render-template
+%>
 
 <table>
 <tr><th>Paste by:</th><td><% "author" get write %></td></tr>
 <tr><th>Channel:</th><td><% "channel" get write %></td></tr>
-<tr><th>Created:</th><td><% "date" get write %></td></tr>
+<tr><th>Created:</th><td><% "date" get timestamp>string write %></td></tr>
+<tr><th>File type:</th><td><% "mode" get write %></td></tr>
 </table>
 
-<pre><% "contents" get write %></pre>
+<% "syntax" render-template %>
 
-<% "annotations" get [ "annotation" render-template ] each %>
+<% "annotations" get [ "annotation" render-component ] each %>
 
-<% model get "annotate-paste" render-template %>
+<% model get "annotate-paste" render-component %>
+
+<% "footer" render-template %>

extra/webapps/pastebin/style.css

@@ -0,0 +1,37 @@
+body {
+	font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+	color:#888;
+}
+
+h1.pastebin-title {
+	font-size:300%;
+}
+
+a {
+	color:#222;
+	border-bottom:1px dotted #ccc;
+	text-decoration:none;
+}
+
+a:hover {
+	border-bottom:1px solid #ccc;
+}
+
+pre.code {
+	border:1px dashed #ccc;
+	background-color:#f5f5f5;
+	padding:5px;
+	font-size:150%;
+	color:#000000;
+}
+
+.navbar {
+	background-color:#eeeeee;
+	padding:5px;
+	border:1px solid #ccc;
+}
+
+.infobox {
+	border: 1px solid #C1DAD7;
+	padding: 10px;
+}

extra/webapps/pastebin/syntax.furnace

@@ -0,0 +1,3 @@
+<% USING: xmode.code2html splitting namespaces ; %>
+
+<pre class="code"><% "contents" get string-lines "mode" get htmlize-lines %></pre>

extra/webapps/planet/planet.factor

@@ -1,41 +1,14 @@
 USING: sequences rss arrays concurrency kernel sorting
 html.elements io assocs namespaces math threads vocabs html
 furnace http.server.templating calendar math.parser splitting
-continuations debugger system http.server.responders ;
+continuations debugger system http.server.responders
+xml.writer ;
 IN: webapps.planet
 
-TUPLE: posting author title date link body ;
-
-: diagnostic write print flush ;
-
-: fetch-feed ( pair -- feed )
-    second
-    dup "Fetching " diagnostic
-    dup news-get feed-entries
-    swap "Done fetching " diagnostic ;
-
-: fetch-blogroll ( blogroll -- entries )
-    #! entries is an array of { author entries } pairs.
-    dup [
-        [ fetch-feed ] [ error. drop f ] recover
-    ] parallel-map
-    [ [ >r first r> 2array ] curry* map ] 2map concat ;
-
-: sort-entries ( entries -- entries' )
-    [ [ second entry-pub-date ] compare ] sort <reversed> ;
-
-: <posting> ( pair -- posting )
-    #! pair has shape { author entry }
-    first2
-    { entry-title entry-pub-date entry-link entry-description }
-    get-slots posting construct-boa ;
-
 : print-posting-summary ( posting -- )
     <p "news" =class p>
-        <b> dup posting-title write </b> <br/>
+        <b> dup entry-title write </b> <br/>
-        "- " write
+        <a entry-link =href "more" =class a>
-        dup posting-author write bl
-        <a posting-link =href "more" =class a>
             "Read More..." write
         </a>
     </p> ;
@@ -51,70 +24,86 @@ TUPLE: posting author title date link body ;
     </ul> ;
 
 : format-date ( date -- string )
-    10 head "-" split [ string>number ] map
+    rfc3339>timestamp timestamp>string ;
-    first3 0 0 0 0 <timestamp>
-    [
-        dup timestamp-day #
-        " " %
-        dup timestamp-month month-abbreviations nth %
-        ", " %
-        timestamp-year #
-    ] "" make ;
 
 : print-posting ( posting -- )
     <h2 "posting-title" =class h2>
-        <a dup posting-link =href a>
+        <a dup entry-link =href a>
-            dup posting-title write-html
+            dup entry-title write-html
-            " - " write
-            dup posting-author write
         </a>
     </h2>
-    <p "posting-body" =class p> dup posting-body write-html </p>
+    <p "posting-body" =class p>
-    <p "posting-date" =class p> posting-date format-date write </p> ;
+        dup entry-description write-html
+    </p>
+    <p "posting-date" =class p>
+        entry-pub-date format-date write
+    </p> ;
 
 : print-postings ( postings -- )
     [ print-posting ] each ;
 
-: browse-webapp-source ( vocab -- )
-    <a f >vocab-link browser-link-href =href a>
-        "Browse source" write
-    </a> ;
-
 SYMBOL: default-blogroll
 SYMBOL: cached-postings
 
-: update-cached-postings ( -- )
+: safe-head ( seq n -- seq' )
-    default-blogroll get fetch-blogroll sort-entries
+    over length min head ;
-    [ <posting> ] map
-    cached-postings set-global ;
 
 : mini-planet-factor ( -- )
-    cached-postings get 4 head print-posting-summaries ;
+    cached-postings get 4 safe-head print-posting-summaries ;
 
 : planet-factor ( -- )
-    serving-html [
+    serving-html [ "planet" render-template ] with-html-stream ;
-        "resource:extra/webapps/planet/planet.fhtml"
-        run-template-file
-    ] with-html-stream ;
 
 \ planet-factor { } define-action
 
-{
+: planet-feed ( -- feed )
-    { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
+    "[ planet-factor ]"
-    { "Chris Double" "http://www.bluishcoder.co.nz/atom.xml" "http://www.bluishcoder.co.nz/" }
+    "http://planet.factorcode.org"
-    { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
+    cached-postings get 30 safe-head <feed> ;
-    { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
+
-    { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
+: feed.xml ( -- )
-    { "Kio M. Smallwood"
+    "text/xml" serving-content
-    "http://sekenre.wordpress.com/feed/atom/"
+    planet-feed feed>xml write-xml ;
-    "http://sekenre.wordpress.com/" }
+
-    { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
+\ feed.xml { } define-action
-    { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
+
-    { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
+: style.css ( -- )
-} default-blogroll set-global
+    "text/css" serving-content
+    "style.css" send-resource ;
+
+\ style.css { } define-action
 
 SYMBOL: last-update
 
+: diagnostic write print flush ;
+
+: fetch-feed ( triple -- feed )
+    second
+    dup "Fetching " diagnostic
+    dup download-feed feed-entries
+    swap "Done fetching " diagnostic ;
+
+: <posting> ( author entry -- entry' )
+    clone
+    [ ": " swap entry-title 3append ] keep
+    [ set-entry-title ] keep ;
+
+: ?fetch-feed ( triple -- feed/f )
+    [ fetch-feed ] [ error. drop f ] recover ;
+
+: fetch-blogroll ( blogroll -- entries )
+    dup 0 <column>
+    swap [ ?fetch-feed ] parallel-map
+    [ [ <posting> ] curry* map ] 2map concat ;
+
+: sort-entries ( entries -- entries' )
+    [ [ entry-pub-date ] compare ] sort <reversed> ;
+
+: update-cached-postings ( -- )
+    default-blogroll get
+    fetch-blogroll sort-entries
+    cached-postings set-global ;
+
 : update-thread ( -- )
     millis last-update set-global
     [ update-cached-postings ] in-thread
@@ -126,14 +115,17 @@ SYMBOL: last-update
 
 "planet" "planet-factor" "extra/webapps/planet" web-app
 
-: merge-feeds ( feeds -- feed )
+{
-    [ feed-entries ] map concat sort-entries ;
+    { "Berlin Brown" "http://factorlang-fornovices.blogspot.com/feeds/posts/default" "http://factorlang-fornovices.blogspot.com" }
-
+    { "Chris Double" "http://www.blogger.com/feeds/18561009/posts/full/-/factor" "http://www.bluishcoder.co.nz/" }
-: planet-feed ( -- feed )
+    { "Elie Chaftari" "http://fun-factor.blogspot.com/feeds/posts/default" "http://fun-factor.blogspot.com/" }
-    default-blogroll get [ second news-get ] map merge-feeds 
+    { "Doug Coleman" "http://code-factor.blogspot.com/feeds/posts/default" "http://code-factor.blogspot.com/" }
-    >r "[ planet-factor ]" "http://planet.factorcode.org" r> <entry>
+    { "Daniel Ehrenberg" "http://useless-factor.blogspot.com/feeds/posts/default" "http://useless-factor.blogspot.com/" }
-    generate-atom ;
+    { "Gavin Harrison" "http://gmh33.blogspot.com/feeds/posts/default" "http://gmh33.blogspot.com/" }
-
+    { "Kio M. Smallwood"
-: feed.xml planet-feed ;
+    "http://sekenre.wordpress.com/feed/atom/"
-
+    "http://sekenre.wordpress.com/" }
-\ feed.xml { } define-action
+    { "Phil Dawes" "http://www.phildawes.net/blog/category/factor/feed/atom" "http://www.phildawes.net/blog/" }
+    { "Samuel Tardieu" "http://www.rfc1149.net/blog/tag/factor/feed/atom/" "http://www.rfc1149.net/blog/tag/factor/" }
+    { "Slava Pestov" "http://factor-language.blogspot.com/atom.xml" "http://factor-language.blogspot.com/" }
+} default-blogroll set-global

extra/webapps/planet/planet.furnace

@@ -1,4 +1,5 @@
-<% USING: namespaces html.elements webapps.planet sequences ; %>
+<% USING: namespaces html.elements webapps.planet sequences
+furnace ; %>
 
 <!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
 	"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
@@ -8,14 +9,15 @@
 	<meta http-equiv="Content-type" content="text/html; charset=utf-8" />
 
 	<title>planet-factor</title>
-	<link rel="stylesheet" href="/responder/file/css/news.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+	<link rel="stylesheet" href="style.css" type="text/css" media="screen" title="no title" charset="utf-8" />
+    <link rel="alternate" type="application/atom+xml" title="Planet Factor - Atom" href="feed.xml" />
 </head>
 
 <body id="index">
     <h1 class="planet-title">[ planet-factor ]</h1>
     <table width="100%" cellpadding="10">
         <tr>
-            <td> <% cached-postings get 20 head print-postings %> </td>
+            <td> <% cached-postings get 20 safe-head print-postings %> </td>
             <td valign="top" width="25%" class="infobox">
                 <p>
                     <b>planet-factor</b> is an Atom/RSS aggregator that collects the
@@ -23,7 +25,11 @@
                     <a href="http://planet.lisp.org">Planet Lisp</a>.
                 </p>
                 <p>
-                    This webapp is written in <a href="http://factorcode.org/">Factor</a>.
+                    <img src="http://planet.lisp.org/feed-icon-14x14.png" />
+                    <a href="feed.xml"> Syndicate </a>
+                </p>
+                <p>
+                    This webapp is written in <a href="http://factorcode.org/">Factor</a>.<br/>
                     <% "webapps.planet" browse-webapp-source %>
                 </p>
                 <h2 class="blogroll-title">Blogroll</h2>

extra/webapps/planet/style.css

@@ -0,0 +1,45 @@
+body {
+	font:75%/1.6em "Lucida Grande", "Lucida Sans Unicode", verdana, geneva, sans-serif;
+	color:#888;
+}
+
+h1.planet-title {
+	font-size:300%;
+}
+
+a {
+	color:#222;
+	border-bottom:1px dotted #ccc;
+	text-decoration:none;
+}
+
+a:hover {
+	border-bottom:1px solid #ccc;
+}
+
+.posting-title {
+	background-color:#f5f5f5;
+}
+
+pre, code {
+	color:#000000;
+	font-size:120%;
+}
+
+.infobox {
+	border-left: 1px solid #C1DAD7;
+}
+
+.posting-date {
+	text-align: right;
+	font-size:90%;
+}
+
+a.more {
+	display:block;
+	padding:0 0 5px 0;
+	color:#333;
+	text-decoration:none;
+	text-align:right;
+	border:none;
+}

extra/webapps/source/source.factor

@@ -0,0 +1,20 @@
+! Copyright (C) 2007 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.files namespaces webapps.file http.server.responders
+xmode.code2html kernel html ;
+IN: webapps.source
+
+global [
+    ! Serve up our own source code
+    "source" [
+        [
+            "" resource-path "doc-root" set
+            [
+                drop
+                serving-html
+                [ swap htmlize-stream ] with-html-stream
+            ] serve-file-hook set
+            file-responder
+        ] with-scope
+    ] add-simple-responder
+] bind

extra/windows/kernel32/kernel32.factor

@@ -1010,7 +1010,8 @@ FUNCTION: HANDLE GetStdHandle ( DWORD nStdHandle ) ;
 ! FUNCTION: GetSystemDefaultLCID
 ! FUNCTION: GetSystemDefaultUILanguage
 ! FUNCTION: GetSystemDirectoryA
-! FUNCTION: GetSystemDirectoryW
+FUNCTION: UINT GetSystemDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
+: GetSystemDirectory GetSystemDirectoryW ; inline
 FUNCTION: void GetSystemInfo ( LPSYSTEM_INFO lpSystemInfo ) ;
 ! FUNCTION: GetSystemPowerStatus
 ! FUNCTION: GetSystemRegistryQuota
@@ -1019,7 +1020,8 @@ FUNCTION: void GetSystemTime ( LPSYSTEMTIME lpSystemTime ) ;
 FUNCTION: void GetSystemTimeAsFileTime ( LPFILETIME lpSystemTimeAsFileTime ) ;
 ! FUNCTION: GetSystemTimes
 ! FUNCTION: GetSystemWindowsDirectoryA
-! FUNCTION: GetSystemWindowsDirectoryW
+FUNCTION: UINT GetSystemWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
+: GetSystemWindowsDirectory GetSystemWindowsDirectoryW ; inline
 ! FUNCTION: GetSystemWow64DirectoryA
 ! FUNCTION: GetSystemWow64DirectoryW
 ! FUNCTION: GetTapeParameters
@@ -1057,7 +1059,8 @@ FUNCTION: BOOL GetVersionExW ( LPOSVERSIONINFO lpVersionInfo ) ;
 ! FUNCTION: GetVolumePathNamesForVolumeNameW
 ! FUNCTION: GetVolumePathNameW
 ! FUNCTION: GetWindowsDirectoryA
-! FUNCTION: GetWindowsDirectoryW
+FUNCTION: UINT GetWindowsDirectoryW ( LPTSTR lpBuffer, UINT uSize ) ;
+: GetWindowsDirectory GetWindowsDirectoryW ; inline
 ! FUNCTION: GetWriteWatch
 ! FUNCTION: GlobalAddAtomA
 ! FUNCTION: GlobalAddAtomW

extra/windows/messages/messages.factor

@@ -13,7 +13,7 @@ SYMBOL: windows-messages
     word [ word-name ] keep execute maybe-create-windows-messages
     windows-messages get set-at ; parsing
 
-: get-windows-message-name ( n -- name )
+: windows-message-name ( n -- name )
     windows-messages get at* [ drop "unknown message" ] unless ;
 
 : WM_NULL HEX: 0000 ; inline add-windows-message
@@ -107,6 +107,8 @@ SYMBOL: windows-messages
 : WM_NCXBUTTONDOWN HEX: 00AB ; inline add-windows-message
 : WM_NCXBUTTONUP HEX: 00AC ; inline add-windows-message
 : WM_NCXBUTTONDBLCLK HEX: 00AD ; inline add-windows-message
+: WM_NCUAHDRAWCAPTION HEX: 00AE ; inline add-windows-message ! undocumented
+: WM_NCUAHDRAWFRAME HEX: 00AF ; inline add-windows-message   ! undocumented
 : WM_INPUT HEX: 00FF ; inline add-windows-message
 : WM_KEYFIRST HEX: 0100 ; inline add-windows-message
 : WM_KEYDOWN HEX: 0100 ; inline add-windows-message

extra/windows/nt/nt.factor

@@ -6,6 +6,7 @@ USING: alien sequences ;
     { "kernel32" "kernel32.dll" "stdcall" }
     { "winsock"  "ws2_32.dll"   "stdcall" }
     { "mswsock"  "mswsock.dll"  "stdcall" }
+    { "shell32"  "shell32.dll"  "stdcall" }
     { "libc"     "msvcrt.dll"   "cdecl"   }
     { "libm"     "msvcrt.dll"   "cdecl"   }
     { "gl"       "opengl32.dll" "stdcall" }

extra/windows/shell32/shell32.factor

@@ -0,0 +1,132 @@
+USING: alien alien.c-types alien.syntax combinators
+kernel windows windows.user32 ;
+IN: windows.shell32
+
+: CSIDL_DESKTOP HEX: 00 ; inline
+: CSIDL_INTERNET HEX: 01 ; inline
+: CSIDL_PROGRAMS HEX: 02 ; inline
+: CSIDL_CONTROLS HEX: 03 ; inline
+: CSIDL_PRINTERS HEX: 04 ; inline
+: CSIDL_PERSONAL HEX: 05 ; inline
+: CSIDL_FAVORITES HEX: 06 ; inline
+: CSIDL_STARTUP HEX: 07 ; inline
+: CSIDL_RECENT HEX: 08 ; inline
+: CSIDL_SENDTO HEX: 09 ; inline
+: CSIDL_BITBUCKET HEX: 0a ; inline
+: CSIDL_STARTMENU HEX: 0b ; inline
+: CSIDL_MYDOCUMENTS HEX: 0c ; inline
+: CSIDL_MYMUSIC HEX: 0d ; inline
+: CSIDL_MYVIDEO HEX: 0e ; inline
+: CSIDL_DESKTOPDIRECTORY HEX: 10 ; inline
+: CSIDL_DRIVES HEX: 11 ; inline
+: CSIDL_NETWORK HEX: 12 ; inline
+: CSIDL_NETHOOD HEX: 13 ; inline
+: CSIDL_FONTS HEX: 14 ; inline
+: CSIDL_TEMPLATES HEX: 15 ; inline
+: CSIDL_COMMON_STARTMENU HEX: 16 ; inline
+: CSIDL_COMMON_PROGRAMS HEX: 17 ; inline
+: CSIDL_COMMON_STARTUP HEX: 18 ; inline
+: CSIDL_COMMON_DESKTOPDIRECTORY HEX: 19 ; inline
+: CSIDL_APPDATA HEX: 1a ; inline
+: CSIDL_PRINTHOOD HEX: 1b ; inline
+: CSIDL_LOCAL_APPDATA HEX: 1c ; inline
+: CSIDL_ALTSTARTUP HEX: 1d ; inline
+: CSIDL_COMMON_ALTSTARTUP HEX: 1e ; inline
+: CSIDL_COMMON_FAVORITES HEX: 1f ; inline
+: CSIDL_INTERNET_CACHE HEX: 20 ; inline
+: CSIDL_COOKIES HEX: 21 ; inline
+: CSIDL_HISTORY HEX: 22 ; inline
+: CSIDL_COMMON_APPDATA HEX: 23 ; inline
+: CSIDL_WINDOWS HEX: 24 ; inline
+: CSIDL_SYSTEM HEX: 25 ; inline
+: CSIDL_PROGRAM_FILES HEX: 26 ; inline
+: CSIDL_MYPICTURES HEX: 27 ; inline
+: CSIDL_PROFILE HEX: 28 ; inline
+: CSIDL_SYSTEMX86 HEX: 29 ; inline
+: CSIDL_PROGRAM_FILESX86 HEX: 2a ; inline
+: CSIDL_PROGRAM_FILES_COMMON HEX: 2b ; inline
+: CSIDL_PROGRAM_FILES_COMMONX86 HEX: 2c ; inline
+: CSIDL_COMMON_TEMPLATES HEX: 2d ; inline
+: CSIDL_COMMON_DOCUMENTS HEX: 2e ; inline
+: CSIDL_COMMON_ADMINTOOLS HEX: 2f ; inline
+: CSIDL_ADMINTOOLS HEX: 30 ; inline
+: CSIDL_CONNECTIONS HEX: 31 ; inline
+: CSIDL_COMMON_MUSIC HEX: 35 ; inline
+: CSIDL_COMMON_PICTURES HEX: 36 ; inline
+: CSIDL_COMMON_VIDEO HEX: 37 ; inline
+: CSIDL_RESOURCES HEX: 38 ; inline
+: CSIDL_RESOURCES_LOCALIZED HEX: 39 ; inline
+: CSIDL_COMMON_OEM_LINKS HEX: 3a ; inline
+: CSIDL_CDBURN_AREA HEX: 3b ; inline
+: CSIDL_COMPUTERSNEARME HEX: 3d ; inline
+: CSIDL_PROFILES HEX: 3e ; inline
+: CSIDL_FOLDER_MASK HEX: ff ; inline
+: CSIDL_FLAG_PER_USER_INIT HEX: 800 ; inline
+: CSIDL_FLAG_NO_ALIAS HEX: 1000 ; inline
+: CSIDL_FLAG_DONT_VERIFY HEX: 4000 ; inline
+: CSIDL_FLAG_CREATE HEX: 8000 ; inline
+: CSIDL_FLAG_MASK HEX: ff00 ; inline
+
+
+: S_OK 0 ; inline
+: S_FALSE 1 ; inline
+: E_FAIL HEX: 80004005 ; inline
+: E_INVALIDARG HEX: 80070057 ; inline
+: ERROR_FILE_NOT_FOUND 2 ; inline
+
+: SHGFP_TYPE_CURRENT 0 ; inline
+: SHGFP_TYPE_DEFAULT 1 ; inline
+
+LIBRARY: shell32
+
+FUNCTION: HRESULT SHGetFolderPathW ( HWND hwndOwner, int nFolder, HANDLE hToken, DWORD dwReserved, LPTSTR pszPath ) ;
+: SHGetFolderPath SHGetFolderPathW ; inline
+
+FUNCTION: HINSTANCE ShellExecuteW ( HWND hwnd, LPCTSTR lpOperation, LPCTSTR lpFile, LPCTSTR lpParameters, LPCTSTR lpDirectory, INT nShowCmd ) ;
+: ShellExecute ShellExecuteW ; inline
+
+: open-in-explorer ( dir -- )
+    f "open" rot f f SW_SHOWNORMAL ShellExecute drop ;
+
+: shell32-error ( n -- )
+    dup S_OK = [
+        drop
+    ] [
+        {
+            ! { ERROR_FILE_NOT_FOUND [ "file not found" throw ] }
+            ! { E_INVALIDARG [ "invalid arg" throw ] }
+            [ (win32-error-string) throw ]
+        } case
+    ] if ;
+
+: shell32-directory ( n -- str )
+    f swap f SHGFP_TYPE_DEFAULT
+    MAX_UNICODE_PATH "ushort" <c-array>
+    [ SHGetFolderPath shell32-error ] keep alien>u16-string ;
+
+: desktop ( -- str )
+    CSIDL_DESKTOPDIRECTORY shell32-directory ;
+
+: my-documents ( -- str )
+    CSIDL_PERSONAL shell32-directory ;
+
+: application-data ( -- str )
+    CSIDL_APPDATA shell32-directory ;
+
+: windows ( -- str )
+    CSIDL_WINDOWS shell32-directory ;
+
+: programs ( -- str )
+    CSIDL_PROGRAMS shell32-directory ;
+
+: program-files ( -- str )
+    CSIDL_PROGRAM_FILES shell32-directory ;
+
+: program-files-x86 ( -- str )
+    CSIDL_PROGRAM_FILESX86 shell32-directory ;
+
+: program-files-common ( -- str )
+    CSIDL_PROGRAM_FILES_COMMON shell32-directory ;
+
+: program-files-common-x86 ( -- str )
+    CSIDL_PROGRAM_FILES_COMMONX86 shell32-directory ;

extra/windows/types/types.factor

@@ -333,4 +333,8 @@ C-STRUCT: LVFINDINFO
     { "POINT" "pt" }
     { "uint" "vkDirection" } ;
 
-
+C-STRUCT: ACCEL
+    { "BYTE" "fVirt" }
+    { "WORD" "key" }
+    { "WORD" "cmd" } ;
+TYPEDEF: ACCEL* LPACCEL

extra/windows/user32/user32.factor

@@ -5,43 +5,43 @@ windows.types shuffle ;
 IN: windows.user32
 
 ! HKL for ActivateKeyboardLayout
-: HKL_PREV 0 ;
+: HKL_PREV 0 ; inline
-: HKL_NEXT 1 ;
+: HKL_NEXT 1 ; inline
 
-: CW_USEDEFAULT HEX: 80000000 ;
+: CW_USEDEFAULT HEX: 80000000 ; inline
 
-: WS_OVERLAPPED       HEX: 00000000 ;
+: WS_OVERLAPPED       HEX: 00000000 ; inline
-: WS_POPUP            HEX: 80000000 ;
+: WS_POPUP            HEX: 80000000 ; inline
-: WS_CHILD            HEX: 40000000 ;
+: WS_CHILD            HEX: 40000000 ; inline
-: WS_MINIMIZE         HEX: 20000000 ;
+: WS_MINIMIZE         HEX: 20000000 ; inline
-: WS_VISIBLE          HEX: 10000000 ;
+: WS_VISIBLE          HEX: 10000000 ; inline
-: WS_DISABLED         HEX: 08000000 ;
+: WS_DISABLED         HEX: 08000000 ; inline
-: WS_CLIPSIBLINGS     HEX: 04000000 ;
+: WS_CLIPSIBLINGS     HEX: 04000000 ; inline
-: WS_CLIPCHILDREN     HEX: 02000000 ;
+: WS_CLIPCHILDREN     HEX: 02000000 ; inline
-: WS_MAXIMIZE         HEX: 01000000 ;
+: WS_MAXIMIZE         HEX: 01000000 ; inline
-: WS_CAPTION          HEX: 00C00000 ; !    /* WS_BORDER | WS_DLGFRAME  */
+: WS_CAPTION          HEX: 00C00000 ; inline
-: WS_BORDER           HEX: 00800000 ;
+: WS_BORDER           HEX: 00800000 ; inline
-: WS_DLGFRAME         HEX: 00400000 ;
+: WS_DLGFRAME         HEX: 00400000 ; inline
-: WS_VSCROLL          HEX: 00200000 ;
+: WS_VSCROLL          HEX: 00200000 ; inline
-: WS_HSCROLL          HEX: 00100000 ;
+: WS_HSCROLL          HEX: 00100000 ; inline
-: WS_SYSMENU          HEX: 00080000 ;
+: WS_SYSMENU          HEX: 00080000 ; inline
-: WS_THICKFRAME       HEX: 00040000 ;
+: WS_THICKFRAME       HEX: 00040000 ; inline
-: WS_GROUP            HEX: 00020000 ;
+: WS_GROUP            HEX: 00020000 ; inline
-: WS_TABSTOP          HEX: 00010000 ;
+: WS_TABSTOP          HEX: 00010000 ; inline
-: WS_MINIMIZEBOX      HEX: 00020000 ;
+: WS_MINIMIZEBOX      HEX: 00020000 ; inline
-: WS_MAXIMIZEBOX      HEX: 00010000 ;
+: WS_MAXIMIZEBOX      HEX: 00010000 ; inline
 
 ! Common window styles
-: WS_OVERLAPPEDWINDOW WS_OVERLAPPED WS_CAPTION WS_SYSMENU WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX bitor bitor bitor bitor bitor ;
+: WS_OVERLAPPEDWINDOW WS_OVERLAPPED WS_CAPTION WS_SYSMENU WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX bitor bitor bitor bitor bitor ; foldable inline
 
-: WS_POPUPWINDOW      WS_POPUP WS_BORDER WS_SYSMENU bitor bitor ;
+: WS_POPUPWINDOW      WS_POPUP WS_BORDER WS_SYSMENU bitor bitor ; foldable inline
 
-: WS_CHILDWINDOW      WS_CHILD ;
+: WS_CHILDWINDOW      WS_CHILD ; inline
 
-: WS_TILED            WS_OVERLAPPED ;
+: WS_TILED            WS_OVERLAPPED ; inline
-: WS_ICONIC           WS_MINIMIZE ;
+: WS_ICONIC           WS_MINIMIZE ; inline
-: WS_SIZEBOX          WS_THICKFRAME ;
+: WS_SIZEBOX          WS_THICKFRAME ; inline
-: WS_TILEDWINDOW      WS_OVERLAPPEDWINDOW ;
+: WS_TILEDWINDOW      WS_OVERLAPPEDWINDOW ; inline
 
 ! Extended window styles
 
@@ -65,72 +65,74 @@ IN: windows.user32
 : WS_EX_CONTROLPARENT     HEX: 00010000 ; inline
 : WS_EX_STATICEDGE        HEX: 00020000 ; inline
 : WS_EX_APPWINDOW         HEX: 00040000 ; inline
-: WS_EX_OVERLAPPEDWINDOW WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; inline
+: WS_EX_OVERLAPPEDWINDOW ( -- n )
-: WS_EX_PALETTEWINDOW
+    WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable inline
-    WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW bitor WS_EX_TOPMOST bitor ; inline
+: WS_EX_PALETTEWINDOW ( -- n )
+    WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW bitor
+    WS_EX_TOPMOST bitor ; foldable inline
 
-: CS_VREDRAW          HEX: 0001 ;
+: CS_VREDRAW          HEX: 0001 ; inline
-: CS_HREDRAW          HEX: 0002 ;
+: CS_HREDRAW          HEX: 0002 ; inline
-: CS_DBLCLKS          HEX: 0008 ;
+: CS_DBLCLKS          HEX: 0008 ; inline
-: CS_OWNDC            HEX: 0020 ;
+: CS_OWNDC            HEX: 0020 ; inline
-: CS_CLASSDC          HEX: 0040 ;
+: CS_CLASSDC          HEX: 0040 ; inline
-: CS_PARENTDC         HEX: 0080 ;
+: CS_PARENTDC         HEX: 0080 ; inline
-: CS_NOCLOSE          HEX: 0200 ;
+: CS_NOCLOSE          HEX: 0200 ; inline
-: CS_SAVEBITS         HEX: 0800 ;
+: CS_SAVEBITS         HEX: 0800 ; inline
-: CS_BYTEALIGNCLIENT  HEX: 1000 ;
+: CS_BYTEALIGNCLIENT  HEX: 1000 ; inline
-: CS_BYTEALIGNWINDOW  HEX: 2000 ;
+: CS_BYTEALIGNWINDOW  HEX: 2000 ; inline
-: CS_GLOBALCLASS      HEX: 4000 ;
+: CS_GLOBALCLASS      HEX: 4000 ; inline
 
-: COLOR_SCROLLBAR         0 ;
+: COLOR_SCROLLBAR         0 ; inline
-: COLOR_BACKGROUND        1 ;
+: COLOR_BACKGROUND        1 ; inline
-: COLOR_ACTIVECAPTION     2 ;
+: COLOR_ACTIVECAPTION     2 ; inline
-: COLOR_INACTIVECAPTION   3 ;
+: COLOR_INACTIVECAPTION   3 ; inline
-: COLOR_MENU              4 ;
+: COLOR_MENU              4 ; inline
-: COLOR_WINDOW            5 ;
+: COLOR_WINDOW            5 ; inline
-: COLOR_WINDOWFRAME       6 ;
+: COLOR_WINDOWFRAME       6 ; inline
-: COLOR_MENUTEXT          7 ;
+: COLOR_MENUTEXT          7 ; inline
-: COLOR_WINDOWTEXT        8 ;
+: COLOR_WINDOWTEXT        8 ; inline
-: COLOR_CAPTIONTEXT       9 ;
+: COLOR_CAPTIONTEXT       9 ; inline
-: COLOR_ACTIVEBORDER      10 ;
+: COLOR_ACTIVEBORDER      10 ; inline
-: COLOR_INACTIVEBORDER    11 ;
+: COLOR_INACTIVEBORDER    11 ; inline
-: COLOR_APPWORKSPACE      12 ;
+: COLOR_APPWORKSPACE      12 ; inline
-: COLOR_HIGHLIGHT         13 ;
+: COLOR_HIGHLIGHT         13 ; inline
-: COLOR_HIGHLIGHTTEXT     14 ;
+: COLOR_HIGHLIGHTTEXT     14 ; inline
-: COLOR_BTNFACE           15 ;
+: COLOR_BTNFACE           15 ; inline
-: COLOR_BTNSHADOW         16 ;
+: COLOR_BTNSHADOW         16 ; inline
-: COLOR_GRAYTEXT          17 ;
+: COLOR_GRAYTEXT          17 ; inline
-: COLOR_BTNTEXT           18 ;
+: COLOR_BTNTEXT           18 ; inline
-: COLOR_INACTIVECAPTIONTEXT 19 ;
+: COLOR_INACTIVECAPTIONTEXT 19 ; inline
-: COLOR_BTNHIGHLIGHT      20 ;
+: COLOR_BTNHIGHLIGHT      20 ; inline
 
-: IDI_APPLICATION     32512 ;
+: IDI_APPLICATION     32512 ; inline
-: IDI_HAND            32513 ;
+: IDI_HAND            32513 ; inline
-: IDI_QUESTION        32514 ;
+: IDI_QUESTION        32514 ; inline
-: IDI_EXCLAMATION     32515 ;
+: IDI_EXCLAMATION     32515 ; inline
-: IDI_ASTERISK        32516 ;
+: IDI_ASTERISK        32516 ; inline
-: IDI_WINLOGO         32517 ;
+: IDI_WINLOGO         32517 ; inline
 
 ! ShowWindow() Commands
-: SW_HIDE             0 ;
+: SW_HIDE             0 ; inline
-: SW_SHOWNORMAL       1 ;
+: SW_SHOWNORMAL       1 ; inline
-: SW_NORMAL           1 ;
+: SW_NORMAL           1 ; inline
-: SW_SHOWMINIMIZED    2 ;
+: SW_SHOWMINIMIZED    2 ; inline
-: SW_SHOWMAXIMIZED    3 ;
+: SW_SHOWMAXIMIZED    3 ; inline
-: SW_MAXIMIZE         3 ;
+: SW_MAXIMIZE         3 ; inline
-: SW_SHOWNOACTIVATE   4 ;
+: SW_SHOWNOACTIVATE   4 ; inline
-: SW_SHOW             5 ;
+: SW_SHOW             5 ; inline
-: SW_MINIMIZE         6 ;
+: SW_MINIMIZE         6 ; inline
-: SW_SHOWMINNOACTIVE  7 ;
+: SW_SHOWMINNOACTIVE  7 ; inline
-: SW_SHOWNA           8 ;
+: SW_SHOWNA           8 ; inline
-: SW_RESTORE          9 ;
+: SW_RESTORE          9 ; inline
-: SW_SHOWDEFAULT      10 ;
+: SW_SHOWDEFAULT      10 ; inline
-: SW_FORCEMINIMIZE    11 ;
+: SW_FORCEMINIMIZE    11 ; inline
-: SW_MAX              11 ;
+: SW_MAX              11 ; inline
 
 ! PeekMessage
-: PM_NOREMOVE   0 ;
+: PM_NOREMOVE   0 ; inline
-: PM_REMOVE     1 ;
+: PM_REMOVE     1 ; inline
-: PM_NOYIELD    2 ;
+: PM_NOYIELD    2 ; inline
 ! : PM_QS_INPUT         (QS_INPUT << 16) ;
 ! : PM_QS_POSTMESSAGE   ((QS_POSTMESSAGE | QS_HOTKEY | QS_TIMER) << 16) ;
 ! : PM_QS_PAINT         (QS_PAINT << 16) ;
@@ -140,22 +142,22 @@ IN: windows.user32
 ! 
 ! Standard Cursor IDs
 !
-: IDC_ARROW           32512 ;
+: IDC_ARROW           32512 ; inline
-: IDC_IBEAM           32513 ;
+: IDC_IBEAM           32513 ; inline
-: IDC_WAIT            32514 ;
+: IDC_WAIT            32514 ; inline
-: IDC_CROSS           32515 ;
+: IDC_CROSS           32515 ; inline
-: IDC_UPARROW         32516 ;
+: IDC_UPARROW         32516 ; inline
-: IDC_SIZE            32640 ; ! OBSOLETE: use IDC_SIZEALL
+: IDC_SIZE            32640 ; inline ! OBSOLETE: use IDC_SIZEALL
-: IDC_ICON            32641 ; ! OBSOLETE: use IDC_ARROW
+: IDC_ICON            32641 ; inline ! OBSOLETE: use IDC_ARROW
-: IDC_SIZENWSE        32642 ;
+: IDC_SIZENWSE        32642 ; inline
-: IDC_SIZENESW        32643 ;
+: IDC_SIZENESW        32643 ; inline
-: IDC_SIZEWE          32644 ;
+: IDC_SIZEWE          32644 ; inline
-: IDC_SIZENS          32645 ;
+: IDC_SIZENS          32645 ; inline
-: IDC_SIZEALL         32646 ;
+: IDC_SIZEALL         32646 ; inline
-: IDC_NO              32648 ; ! not in win3.1
+: IDC_NO              32648 ; inline ! not in win3.1
-: IDC_HAND            32649 ;
+: IDC_HAND            32649 ; inline
-: IDC_APPSTARTING     32650 ; ! not in win3.1
+: IDC_APPSTARTING     32650 ; inline ! not in win3.1
-: IDC_HELP            32651 ;
+: IDC_HELP            32651 ; inline
 
 ! Predefined Clipboard Formats
 : CF_TEXT             1 ; inline
@@ -244,9 +246,43 @@ IN: windows.user32
 : VK_DELETE         HEX: 2E ; inline
 : VK_HELP           HEX: 2F ; inline
 
-! VK_0 - VK_9 are the same as ASCII '0' - '9' (0x30 - 0x39)
+: VK_0 CHAR: 0 ; inline
-! 0x40 : unassigned
+: VK_1 CHAR: 1 ; inline
-! VK_A - VK_Z are the same as ASCII 'A' - 'Z' (0x41 - 0x5A)
+: VK_2 CHAR: 2 ; inline
+: VK_3 CHAR: 3 ; inline
+: VK_4 CHAR: 4 ; inline
+: VK_5 CHAR: 5 ; inline
+: VK_6 CHAR: 6 ; inline
+: VK_7 CHAR: 7 ; inline
+: VK_8 CHAR: 8 ; inline
+: VK_9 CHAR: 9 ; inline
+
+: VK_A CHAR: A ; inline
+: VK_B CHAR: B ; inline
+: VK_C CHAR: C ; inline
+: VK_D CHAR: D ; inline
+: VK_E CHAR: E ; inline
+: VK_F CHAR: F ; inline
+: VK_G CHAR: G ; inline
+: VK_H CHAR: H ; inline
+: VK_I CHAR: I ; inline
+: VK_J CHAR: J ; inline
+: VK_K CHAR: K ; inline
+: VK_L CHAR: L ; inline
+: VK_M CHAR: M ; inline
+: VK_N CHAR: N ; inline
+: VK_O CHAR: O ; inline
+: VK_P CHAR: P ; inline
+: VK_Q CHAR: Q ; inline
+: VK_R CHAR: R ; inline
+: VK_S CHAR: S ; inline
+: VK_T CHAR: T ; inline
+: VK_U CHAR: U ; inline
+: VK_V CHAR: V ; inline
+: VK_W CHAR: W ; inline
+: VK_X CHAR: X ; inline
+: VK_Y CHAR: Y ; inline
+: VK_Z CHAR: Z ; inline
 
 : VK_LWIN           HEX: 5B ; inline
 : VK_RWIN           HEX: 5C ; inline
@@ -417,47 +453,59 @@ IN: windows.user32
 
 ! Some fields are not defined for win64
 ! Window field offsets for GetWindowLong()
-: GWL_WNDPROC         -4 ;
+: GWL_WNDPROC         -4 ; inline
-: GWL_HINSTANCE       -6 ;
+: GWL_HINSTANCE       -6 ; inline
-: GWL_HWNDPARENT      -8 ;
+: GWL_HWNDPARENT      -8 ; inline
-: GWL_USERDATA        -21 ;
+: GWL_USERDATA        -21 ; inline
-: GWL_ID              -12 ;
+: GWL_ID              -12 ; inline
 
-: GWL_STYLE           -16 ;
+: GWL_STYLE           -16 ; inline
-: GWL_EXSTYLE         -20 ;
+: GWL_EXSTYLE         -20 ; inline
 
-: GWLP_WNDPROC        -4 ;
+: GWLP_WNDPROC        -4 ; inline
-: GWLP_HINSTANCE      -6 ;
+: GWLP_HINSTANCE      -6 ; inline
-: GWLP_HWNDPARENT     -8 ;
+: GWLP_HWNDPARENT     -8 ; inline
-: GWLP_USERDATA       -21 ;
+: GWLP_USERDATA       -21 ; inline
-: GWLP_ID             -12 ;
+: GWLP_ID             -12 ; inline
 
 ! Class field offsets for GetClassLong()
-: GCL_MENUNAME        -8 ;
+: GCL_MENUNAME        -8 ; inline
-: GCL_HBRBACKGROUND   -10 ;
+: GCL_HBRBACKGROUND   -10 ; inline
-: GCL_HCURSOR         -12 ;
+: GCL_HCURSOR         -12 ; inline
-: GCL_HICON           -14 ;
+: GCL_HICON           -14 ; inline
-: GCL_HMODULE         -16 ;
+: GCL_HMODULE         -16 ; inline
-: GCL_WNDPROC         -24 ;
+: GCL_WNDPROC         -24 ; inline
-: GCL_HICONSM         -34 ;
+: GCL_HICONSM         -34 ; inline
-: GCL_CBWNDEXTRA      -18 ;
+: GCL_CBWNDEXTRA      -18 ; inline
-: GCL_CBCLSEXTRA      -20 ;
+: GCL_CBCLSEXTRA      -20 ; inline
-: GCL_STYLE           -26 ;
+: GCL_STYLE           -26 ; inline
-: GCW_ATOM            -32 ;
+: GCW_ATOM            -32 ; inline
 
-: GCLP_MENUNAME       -8 ;
+: GCLP_MENUNAME       -8 ; inline
-: GCLP_HBRBACKGROUND  -10 ;
+: GCLP_HBRBACKGROUND  -10 ; inline
-: GCLP_HCURSOR        -12 ;
+: GCLP_HCURSOR        -12 ; inline
-: GCLP_HICON          -14 ;
+: GCLP_HICON          -14 ; inline
-: GCLP_HMODULE        -16 ;
+: GCLP_HMODULE        -16 ; inline
-: GCLP_WNDPROC        -24 ;
+: GCLP_WNDPROC        -24 ; inline
-: GCLP_HICONSM        -34 ;
+: GCLP_HICONSM        -34 ; inline
 
-: MB_ICONASTERISK    HEX: 00000040 ;
+: MB_ICONASTERISK    HEX: 00000040 ; inline
-: MB_ICONEXCLAMATION HEX: 00000030 ;
+: MB_ICONEXCLAMATION HEX: 00000030 ; inline
-: MB_ICONHAND        HEX: 00000010 ;
+: MB_ICONHAND        HEX: 00000010 ; inline
-: MB_ICONQUESTION    HEX: 00000020 ;
+: MB_ICONQUESTION    HEX: 00000020 ; inline
-: MB_OK              HEX: 00000000 ;
+: MB_OK              HEX: 00000000 ; inline
+
+: FVIRTKEY TRUE ; inline
+: FNOINVERT 2 ; inline
+: FSHIFT 4 ; inline
+: FCONTROL 8 ; inline
+: FALT 16 ; inline
+
+: MAPVK_VK_TO_VSC 0 ; inline
+: MAPVK_VSC_TO_VK 1 ; inline
+: MAPVK_VK_TO_CHAR 2 ; inline
+: MAPVK_VSC_TO_VK_EX 3 ; inline
+: MAPVK_VK_TO_VSC_EX 3 ; inline
 
 : TME_HOVER 1 ; inline
 : TME_LEAVE 2 ; inline
@@ -549,13 +597,15 @@ FUNCTION: BOOL CloseClipboard ( ) ;
 ! FUNCTION: CloseWindow
 ! FUNCTION: CloseWindowStation
 ! FUNCTION: CopyAcceleratorTableA
-! FUNCTION: CopyAcceleratorTableW
+FUNCTION: int CopyAcceleratorTableW ( HACCEL hAccelSrc, LPACCEL lpAccelDst, int cAccelEntries ) ;
+: CopyAcceleratorTable CopyAcceleratorTableW ; inline
 ! FUNCTION: CopyIcon
 ! FUNCTION: CopyImage
 ! FUNCTION: CopyRect
 ! FUNCTION: CountClipboardFormats
 ! FUNCTION: CreateAcceleratorTableA
-! FUNCTION: CreateAcceleratorTableW
+FUNCTION: HACCEL CreateAcceleratorTableW ( LPACCEL lpaccl, int cEntries ) ;
+: CreateAcceleratorTable CreateAcceleratorTableW ; inline
 ! FUNCTION: CreateCaret
 ! FUNCTION: CreateCursor
 ! FUNCTION: CreateDesktopA
@@ -643,7 +693,7 @@ FUNCTION: LRESULT DefWindowProcW ( HWND hWnd, UINT Msg, WPARAM wParam, LPARAM lP
 : DefWindowProc DefWindowProcW ; inline
 ! FUNCTION: DeleteMenu
 ! FUNCTION: DeregisterShellHookWindow
-! FUNCTION: DestroyAcceleratorTable
+FUNCTION: BOOL DestroyAcceleratorTable ( HACCEL hAccel ) ;
 ! FUNCTION: DestroyCaret
 ! FUNCTION: DestroyCursor
 ! FUNCTION: DestroyIcon
@@ -953,7 +1003,7 @@ FUNCTION: BOOL IsZoomed ( HWND hWnd ) ;
 ! FUNCTION: KillSystemTimer
 ! FUNCTION: KillTimer
 ! FUNCTION: LoadAcceleratorsA
-! FUNCTION: LoadAcceleratorsW
+FUNCTION: HACCEL LoadAcceleratorsW ( HINSTANCE hInstance, LPCTSTR lpTableName ) ;
 ! FUNCTION: LoadBitmapA
 ! FUNCTION: LoadBitmapW
 ! FUNCTION: LoadCursorFromFileA
@@ -988,10 +1038,13 @@ FUNCTION: HICON LoadIconW ( HINSTANCE hInstance, LPCTSTR lpIconName ) ;
 ! FUNCTION: LookupIconIdFromDirectory
 ! FUNCTION: LookupIconIdFromDirectoryEx
 ! FUNCTION: MapDialogRect
-! FUNCTION: MapVirtualKeyA
+
-! FUNCTION: MapVirtualKeyExA
+FUNCTION: UINT MapVirtualKeyW ( UINT uCode, UINT uMapType ) ;
-! FUNCTION: MapVirtualKeyExW
+: MapVirtualKey MapVirtualKeyW ; inline
-! FUNCTION: MapVirtualKeyW
+
+FUNCTION: UINT MapVirtualKeyExW ( UINT uCode, UINT uMapType, HKL dwhkl ) ;
+: MapVirtualKeyEx MapVirtualKeyExW ; inline
+
 ! FUNCTION: MapWindowPoints
 ! FUNCTION: MB_GetString
 ! FUNCTION: MBToWCSEx
@@ -1050,7 +1103,6 @@ FUNCTION: int MessageBoxExW (
 ! FUNCTION: mouse_event
 
 
-
 FUNCTION: BOOL MoveWindow (
     HWND hWnd,
     int X,
@@ -1059,7 +1111,6 @@ FUNCTION: BOOL MoveWindow (
     int nHeight,
     BOOL bRepaint ) ;
 
-
 ! FUNCTION: MsgWaitForMultipleObjects
 ! FUNCTION: MsgWaitForMultipleObjectsEx
 ! FUNCTION: NotifyWinEvent
@@ -1264,7 +1315,9 @@ FUNCTION: BOOL TrackMouseEvent ( LPTRACKMOUSEEVENT lpEventTrack ) ;
 ! FUNCTION: TrackPopupMenuEx
 ! FUNCTION: TranslateAccelerator
 ! FUNCTION: TranslateAcceleratorA
-! FUNCTION: TranslateAcceleratorW
+FUNCTION: int TranslateAcceleratorW ( HWND hWnd, HACCEL hAccTable, LPMSG lpMsg ) ;
+: TranslateAccelerator TranslateAcceleratorW ; inline
+
 ! FUNCTION: TranslateMDISysAccel
 FUNCTION: BOOL TranslateMessage ( MSG* lpMsg ) ;
 

extra/windows/windows.factor

@@ -7,6 +7,7 @@ IN: windows
 
 : lo-word ( wparam -- lo ) <short> *short ; inline
 : hi-word ( wparam -- hi ) -16 shift lo-word ; inline
+: MAX_UNICODE_PATH 32768 ; inline
 
 ! You must LocalFree the return value!
 FUNCTION: void* error_message ( DWORD id ) ;

extra/xml/data/data.factor

@@ -65,7 +65,6 @@ M: attrs set-at
 
 M: attrs assoc-size length ;
 M: attrs new-assoc drop V{ } new <attrs> ;
-M: attrs assoc-find >r delegate r> assoc-find ;
 M: attrs >alist delegate >alist ;
 
 : >attrs ( assoc -- attrs )

extra/xmode/README.txt

@@ -32,10 +32,10 @@ to depend on:
   it inherits the value of the NO_WORD_SEP attribute from the previous
   RULES tag.
 
-  The Factor implementation does not duplicate this behavior.
+  The Factor implementation does not duplicate this behavior. If you
+  find a mode file which depends on this flaw, please fix it and submit
+  the changes to the jEdit project.
 
-This is still a work in progress. If you find any behavioral differences
+If you wish to contribute a new or improved mode file, please contact
-between the Factor implementation and the original jEdit code, please
+the jEdit project. Updated mode files in jEdit will be periodically
-report them as bugs. Also, if you wish to contribute a new or improved
+imported into the Factor source tree.
-mode file, please contact the jEdit project. Updated mode files in jEdit
-will be periodically imported into the Factor source tree.

extra/xmode/catalog/catalog-tests.factor

@@ -5,5 +5,7 @@ kernel sequences io ;
 [ t ] [ modes hashtable? ] unit-test
 
 [ ] [
-    modes keys [ dup print load-mode drop reset-modes ] each
+    modes keys [
+        dup print flush load-mode drop reset-modes
+    ] each
 ] unit-test

extra/xmode/catalog/catalog.factor

@@ -26,7 +26,7 @@ TAGS>
     "extra/xmode/modes/catalog" resource-path
     <file-reader> read-xml parse-modes-tag ;
 
-: modes ( -- )
+: modes ( -- assoc )
     \ modes get-global [
         load-catalog dup \ modes set-global
     ] unless* ;

extra/xmode/code2html/code2html.factor

@@ -15,8 +15,8 @@ IN: xmode.code2html
 : htmlize-line ( line-context line rules -- line-context' )
     tokenize-line htmlize-tokens ;
 
-: htmlize-lines ( lines rules -- )
+: htmlize-lines ( lines mode -- )
-    <pre> f -rot [ htmlize-line nl ] curry each drop </pre> ;
+    f swap load-mode [ htmlize-line nl ] curry reduce drop ;
 
 : default-stylesheet ( -- )
     <style>
@@ -24,22 +24,22 @@ IN: xmode.code2html
         resource-path <file-reader> contents write
     </style> ;
 
-: htmlize-file ( path -- )
+: htmlize-stream ( path stream -- )
-    dup <file-reader> lines dup empty? [ 2drop ] [
+    lines swap
-        swap dup ".html" append <file-writer> [
-            [
     <html>
         <head>
-                        <title> dup write </title>
             default-stylesheet
+            <title> dup write </title>
         </head>
         <body>
-                        over first
+            <pre>
-                        find-mode
+                over empty?
-                        load-mode
+                [ 2drop ]
-                        htmlize-lines
+                [ over first find-mode htmlize-lines ] if
+            </pre>
         </body>
-                </html>
+    </html> ;
-            ] with-html-stream
+
-        ] with-stream
+: htmlize-file ( path -- )
-    ] if ;
+    dup <file-reader> over ".html" append <file-writer>
+    [ htmlize-stream ] with-stream ;

extra/xmode/keyword-map/keyword-map.factor

@@ -22,8 +22,6 @@ M: keyword-map set-at
 M: keyword-map clear-assoc
     [ delegate clear-assoc ] keep invalid-no-word-sep ;
 
-M: keyword-map assoc-find >r delegate r> assoc-find ;
-
 M: keyword-map >alist delegate >alist ;
 
 : (keyword-map-no-word-sep)

extra/xmode/loader/loader.factor

@@ -1,11 +1,12 @@
-USING: xmode.tokens xmode.rules
+USING: xmode.tokens xmode.rules xmode.keyword-map xml.data
-xmode.keyword-map xml.data xml.utilities xml assocs
+xml.utilities xml assocs kernel combinators sequences
-kernel combinators sequences math.parser namespaces parser
+math.parser namespaces parser xmode.utilities regexp io.files ;
-xmode.utilities regexp io.files ;
 IN: xmode.loader
 
 ! Based on org.gjt.sp.jedit.XModeHandler
 
+SYMBOL: ignore-case?
+
 ! Attribute utilities
 : string>boolean ( string -- ? ) "TRUE" = ;
 
@@ -32,10 +33,13 @@ IN: xmode.loader
     swap [ at string>boolean ] curry map first3 ;
 
 : parse-literal-matcher ( tag -- matcher )
-    dup children>string swap position-attrs <matcher> ;
+    dup children>string
+    ignore-case? get <string-matcher>
+    swap position-attrs <matcher> ;
 
 : parse-regexp-matcher ( tag -- matcher )
-    dup children>string <regexp> swap position-attrs <matcher> ;
+    dup children>string ignore-case? get <regexp>
+    swap position-attrs <matcher> ;
 
 ! SPAN's children
 <TAGS: parse-begin/end-tag
@@ -130,22 +134,25 @@ RULE: MARK_FOLLOWING mark-following-rule
 RULE: MARK_PREVIOUS mark-previous-rule
     shared-tag-attrs match-type-attr literal-start ;
 
-: parse-keyword-tag
+: parse-keyword-tag ( tag keyword-map -- )
-    dup name-tag string>token swap children>string rot set-at ;
+    >r dup name-tag string>token swap children>string r> set-at ;
 
 TAG: KEYWORDS ( rule-set tag -- key value )
-    >r rule-set-keywords r>
+    ignore-case? get <keyword-map>
-    child-tags [ parse-keyword-tag ] curry* each ;
+    swap child-tags [ over parse-keyword-tag ] each
+    swap set-rule-set-keywords ;
 
 TAGS>
 
+: ?<regexp> dup [ ignore-case? get <regexp> ] when ;
+
 : (parse-rules-tag) ( tag -- rule-set )
     <rule-set>
     {
         { "SET" string>rule-set-name set-rule-set-name }
         { "IGNORE_CASE" string>boolean set-rule-set-ignore-case? }
         { "HIGHLIGHT_DIGITS" string>boolean set-rule-set-highlight-digits? }
-        { "DIGIT_RE" <regexp> set-rule-set-digit-re } ! XXX
+        { "DIGIT_RE" ?<regexp> set-rule-set-digit-re }
         { "ESCAPE" f add-escape-rule }
         { "DEFAULT" string>token set-rule-set-default }
         { "NO_WORD_SEP" f set-rule-set-no-word-sep }
@@ -153,9 +160,9 @@ TAGS>
 
 : parse-rules-tag ( tag -- rule-set )
     dup (parse-rules-tag) [
-        swap child-tags [
+        dup rule-set-ignore-case? ignore-case? [
-            parse-rule-tag
+            swap child-tags [ parse-rule-tag ] curry* each
-        ] curry* each
+        ] with-variable
     ] keep ;
 
 : merge-rule-set-props ( props rule-set -- )

extra/xmode/marker/marker-tests.factor

@@ -109,3 +109,21 @@ IN: temporary
 ] [
     f "$FOO" "shellscript" load-mode tokenize-line nip
 ] unit-test
+
+[
+    {
+        T{ token f "AND" KEYWORD1 }
+    }
+] [
+    f "AND" "pascal" load-mode tokenize-line nip
+] unit-test
+
+[
+    {
+        T{ token f "Comment {" COMMENT1 }
+        T{ token f "XXX" COMMENT1 }
+        T{ token f "}" COMMENT1 }
+    }
+] [
+    f "Comment {XXX}" "rebol" load-mode tokenize-line nip
+] unit-test

extra/xmode/marker/marker.factor

@@ -1,8 +1,8 @@
 IN: xmode.marker
 USING: kernel namespaces xmode.rules xmode.tokens
-xmode.marker.state xmode.marker.context
+xmode.marker.state xmode.marker.context xmode.utilities
-xmode.utilities xmode.catalog sequences math
+xmode.catalog sequences math assocs combinators combinators.lib
-assocs combinators combinators.lib strings regexp splitting ;
+strings regexp splitting parser-combinators ;
 
 ! Based on org.gjt.sp.jedit.syntax.TokenMarker
 
@@ -15,8 +15,8 @@ assocs combinators combinators.lib strings regexp splitting ;
         [ dup [ digit? ] contains? ]
         [
             dup [ digit? ] all? [
-                current-rule-set rule-set-digit-re dup
+                current-rule-set rule-set-digit-re
-                [ dupd 2drop f ] [ drop f ] if
+                dup [ dupd matches? ] [ drop f ] if
             ] unless*
         ]
     } && nip ;
@@ -26,7 +26,7 @@ assocs combinators combinators.lib strings regexp splitting ;
 
 : resolve-delegate ( name -- rules )
     dup string? [
-        "::" split1 [ swap load-mode at ] [ rule-sets get at ] if*
+        "::" split1 [ swap load-mode ] [ rule-sets get ] if* at
     ] when ;
 
 : rule-set-keyword-maps ( ruleset -- seq )
@@ -45,13 +45,6 @@ assocs combinators combinators.lib strings regexp splitting ;
     dup mark-number [ ] [ mark-keyword ] ?if
     [ prev-token, ] when* ;
 
-: check-terminate-char ( -- )
-    current-rule-set rule-set-terminate-char [
-        position get <= [
-            terminated? on
-        ] when
-    ] when* ;
-
 : current-char ( -- char )
     position get line get nth ;
 
@@ -69,20 +62,27 @@ M: rule match-position drop position get ;
         [ over matcher-at-word-start?     over last-offset get =    implies ]
     } && 2nip ;
 
-GENERIC: text-matches? ( position text -- match-count/f )
+: rest-of-line ( -- str )
+    line get position get tail-slice ;
 
-M: f text-matches? 2drop f ;
+GENERIC: text-matches? ( string text -- match-count/f )
 
-M: string text-matches?
+M: f text-matches?
-    ! XXX ignore case
+    2drop f ;
-    >r line get swap tail-slice r>
-    [ head? ] keep length and ;
 
-! M: regexp text-matches? ... ;
+M: string-matcher text-matches?
+    [
+        dup string-matcher-string
+        swap string-matcher-ignore-case?
+        string-head?
+    ] keep string-matcher-string length and ;
+
+M: regexp text-matches?
+    >r >string r> match-head ;
 
 : rule-start-matches? ( rule -- match-count/f )
     dup rule-start tuck swap can-match-here? [
-        position get swap matcher-text text-matches?
+        rest-of-line swap matcher-text text-matches?
     ] [
         drop f
     ] if ;
@@ -92,8 +92,8 @@ M: string text-matches?
         dup rule-start swap can-match-here? 0 and
     ] [
         dup rule-end tuck swap can-match-here? [
-            position get swap matcher-text
+            rest-of-line
-            context get line-context-end or
+            swap matcher-text context get line-context-end or
             text-matches?
         ] [
             drop f
@@ -284,8 +284,6 @@ M: mark-previous-rule handle-rule-start
 
 : mark-token-loop ( -- )
     position get line get length < [
-        check-terminate-char
-
         {
             [ check-end-delegate ]
             [ check-every-rule ]
@@ -302,8 +300,7 @@ M: mark-previous-rule handle-rule-start
 
 : unwind-no-line-break ( -- )
     context get line-context-parent [
-        line-context-in-rule rule-no-line-break?
+        line-context-in-rule rule-no-line-break? [
-        terminated? get or [
             pop-context
             unwind-no-line-break
         ] when

extra/xmode/marker/state/state.factor

@@ -16,7 +16,6 @@ SYMBOL: seen-whitespace-end?
 SYMBOL: escaped?
 SYMBOL: process-escape?
 SYMBOL: delegate-end-escaped?
-SYMBOL: terminated?
 
 : current-rule ( -- rule )
     context get line-context-in-rule ;
@@ -52,10 +51,6 @@ SYMBOL: terminated?
     dup context set
     f swap set-line-context-in-rule ;
 
-: terminal-rule-set ( -- rule-set )
-    get-rule-set rule-set-default standard-rule-set
-    push-context ;
-
 : init-token-marker ( prev-context line rules -- )
     rule-sets set
     line set

extra/xmode/rules/rules.factor

@@ -1,7 +1,11 @@
 USING: xmode.tokens xmode.keyword-map kernel
-sequences vectors assocs strings memoize ;
+sequences vectors assocs strings memoize regexp ;
 IN: xmode.rules
 
+TUPLE: string-matcher string ignore-case? ;
+
+C: <string-matcher> string-matcher
+
 ! Based on org.gjt.sp.jedit.syntax.ParserRuleSet
 TUPLE: rule-set
 name
@@ -20,12 +24,11 @@ no-word-sep
 
 : init-rule-set ( ruleset -- )
     #! Call after constructor.
-    >r H{ } clone H{ } clone V{ } clone f <keyword-map> r>
+    >r H{ } clone H{ } clone V{ } clone r>
     {
         set-rule-set-rules
         set-rule-set-props
         set-rule-set-imports
-        set-rule-set-keywords
     } set-slots ;
 
 : <rule-set> ( -- ruleset )
@@ -46,8 +49,9 @@ MEMO: standard-rule-set ( id -- ruleset )
     ] when* ;
 
 : rule-set-no-word-sep* ( ruleset -- str )
-    dup rule-set-keywords keyword-map-no-word-sep*
+    dup rule-set-no-word-sep
-    swap rule-set-no-word-sep "_" 3append ;
+    swap rule-set-keywords dup [ keyword-map-no-word-sep* ] when
+    "_" 3append ;
 
 ! Match restrictions
 TUPLE: matcher text at-line-start? at-whitespace-end? at-word-start? ;
@@ -93,20 +97,32 @@ TUPLE: mark-previous-rule ;
 TUPLE: escape-rule ;
 
 : <escape-rule> ( string -- rule )
-    f f f <matcher>
+    f <string-matcher> f f f <matcher>
     escape-rule construct-rule
     [ set-rule-start ] keep ;
 
+GENERIC: text-hash-char ( text -- ch )
+
+M: f text-hash-char ;
+
+M: string-matcher text-hash-char string-matcher-string first ;
+
+M: regexp text-hash-char drop f ;
+
 : rule-chars* ( rule -- string )
     dup rule-chars
     swap rule-start matcher-text
-    dup string? [ first add ] [ drop ] if ;
+    text-hash-char [ add ] when* ;
 
 : add-rule ( rule ruleset -- )
     >r dup rule-chars* >upper swap
     r> rule-set-rules inverted-index ;
 
 : add-escape-rule ( string ruleset -- )
+    over [
         >r <escape-rule> r>
         2dup set-rule-set-escape-rule
-    add-rule ;
+        add-rule
+    ] [
+        2drop
+    ] if ;

unmaintained/scaffold/scaffold.factor

@@ -2,7 +2,7 @@ USING: http.server help.markup help.syntax kernel prettyprint
 sequences parser namespaces words classes math tuples.private
 quotations arrays strings ;
 
-IN: furnace
+IN: furnace.scaffold
 
 TUPLE: furnace-model model ;
 C: <furnace-model> furnace-model
@@ -40,6 +40,11 @@ HELP: crud-lookup*
 { $values { "string" string } { "class" class } { "tuple" tuple } }
 "A CRUD utility function - same as crud-lookup, but always returns a tuple of the given class.  When the lookup fails, returns a tuple of the given class with all slots set to f." ;
 
+: render-page ( model template title -- )
+    [
+        [ render-component ] simple-html-document
+    ] serve-html ;
+
 : crud-page ( model template title -- )
     [ "libs/furnace/crud-templates" template-path set render-page ]
     with-scope ;

vm/os-linux-x86-64.h

@@ -1,2 +1,10 @@
+#include <ucontext.h>
+
+INLINE void *ucontext_stack_pointer(void *uap)
+{
+        ucontext_t *ucontext = (ucontext_t *)uap;
+        return (void *)ucontext->uc_mcontext.gregs[15];
+}
+
 #define UAP_PROGRAM_COUNTER(ucontext) \
 	(((ucontext_t *)(ucontext))->uc_mcontext.gregs[16])

vm/os-windows.c

@@ -98,21 +98,22 @@ const F_CHAR *vm_executable_path(void)
 	return safe_strdup(full_path);
 }
 
-DEFINE_PRIMITIVE(stat)
+void stat_not_found(void)
 {
+	dpush(F);
+	dpush(F);
+	dpush(F);
+	dpush(F);
+}
+
+void find_file_stat(F_CHAR *path)
+{
+	// FindFirstFile is the only call that can stat c:\pagefile.sys
 	WIN32_FIND_DATA st;
 	HANDLE h;
 
-	F_CHAR *path = unbox_u16_string();
+	if(INVALID_HANDLE_VALUE == (h = FindFirstFile(path, &st)))
-	if(INVALID_HANDLE_VALUE == (h = FindFirstFile(
+		stat_not_found();
-		path,
-		&st)))
-	{
-		dpush(F);
-		dpush(F);
-		dpush(F);
-		dpush(F);
-	}
 	else
 	{
 		box_boolean(st.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
@@ -129,6 +130,42 @@ DEFINE_PRIMITIVE(stat)
 	}
 }
 
+DEFINE_PRIMITIVE(stat)
+{
+	HANDLE h;
+	BY_HANDLE_FILE_INFORMATION bhfi;
+
+	F_CHAR *path = unbox_u16_string();
+	//wprintf(L"path = %s\n", path);
+	h = CreateFileW(path,
+					GENERIC_READ,
+					FILE_SHARE_READ,
+					NULL,
+					OPEN_EXISTING,
+					FILE_FLAG_BACKUP_SEMANTICS,
+					NULL);
+	if(h == INVALID_HANDLE_VALUE)
+	{
+		find_file_stat(path);
+		return;
+	}
+
+	if(!GetFileInformationByHandle(h, &bhfi))
+		stat_not_found();
+	else {
+		box_boolean(bhfi.dwFileAttributes & FILE_ATTRIBUTE_DIRECTORY);
+		dpush(tag_fixnum(0));
+		box_unsigned_8(
+			(u64)bhfi.nFileSizeLow | (u64)bhfi.nFileSizeHigh << 32);
+		u64 lo = bhfi.ftLastWriteTime.dwLowDateTime;
+		u64 hi = bhfi.ftLastWriteTime.dwHighDateTime;
+		u64 modTime = (hi << 32) + lo;
+
+		box_unsigned_8((modTime - EPOCH_OFFSET) / 10000000);
+	}
+	CloseHandle(h);
+}
+
 DEFINE_PRIMITIVE(read_dir)
 {
 	HANDLE dir;