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

core/alien/alien-docs.factor

@@ -65,8 +65,7 @@ HELP: dlclose ( dll -- )
 
 HELP: load-library
 { $values { "name" "a string" } { "dll" "a DLL handle" } }
-{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." }
+{ $description "Loads a library by logical name and outputs a handle which may be passed to " { $link dlsym } " or " { $link dlclose } ". If the library is already loaded, returns the existing handle." } ;
-{ $errors "Throws an error if the library could not be found, or if loading fails for some other reason." } ;
 
 HELP: add-library
 { $values { "name" "a string" } { "path" "a string" } { "abi" "one of " { $snippet "\"cdecl\"" } " or " { $snippet "\"stdcall\"" } } }

core/alien/alien.factor

@@ -57,7 +57,7 @@ TUPLE: library path abi dll ;
     over dup [ dlopen ] when \ library construct-boa ;
 
 : load-library ( name -- dll )
-    library library-dll ;
+    library dup [ library-dll ] when ;
 
 : add-library ( name path abi -- )
     <library> swap libraries get set-at ;

core/alien/c-types/c-types.factor

@@ -262,8 +262,8 @@ M: long-long-type box-return ( type -- )
         r> add*
     ] when ;
 
-: malloc-file-contents ( path -- alien )
+: malloc-file-contents ( path -- alien len )
-    binary file-contents malloc-byte-array ;
+    binary file-contents dup malloc-byte-array swap length ;
 
 [
     [ alien-cell ]

core/bootstrap/stage1.factor

@@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ;
                 "listener" vocab
                 [ restarts. vocab-main execute ]
                 [ die ] if*
+                1 exit
             ] recover
         ] [
             "Cannot find " write write "." print

core/continuations/continuations-docs.factor

@@ -29,7 +29,9 @@ $nl
 { $subsection ignore-errors }
 "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
 { $subsection "errors-restartable" }
-{ $subsection "errors-post-mortem" } ;
+{ $subsection "errors-post-mortem" }
+"When Factor encouters a critical error, it calls the following word:"
+{ $subsection die } ;
 
 ARTICLE: "continuations.private" "Continuation implementation details"
 "A continuation is simply a tuple holding the contents of the five stacks:"

core/debugger/debugger.factor

@@ -214,7 +214,7 @@ M: check-closed summary
     drop "Attempt to perform I/O on closed stream" ;
 
 M: check-method summary
-    drop "Invalid parameters for define-method" ;
+    drop "Invalid parameters for create-method" ;
 
 M: check-tuple summary
     drop "Invalid class for define-constructor" ;

core/definitions/definitions-tests.factor

@@ -1,10 +1,10 @@
 IN: definitions.tests
 USING: tools.test generic kernel definitions sequences
-compiler.units ;
+compiler.units words ;
 
 TUPLE: combination-1 ;
 
-M: combination-1 perform-combination 2drop { } [ ] each [ ] ;
+M: combination-1 perform-combination 2drop [ ] ;
 
 M: combination-1 make-default-method 2drop [ "No method" throw ] ;
 
@@ -13,7 +13,7 @@ SYMBOL: generic-1
 [
     generic-1 T{ combination-1 } define-generic
 
-    [ ] object \ generic-1 define-method
+    object \ generic-1 create-method [ ] define
 ] with-compilation-unit
 
 [ ] [

core/generic/generic-docs.factor

@@ -34,7 +34,7 @@ $nl
 { $subsection define-generic }
 { $subsection define-simple-generic }
 "Methods can be added to existing generic words:"
-{ $subsection define-method }
+{ $subsection create-method }
 "Method definitions can be looked up:"
 { $subsection method }
 { $subsection methods }
@@ -123,7 +123,7 @@ HELP: method
 { $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } }
 { $description "Looks up a method definition." } ;
 
-{ method define-method POSTPONE: M: } related-words
+{ method create-method POSTPONE: M: } related-words
 
 HELP: <method>
 { $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } }
@@ -140,16 +140,17 @@ HELP: order
 HELP: check-method
 { $values { "class" class } { "generic" generic } }
 { $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." }
-{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ;
+{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ;
 
 HELP: with-methods
 { $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } }
 { $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." }
 $low-level-note ;
 
-HELP: define-method
+HELP: create-method
-{ $values { "quot" quotation } { "class" class } { "generic" generic } }
+{ $values { "class" class } { "generic" generic } { "method" method-body } }
-{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
+{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." }
+{ $notes "To define a method, pass the output value to " { $link define } "." } ;
 
 HELP: implementors
 { $values { "class" class } { "seq" "a sequence of generic words" } }

core/generic/generic.factor

@@ -17,10 +17,6 @@ M: object perform-combination
     #! the method will throw an error. We don't want that.
     nip [ "Invalid method combination" throw ] curry [ ] like ;
 
-GENERIC: method-prologue ( class combination -- quot )
-
-M: object method-prologue 2drop [ ] ;
-
 GENERIC: make-default-method ( generic combination -- method )
 
 PREDICATE: word generic "combination" word-prop >boolean ;
@@ -50,55 +46,49 @@ TUPLE: check-method class generic ;
 : check-method ( class generic -- class generic )
     over class? over generic? and [
         \ check-method construct-boa throw
-    ] unless ;
+    ] unless ; inline
 
-: with-methods ( word quot -- )
+: with-methods ( generic quot -- )
     swap [ "methods" word-prop swap call ] keep make-generic ;
     inline
 
 : method-word-name ( class word -- string )
     word-name "/" rot word-name 3append ;
 
-: make-method-def ( quot class generic -- quot )
+PREDICATE: word method-body
-    "combination" word-prop method-prologue swap append ;
+    "method-generic" word-prop >boolean ;
-
-PREDICATE: word method-body "method-def" word-prop >boolean ;
 
 M: method-body stack-effect
     "method-generic" word-prop stack-effect ;
 
-: method-word-props ( quot class generic -- assoc )
+: method-word-props ( class generic -- assoc )
     [
         "method-generic" set
         "method-class" set
-        "method-def" set
     ] H{ } make-assoc ;
 
-: <method> ( quot class generic -- method )
+: <method> ( class generic -- method )
     check-method
-    [ make-method-def ] 3keep
     [ method-word-props ] 2keep
     method-word-name f <word>
-    tuck set-word-props
+    [ set-word-props ] keep ;
-    dup rot define ;
 
-: redefine-method ( quot class generic -- )
+: reveal-method ( method class generic -- )
-    [ method swap "method-def" set-word-prop ] 3keep
+    [ set-at ] with-methods ;
-    [ make-method-def ] 2keep
-    method swap define ;
 
-: define-method ( quot class generic -- )
+: create-method ( class generic -- method )
-    >r bootstrap-word r>
+    2dup method dup [
-    2dup method [
+        2nip
-        redefine-method
     ] [
-        [ <method> ] 2keep
+        drop [ <method> dup ] 2keep reveal-method
-        [ set-at ] with-methods
     ] if ;
 
+: <default-method> ( generic combination -- method )
+    object bootstrap-word pick <method>
+    [ -rot make-default-method define ] keep ;
+
 : define-default-method ( generic combination -- )
-    dupd make-default-method object bootstrap-word pick <method>
+    dupd <default-method> "default-method" set-word-prop ;
-    "default-method" set-word-prop ;
 
 ! Definition protocol
 M: method-spec where
@@ -108,11 +98,10 @@ M: method-spec set-where
     first2 method set-where ;
 
 M: method-spec definer
-    drop \ M: \ ; ;
+    first2 method definer ;
 
 M: method-spec definition
-    first2 method dup
+    first2 method definition ;
-    [ "method-def" word-prop ] when ;
 
 : forget-method ( class generic -- )
     check-method
@@ -125,9 +114,6 @@ M: method-spec forget*
 M: method-body definer
     drop \ M: \ ; ;
 
-M: method-body definition
-    "method-def" word-prop ;
-
 M: method-body forget*
     dup "method-class" word-prop
     swap "method-generic" word-prop

core/generic/math/math.factor

@@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ;
 
 : applicable-method ( generic class -- quot )
     over method
-    [ word-def ]
+    [ 1quotation ]
     [ default-math-method ] ?if ;
 
 : object-method ( generic -- quot )

core/generic/standard/standard.factor

@@ -8,10 +8,6 @@ IN: generic.standard
 
 TUPLE: standard-combination # ;
 
-M: standard-combination method-prologue
-    standard-combination-# object
-    <array> swap add* [ declare ] curry ;
-
 C: <standard-combination> standard-combination
 
 SYMBOL: (dispatch#)

core/io/files/files-tests.factor

@@ -1,6 +1,10 @@
 IN: io.files.tests
 USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
 
+[ ] [ "blahblah" temp-file dup exists? [ delete-directory ] [ drop ] if ] unit-test
+[ ] [ "blahblah" temp-file make-directory ] unit-test
+[ t ] [ "blahblah" temp-file directory? ] unit-test
+
 [ "passwd" ] [ "/etc/passwd" file-name ] unit-test
 [ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
 [ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
@@ -123,3 +127,7 @@ USING: tools.test io.files io threads kernel continuations io.encodings.ascii ;
 [ ] [ "copy-tree-test" temp-file delete-tree ] unit-test
 
 [ t ] [ cwd "misc" resource-path [ ] with-directory cwd = ] unit-test
+
+[ ] [ "append-test" temp-file dup exists? [ delete-file ] [ drop ] if ] unit-test
+
+[ ] [ "append-test" ascii <file-appender> dispose ] unit-test

core/io/files/files.factor

@@ -86,15 +86,11 @@ SYMBOL: +unknown+
 : stat ( path -- directory? permissions length modified )
     normalize-pathname (stat) ;
 
-! : file-length ( path -- n ) stat drop 2nip ;
-
 : file-modified ( path -- n ) stat >r 3drop r> ;
 
-! : file-permissions ( path -- perm ) stat 2drop nip ;
-
 : exists? ( path -- ? ) file-modified >boolean ;
 
-: directory? ( path -- ? ) stat 3drop ;
+: directory? ( path -- ? ) file-info file-info-type +directory+ = ;
 
 ! Current working directory
 HOOK: cd io-backend ( path -- )
@@ -220,10 +216,7 @@ M: pathname <=> [ pathname-string ] compare ;
     >r <file-reader> r> with-stream ; inline
 
 : file-contents ( path encoding -- str )
-    dupd [ file-info file-info-size read ] with-file-reader ;
+    <file-reader> contents ;
-
-! : file-contents ( path encoding -- str )
-!     dupd [ file-length read ] with-file-reader ;
 
 : with-file-writer ( path encoding quot -- )
     >r <file-writer> r> with-stream ; inline

core/io/io.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2003, 2007 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: hashtables generic kernel math namespaces sequences strings
+USING: hashtables generic kernel math namespaces sequences
-    continuations assocs io.styles sbufs ;
+continuations assocs io.styles ;
 IN: io
 
 GENERIC: stream-readln ( stream -- str )
@@ -88,4 +88,6 @@ SYMBOL: stderr
     [ [ readln dup ] [ ] [ drop ] unfold ] with-stream ;
 
 : contents ( stream -- str )
-    2048 <sbuf> [ stream-copy ] keep >string ;
+    [
+        [ 65536 read dup ] [ ] [ drop ] unfold concat f like
+    ] with-stream  ;

core/kernel/kernel-docs.factor

@@ -429,7 +429,14 @@ $nl
 { $code "[ X ] [ Y ] ?if" "dup [ nip X ] [ drop Y ] if" } } ;
 
 HELP: die
-{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." } ;
+{ $description "Starts the front-end processor (FEP), which is a low-level debugger which can inspect memory addresses and the like. The FEP is also entered when a critical error occurs." }
+{ $notes
+    "The term FEP originates from the Lisp machines of old. According to the Jargon File,"
+    $nl
+    { $strong "fepped out" } " /fept owt/ " { $emphasis "adj." }  " The Symbolics 3600 LISP Machine has a Front-End Processor called a `FEP' (compare sense 2 of box). When the main processor gets wedged, the FEP takes control of the keyboard and screen. Such a machine is said to have `fepped out' or `dropped into the fep'." 
+    $nl
+    { $url "http://www.jargon.net/jargonfile/f/feppedout.html" }
+} ;
 
 HELP: (clone) ( obj -- newobj )
 { $values { "obj" object } { "newobj" "a shallow copy" } }

core/optimizer/specializers/specializers.factor

@@ -24,20 +24,40 @@ IN: optimizer.specializers
         \ dispatch ,
     ] [ ] make ;
 
-: specializer-methods ( quot word -- default alist )
+: specializer-cases ( quot word -- default alist )
     dup [ array? ] all? [ 1array ] unless [
         [ make-specializer ] keep
         [ declare ] curry pick append
     ] { } map>assoc ;
 
+: method-declaration ( method -- quot )
+    dup "method-generic" word-prop dispatch# object <array>
+    swap "method-class" word-prop add* ;
+
+: specialize-method ( quot method -- quot' )
+    method-declaration [ declare ] curry swap append ;
+
+: specialize-quot ( quot specializer -- quot' )
+    dup { number } = [
+        drop tag-specializer
+    ] [
+        specializer-cases alist>quot
+    ] if ;
+
+: standard-method? ( method -- ? )
+    dup method-body? [
+        "method-generic" word-prop standard-generic?
+    ] [ drop f ] if ;
+
 : specialized-def ( word -- quot )
-    dup word-def swap "specializer" word-prop [
+    dup word-def swap {
-        dup { number } = [
+        { [ dup standard-method? ] [ specialize-method ] }
-            drop tag-specializer
+        {
-        ] [
+            [ dup "specializer" word-prop ]
-            specializer-methods alist>quot
+            [ "specializer" word-prop specialize-quot ]
-        ] if
+        }
-    ] when* ;
+        { [ t ] [ drop ] }
+    } cond ;
 
 : specialized-length ( specializer -- n )
     dup [ array? ] all? [ first ] when length ;

core/parser/parser.factor

@@ -215,9 +215,6 @@ SYMBOL: in
 : set-in ( name -- )
     check-vocab-string dup in set create-vocab (use+) ;
 
-: create-in ( string -- word )
-    in get create dup set-word dup save-location ;
-
 TUPLE: unexpected want got ;
 
 : unexpected ( want got -- * )
@@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof
 : parse-tokens ( end -- seq )
     100 <vector> swap (parse-tokens) >array ;
 
+: create-in ( string -- word )
+    in get create dup set-word dup save-location ;
+
 : CREATE ( -- word ) scan create-in ;
 
+: CREATE-GENERIC ( -- word ) CREATE dup reset-word ;
+
+: CREATE-WORD ( -- word ) CREATE dup reset-generic ;
+
 : create-class-in ( word -- word )
     in get create
     dup save-class-location
@@ -284,6 +288,12 @@ M: no-word summary
         ] ?if
     ] when ;
 
+: create-method-in ( class generic -- method )
+    create-method f set-word dup save-location ;
+
+: CREATE-METHOD ( -- method )
+    scan-word bootstrap-word scan-word create-method-in ;
+
 TUPLE: staging-violation word ;
 
 : staging-violation ( word -- * )
@@ -355,7 +365,9 @@ TUPLE: bad-number ;
 : parse-definition ( -- quot )
     \ ; parse-until >quotation ;
 
-: (:) CREATE dup reset-generic parse-definition ;
+: (:) CREATE-WORD parse-definition ;
+
+: (M:) CREATE-METHOD parse-definition ;
 
 GENERIC: expected>string ( obj -- str )
 

core/slots/slots.factor

@@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ;
 C: <slot-spec> slot-spec
 
 : define-typecheck ( class generic quot -- )
-    over define-simple-generic -rot define-method ;
+    over define-simple-generic
+    >r create-method r> define ;
 
 : define-slot-word ( class slot word quot -- )
     rot >fixnum add* define-typecheck ;

core/syntax/syntax.factor

@@ -97,7 +97,7 @@ IN: bootstrap.syntax
     "parsing" [ word t "parsing" set-word-prop ] define-syntax
 
     "SYMBOL:" [
-        CREATE dup reset-generic define-symbol
+        CREATE-WORD define-symbol
     ] define-syntax
 
     "DEFER:" [
@@ -111,31 +111,26 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "GENERIC:" [
-        CREATE dup reset-word
+        CREATE-GENERIC define-simple-generic
-        define-simple-generic
     ] define-syntax
 
     "GENERIC#" [
-        CREATE dup reset-word
+        CREATE-GENERIC
         scan-word <standard-combination> define-generic
     ] define-syntax
 
     "MATH:" [
-        CREATE dup reset-word
+        CREATE-GENERIC
         T{ math-combination } define-generic
     ] define-syntax
 
     "HOOK:" [
-        CREATE dup reset-word scan-word
+        CREATE-GENERIC scan-word
         <hook-combination> define-generic
     ] define-syntax
 
     "M:" [
-        f set-word
+        (M:) define
-        location >r
-        scan-word bootstrap-word scan-word
-        [ parse-definition -rot define-method ] 2keep
-        2array r> remember-definition
     ] define-syntax
 
     "UNION:" [
@@ -163,7 +158,7 @@ IN: bootstrap.syntax
     ] define-syntax
 
     "C:" [
-        CREATE dup reset-generic
+        CREATE-WORD
         scan-word dup check-tuple
         [ construct-boa ] curry define-inline
     ] define-syntax

core/threads/threads-tests.factor

@@ -14,3 +14,5 @@ yield
 [ 3 ] [
     [ 3 swap resume-with ] "Test suspend" suspend
 ] unit-test
+
+[ f ] [ f get-global ] unit-test

core/threads/threads.factor

@@ -32,8 +32,6 @@ mailbox variables sleep-entry ;
 
 : threads 41 getenv ;
 
-threads global [ H{ } assoc-like ] change-at
-
 : thread ( id -- thread ) threads at ;
 
 : thread-registered? ( thread -- ? )

core/tuples/tuples-docs.factor

@@ -12,6 +12,22 @@ ARTICLE: "tuple-constructors" "Constructors and slots"
 $nl
 "A shortcut for defining BOA constructors:"
 { $subsection POSTPONE: C: }
+"Examples of constructors:"
+{ $code
+    "TUPLE: color red green blue alpha ;"
+    ""
+    "C: <rgba> rgba"
+    ": <rgba> color construct-boa ; ! identical to above"
+    ""
+    ": <rgb>"
+    "    { set-color-red set-color-green set-color-blue }"
+    "    color construct ;"
+    ": <rgb> f <rgba> ; ! identical to above"
+    ""
+    ": <color> construct-empty ;"
+    ": <color> { } color construct ; ! identical to above"
+    ": <color> f f f f <rgba> ; ! identical to above"
+}
 "After construction, slots are read and written using various automatically-defined words with names of the form " { $snippet { $emphasis "class-slot" } } " and " { $snippet "set-" { $emphasis "class-slot" } } "." ;
 
 ARTICLE: "tuple-delegation" "Delegation"
@@ -48,8 +64,8 @@ ARTICLE: "tuples" "Tuples"
 "Tuples are user-defined classes composed of named slots. A parsing word defines tuple classes:"
 { $subsection POSTPONE: TUPLE: }
 "An example:"
-{ $code "TUPLE: person name address phone ;" }
+{ $code "TUPLE: person name address phone ;" "C: <person> person" }
-"This defines a class word named " { $snippet "person" } ", along with a predicate " { $snippet "person?" } ", and the following reader/writer words:"
+"This defines a class word named " { $snippet "person" } ", a predicate " { $snippet "person?" } ", a constructor named " { $snippet "<person>" } ", and the following reader/writer words:"
 { $table
     { "Reader" "Writer" }
     { { $snippet "person-name" }    { $snippet "set-person-name" }    }

core/words/words.factor

@@ -68,7 +68,7 @@ SYMBOL: bootstrapping?
 : crossref? ( word -- ? )
     {
         { [ dup "forgotten" word-prop ] [ f ] }
-        { [ dup "method-def" word-prop ] [ t ] }
+        { [ dup "method-generic" word-prop ] [ t ] }
         { [ dup word-vocabulary ] [ t ] }
         { [ t ] [ f ] }
     } cond nip ;

extra/assocs/lib/lib.factor

@@ -1,4 +1,5 @@
-USING: assocs kernel vectors sequences namespaces ;
+USING: arrays assocs kernel vectors sequences namespaces
+random math.parser ;
 IN: assocs.lib
 
 : >set ( seq -- hash )
@@ -35,3 +36,13 @@ IN: assocs.lib
     [ with each ] curry assoc-each ; inline
 
 : insert ( value variable -- ) namespace insert-at ;
+
+: 2seq>assoc ( keys values exemplar -- assoc )
+    >r 2array flip r> assoc-like ;
+
+: generate-key ( assoc -- str )
+    >r random-256 >hex r>
+    2dup key? [ nip generate-key ] [ drop ] if ;
+
+: set-at-unique ( value assoc -- key )
+    dup generate-key [ swap set-at ] keep ;

extra/bootstrap/tools/tools.factor

@@ -13,5 +13,6 @@ USING: vocabs.loader sequences ;
     "tools.threads"
     "tools.vocabs"
     "tools.vocabs.browser"
+    "tools.vocabs.monitor"
     "editors"
 } [ require ] each

extra/builder/benchmark/benchmark.factor

@@ -4,10 +4,12 @@ USING: kernel continuations arrays assocs sequences sorting math
 
 IN: builder.benchmark
 
-: passing-benchmarks ( table -- table )
+! : passing-benchmarks ( table -- table )
-  [ second first2 number? swap number? and ] subset ;
+!   [ second first2 number? swap number? and ] subset ;
 
-: simplify-table ( table -- table ) [ first2 second 2array ] map ;
+: passing-benchmarks ( table -- table ) [ second number? ] subset ;
+
+! : simplify-table ( table -- table ) [ first2 second 2array ] map ;
 
 : benchmark-difference ( old-table benchmark-result -- result-diff )
   first2 >r
@@ -17,7 +19,7 @@ IN: builder.benchmark
   2array ;
 
 : compare-tables ( old new -- table )
-  [ passing-benchmarks simplify-table ] 2apply
+  [ passing-benchmarks ] 2apply
   [ benchmark-difference ] with map ;
 
 : benchmark-deltas ( -- table )

extra/builder/builder.factor

@@ -134,7 +134,9 @@ SYMBOL: build-status
       "Did not pass load-everything: " print "load-everything-vocabs" cat
       
       "Did not pass test-all: "        print "test-all-vocabs"        cat
-      "test-all-vocabs" eval-file test-failures.
+                                             "test-failures"          cat
+      
+!       "test-failures" eval-file test-failures.
       
       "help-lint results:"             print "help-lint"              cat
 

extra/cairo-demo/cairo-demo.factor

@@ -6,7 +6,7 @@
 !  http://cairographics.org/samples/text/
 
 
-USING: cairo math math.constants byte-arrays kernel ui ui.render
+USING: cairo.ffi math math.constants byte-arrays kernel ui ui.render
            ui.gadgets opengl.gl ;
 
 IN: cairo-demo
@@ -23,13 +23,15 @@ IN: cairo-demo
 TUPLE: cairo-gadget image-array cairo-t ;
 
 M: cairo-gadget draw-gadget* ( gadget -- )
-   0 0 glRasterPos2i
+    0 0 glRasterPos2i
-   1.0 -1.0 glPixelZoom
+    1.0 -1.0 glPixelZoom
-   >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
+    >r 384 256 GL_RGBA GL_UNSIGNED_BYTE r>
-   cairo-gadget-image-array glDrawPixels ;
+    cairo-gadget-image-array glDrawPixels ;
 
 : create-surface ( gadget -- cairo_surface_t )
-  make-image-array dup >r swap set-cairo-gadget-image-array r> convert-array-to-surface ;
+    make-image-array
+    [ swap set-cairo-gadget-image-array ] keep
+    convert-array-to-surface ;
 
 : init-cairo ( gadget -- cairo_t )
    create-surface cairo_create ;
@@ -56,7 +58,7 @@ M: cairo-gadget pref-dim* drop { 384 256 0 } ;
   cairo_fill ;
 
 M: cairo-gadget graft* ( gadget -- )
-   dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
+  dup dup init-cairo swap set-cairo-gadget-cairo-t draw-hello-world ;
 
 M: cairo-gadget ungraft* ( gadget -- )
    cairo-gadget-cairo-t cairo_destroy ;

extra/cairo/authors.txt

@@ -1 +1,2 @@
 Sampo Vuori
+Doug Coleman

extra/cairo/ffi/ffi.factor

@@ -10,7 +10,7 @@
 
 USING: alien alien.syntax combinators system ;
 
-IN: cairo
+IN: cairo.ffi
 
 << "cairo" {
         { [ win32? ] [ "cairo.dll" ] }

extra/cairo/lib/lib.factor

@@ -0,0 +1,40 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types cairo.ffi continuations destructors
+kernel libc locals math combinators.cleave shuffle new-slots
+accessors ;
+IN: cairo.lib
+
+TUPLE: cairo-t alien ;
+C: <cairo-t> cairo-t
+M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
+: cairo-t-destroy-always ( alien -- ) <cairo-t> add-always-destructor ;
+: cairo-t-destroy-later ( alien -- ) <cairo-t> add-error-destructor ;
+    
+TUPLE: cairo-surface-t alien ;
+C: <cairo-surface-t> cairo-surface-t
+M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
+
+: cairo-surface-t-destroy-always ( alien -- )
+    <cairo-surface-t> add-always-destructor ;
+
+: cairo-surface-t-destroy-later ( alien -- )
+    <cairo-surface-t> add-error-destructor ;
+
+: cairo-surface>array ( surface -- cairo-t byte-array )
+    [
+        dup
+        [ drop CAIRO_FORMAT_ARGB32 ]
+        [ cairo_image_surface_get_width ]
+        [ cairo_image_surface_get_height ] tri
+        over 4 *
+        2dup * [
+            malloc dup free-always [
+                5 -nrot cairo_image_surface_create_for_data
+                dup cairo-surface-t-destroy-always
+                cairo_create dup cairo-t-destroy-later
+                [ swap 0 0 cairo_set_source_surface ] keep
+                dup cairo_paint
+            ] keep
+        ] keep memory>byte-array
+    ] with-destructors ;

extra/cairo/png/png.factor

@@ -0,0 +1,45 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators.cleave kernel new-slots
+accessors math ui.gadgets ui.render opengl.gl byte-arrays
+namespaces opengl cairo.ffi cairo.lib ;
+IN: cairo.png
+
+TUPLE: png surface width height cairo-t array ;
+TUPLE: png-gadget png ;
+
+: <png> ( path -- png )
+    cairo_image_surface_create_from_png
+    dup [ cairo_image_surface_get_width ]
+    [ cairo_image_surface_get_height ] [ ] tri
+    cairo-surface>array png construct-boa ;
+
+: write-png ( png path -- )
+    >r png-surface r>
+    cairo_surface_write_to_png
+    zero? [ "write png failed" throw ] unless ;
+
+: <png-gadget> ( path -- gadget )
+    png-gadget construct-gadget swap
+    <png> >>png ;
+
+M: png-gadget pref-dim* ( gadget -- )
+    png>>
+    [ width>> ] [ height>> ] bi 2array ;
+
+M: png-gadget draw-gadget* ( gadget -- )
+    origin get [
+        0 0 glRasterPos2i
+        1.0 -1.0 glPixelZoom
+        png>>
+        [ width>> ]
+        [ height>> GL_RGBA GL_UNSIGNED_BYTE ]
+        [ array>> ] tri
+        glDrawPixels
+    ] with-translation ;
+
+M: png-gadget graft* ( gadget -- )
+    drop ;
+
+M: png-gadget ungraft* ( gadget -- )
+    png>> surface>> cairo_destroy ;

extra/combinators/cleave/cleave.factor

@@ -70,3 +70,29 @@ MACRO: spread ( seq -- )
   swap
     [ [ r> ] swap append ] map concat
   append ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Cleave into array
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+USING: words quotations fry arrays.lib ;
+
+: >quot ( obj -- quot ) dup word? [ 1quotation ] when ;
+
+: >quots ( seq -- seq ) [ >quot ] map ;
+
+MACRO: <arr> ( seq -- )
+  [ >quots ] [ length ] bi
+ '[ , cleave , narray ] ;
+
+MACRO: <2arr> ( seq -- )
+  [ >quots ] [ length ] bi
+ '[ , 2cleave , narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+! Spread into array
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+MACRO: <arr*> ( seq -- )
+  [ >quots ] [ length ] bi
+ '[ , spread , narray ] ;

extra/db/db-tests.factor

@@ -0,0 +1,5 @@
+IN: db.tests
+USING: tools.test db kernel ;
+
+{ 1 0 } [ [ drop ] query-each ] must-infer-as
+{ 1 1 } [ [ ] query-map ] must-infer-as

extra/db/db.factor

@@ -33,6 +33,19 @@ HOOK: db-close db ( handle -- )
 TUPLE: statement handle sql in-params out-params bind-params bound? ;
 TUPLE: simple-statement ;
 TUPLE: prepared-statement ;
+TUPLE: nonthrowable-statement ;
+: make-nonthrowable ( obj -- obj' )
+    dup sequence? [
+        [ make-nonthrowable ] map
+    ] [
+        nonthrowable-statement construct-delegate
+    ] if ;
+
+MIXIN: throwable-statement
+INSTANCE: statement throwable-statement
+INSTANCE: simple-statement throwable-statement
+INSTANCE: prepared-statement throwable-statement
+
 TUPLE: result-set sql in-params out-params handle n max ;
 : <statement> ( sql in out -- statement )
     { (>>sql) (>>in-params) (>>out-params) } statement construct ;
@@ -50,13 +63,22 @@ GENERIC# row-column-typed 1 ( result-set column -- sql )
 GENERIC: advance-row ( result-set -- )
 GENERIC: more-rows? ( result-set -- ? )
 
-: execute-statement ( statement -- )
+GENERIC: execute-statement ( statement -- )
+
+M: throwable-statement execute-statement ( statement -- )
     dup sequence? [
         [ execute-statement ] each
     ] [
         query-results dispose
     ] if ;
 
+M: nonthrowable-statement execute-statement ( statement -- )
+    dup sequence? [
+        [ execute-statement ] each
+    ] [
+        [ query-results dispose ] [ 2drop ] recover
+    ] if ;
+
 : bind-statement ( obj statement -- )
     swap >>bind-params
     [ bind-statement* ] keep

extra/db/postgresql/lib/lib.factor

@@ -73,7 +73,7 @@ IN: db.postgresql.lib
         sql-spec-type {
             { FACTOR-BLOB [
                 dup [
-                    binary [ serialize ] with-byte-writer
+                    object>bytes
                     malloc-byte-array/length ] [ 0 ] if ] }
             { BLOB [
                 dup [ malloc-byte-array/length ] [ 0 ] if ] }
@@ -164,7 +164,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
         { BLOB [ pq-get-blob ] }
         { FACTOR-BLOB [
             pq-get-blob
-            dup [ binary [ deserialize ] with-byte-reader ] when ] }
+            dup [ bytes>object ] when ] }
         [ no-sql-type ]
     } case ;
     ! PQgetlength PQgetisnull

extra/db/postgresql/postgresql.factor

@@ -10,6 +10,7 @@ IN: db.postgresql
 
 TUPLE: postgresql-db host port pgopts pgtty db user pass ;
 TUPLE: postgresql-statement ;
+INSTANCE: postgresql-statement throwable-statement
 TUPLE: postgresql-result-set ;
 : <postgresql-statement> ( statement in out -- postgresql-statement )
     <statement>
@@ -119,8 +120,8 @@ M: postgresql-db bind% ( spec -- )
 
 : postgresql-make ( class quot -- )
     >r sql-props r>
-    [ postgresql-counter off ] swap compose
+    [ postgresql-counter off call ] { "" { } { } } nmake
-    { "" { } { } } nmake <postgresql-statement> ;
+    <postgresql-statement> ; inline
 
 : create-table-sql ( class -- statement )
     [
@@ -194,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
         ");" 0%
     ] postgresql-make ;
 
-M: postgresql-db <insert-assigned-statement> ( class -- statement )
+M: postgresql-db <insert-nonnative-statement> ( class -- statement )
     [
         "insert into " 0% 0%
         "(" 0%

extra/db/sqlite/ffi/ffi.factor

@@ -127,6 +127,6 @@ FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: sqlite3_int64 sqlite3_column_int64 ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: double sqlite3_column_double ( sqlite3_stmt* pStmt, int col ) ;
-FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
 FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;

extra/db/sqlite/lib/lib.factor

@@ -94,7 +94,7 @@ IN: db.sqlite.lib
         { TIMESTAMP [ sqlite-bind-text-by-name ] }
         { BLOB [ sqlite-bind-blob-by-name ] }
         { FACTOR-BLOB [
-            binary [ serialize ] with-byte-writer
+            object>bytes
             sqlite-bind-blob-by-name
         ] }
         { +native-id+ [ sqlite-bind-int-by-name ] }
@@ -102,17 +102,12 @@ IN: db.sqlite.lib
         [ no-sql-type ]
     } case ;
 
-: sqlite-finalize ( handle -- )
+: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
-    sqlite3_finalize sqlite-check-result ;
+: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
-
+: sqlite-#columns ( query -- int ) sqlite3_column_count ;
-: sqlite-reset ( handle -- )
+: sqlite-column ( handle index -- string ) sqlite3_column_text ;
-    sqlite3_reset sqlite-check-result ;
+: sqlite-column-name ( handle index -- string ) sqlite3_column_name ;
-
+: sqlite-column-type ( handle index -- string ) sqlite3_column_type ;
-: sqlite-#columns ( query -- int )
-    sqlite3_column_count ;
-
-: sqlite-column ( handle index -- string )
-    sqlite3_column_text ;
 
 : sqlite-column-blob ( handle index -- byte-array/f )
     [ sqlite3_column_bytes ] 2keep
@@ -126,6 +121,7 @@ IN: db.sqlite.lib
     dup array? [ first ] when
     {
         { +native-id+ [ sqlite3_column_int64 ] }
+        { +random-id+ [ sqlite3_column_int64 ] }
         { INTEGER [ sqlite3_column_int ] }
         { BIG-INTEGER [ sqlite3_column_int64 ] }
         { DOUBLE [ sqlite3_column_double ] }
@@ -138,7 +134,7 @@ IN: db.sqlite.lib
         { BLOB [ sqlite-column-blob ] }
         { FACTOR-BLOB [
             sqlite-column-blob
-            dup [ binary [ deserialize ] with-byte-reader ] when
+            dup [ bytes>object ] when
         ] }
         ! { NULL [ 2drop f ] }
         [ no-sql-type ]
@@ -147,7 +143,7 @@ IN: db.sqlite.lib
 : sqlite-row ( handle -- seq )
     dup sqlite-#columns [ sqlite-column ] with map ;
 
-: sqlite-step-has-more-rows? ( step-result -- bool )
+: sqlite-step-has-more-rows? ( prepared -- bool )
     dup SQLITE_ROW =  [
         drop t
     ] [

extra/db/sqlite/sqlite.factor

@@ -6,6 +6,7 @@ prettyprint sequences strings tuples alien.c-types
 continuations db.sqlite.lib db.sqlite.ffi db.tuples
 words combinators.lib db.types combinators
 combinators.cleave io namespaces.lib ;
+USE: tools.walker
 IN: db.sqlite
 
 TUPLE: sqlite-db path ;
@@ -17,15 +18,12 @@ M: sqlite-db db-open ( db -- )
     dup sqlite-db-path sqlite-open <db>
     swap set-delegate ;
 
-M: sqlite-db db-close ( handle -- )
+M: sqlite-db db-close ( handle -- ) sqlite-close ;
-    sqlite-close ;
-
 M: sqlite-db dispose ( db -- ) dispose-db ;
-
+: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
-: with-sqlite ( path quot -- )
-    sqlite-db swap with-db ; inline
 
 TUPLE: sqlite-statement ;
+INSTANCE: sqlite-statement throwable-statement
 
 TUPLE: sqlite-result-set has-more? ;
 
@@ -38,12 +36,20 @@ M: sqlite-db <prepared-statement> ( str in out -- obj )
         set-statement-in-params
         set-statement-out-params
     } statement construct
-    db get db-handle over statement-sql sqlite-prepare
-    over set-statement-handle
     sqlite-statement construct-delegate ;
 
+: sqlite-maybe-prepare ( statement -- statement )
+    dup statement-handle [
+        [
+            delegate
+            db get db-handle over statement-sql sqlite-prepare
+            swap set-statement-handle
+        ] keep
+    ] unless ;
+
 M: sqlite-statement dispose ( statement -- )
-    statement-handle sqlite-finalize ;
+    statement-handle
+    [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
 
 M: sqlite-result-set dispose ( result-set -- )
     f swap set-result-set-handle ;
@@ -52,9 +58,11 @@ M: sqlite-result-set dispose ( result-set -- )
     swap [ first3 sqlite-bind-type ] with each ;
 
 : reset-statement ( statement -- )
+    sqlite-maybe-prepare
     statement-handle sqlite-reset ;
 
 M: sqlite-statement bind-statement* ( statement -- )
+    sqlite-maybe-prepare
     dup statement-bound? [ dup reset-statement ] when
     [ statement-bind-params ] [ statement-handle ] bi
     sqlite-bind ;
@@ -95,21 +103,17 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
     sqlite-result-set-has-more? ;
 
 M: sqlite-statement query-results ( query -- result-set )
+    sqlite-maybe-prepare
     dup statement-handle sqlite-result-set <result-set>
     dup advance-row ;
 
-M: sqlite-db begin-transaction ( -- )
+M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
-    "BEGIN" sql-command ;
+M: sqlite-db commit-transaction ( -- ) "COMMIT" sql-command ;
-
+M: sqlite-db rollback-transaction ( -- ) "ROLLBACK" sql-command ;
-M: sqlite-db commit-transaction ( -- )
-    "COMMIT" sql-command ;
-
-M: sqlite-db rollback-transaction ( -- )
-    "ROLLBACK" sql-command ;
 
 : sqlite-make ( class quot -- )
     >r sql-props r>
-    { "" { } { } } nmake <simple-statement> ;
+    { "" { } { } } nmake <simple-statement> ; inline
 
 M: sqlite-db create-sql-statement ( class -- statement )
     [
@@ -123,9 +127,7 @@ M: sqlite-db create-sql-statement ( class -- statement )
     ] sqlite-make ;
 
 M: sqlite-db drop-sql-statement ( class -- statement )
-    [
+    [ "drop table " 0% 0% ";" 0% drop ] sqlite-make ;
-        "drop table " 0% 0% ";" 0% drop
-    ] sqlite-make ;
 
 M: sqlite-db <insert-native-statement> ( tuple -- statement )
     [
@@ -138,7 +140,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
         ");" 0%
     ] sqlite-make ;
 
-M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
+M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
     <insert-native-statement> ;
 
 : where-primary-key% ( specs -- )
@@ -188,6 +190,8 @@ M: sqlite-db modifier-table ( -- hashtable )
     H{
         { +native-id+ "primary key" }
         { +assigned-id+ "primary key" }
+        { +random-id+ "primary key" }
+        ! { +nonnative-id+ "primary key" }
         { +autoincrement+ "autoincrement" }
         { +unique+ "unique" }
         { +default+ "default" }
@@ -195,10 +199,9 @@ M: sqlite-db modifier-table ( -- hashtable )
         { +not-null+ "not null" }
     } ;
 
-M: sqlite-db compound-modifier ( str obj -- newstr )
+M: sqlite-db compound-modifier ( str obj -- str' ) compound-type ;
-    compound-type ;
 
-M: sqlite-db compound-type ( str seq -- newstr )
+M: sqlite-db compound-type ( str seq -- str' )
     over {
         { "default" [ first number>string join-space ] }
         [ 2drop ] !  "no sqlite compound data type" 3array throw ]
@@ -207,6 +210,7 @@ M: sqlite-db compound-type ( str seq -- newstr )
 M: sqlite-db type-table ( -- assoc )
     H{
         { +native-id+ "integer primary key" }
+        { +random-id+ "integer primary key" }
         { INTEGER "integer" }
         { TEXT "text" }
         { VARCHAR "text" }
@@ -219,5 +223,4 @@ M: sqlite-db type-table ( -- assoc )
         { FACTOR-BLOB "blob" }
     } ;
 
-M: sqlite-db create-type-table
+M: sqlite-db create-type-table ( symbol -- str ) type-table ;
-    type-table ;

extra/db/tuples/tuples-tests.factor

@@ -9,7 +9,7 @@ IN: db.tuples.tests
 TUPLE: person the-id the-name the-number the-real
 ts date time blob factor-blob ;
 
-: <person> ( name age real ts date time blob -- person )
+: <person> ( name age real ts date time blob factor-blob -- person )
     {
         set-person-the-name
         set-person-the-number
@@ -190,11 +190,11 @@ TUPLE: annotation n paste-id summary author mode contents ;
 : test-postgresql ( -- )
 >r { "localhost" "postgres" "foob" "factor-test" } postgresql-db r> with-db ;
 
-[ native-person-schema test-tuples ] test-sqlite
+: test-repeated-insert
-[ assigned-person-schema test-tuples ] test-sqlite
+    [ ] [ person ensure-table ] unit-test
-
+    
-! [ native-person-schema test-tuples ] test-postgresql
+    [ ] [ person1 get insert-tuple ] unit-test
-! [ assigned-person-schema test-tuples ] test-postgresql
+    [ person1 get insert-tuple ] must-fail ;
 
 TUPLE: serialize-me id data ;
 
@@ -239,3 +239,34 @@ TUPLE: exam id name score ;
     ;
 
 ! [ test-ranges ] test-sqlite
+
+TUPLE: secret n message ;
+C: <secret> secret
+
+: test-random-id
+    secret "SECRET"
+    {
+        { "n" "ID" +random-id+ }
+        { "message" "MESSAGE" TEXT }
+    } define-persistent
+
+    [ ] [ secret ensure-table ] unit-test
+    [ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
+    [ ] [ T{ secret } select-tuples ] unit-test
+    ;
+
+
+
+! [ test-random-id ] test-sqlite
+ [ native-person-schema test-tuples ] test-sqlite
+ [ assigned-person-schema test-tuples ] test-sqlite
+! [ assigned-person-schema test-repeated-insert ] test-sqlite
+! [ native-person-schema test-tuples ] test-postgresql
+! [ assigned-person-schema test-tuples ] test-postgresql
+! [ assigned-person-schema test-repeated-insert ] test-postgresql
+
+! \ insert-tuple must-infer
+! \ update-tuple must-infer
+! \ delete-tuple must-infer
+! \ select-tuple must-infer
+! \ define-persistent must-infer

extra/db/tuples/tuples.factor

@@ -28,7 +28,7 @@ HOOK: create-sql-statement db ( class -- obj )
 HOOK: drop-sql-statement db ( class -- obj )
 
 HOOK: <insert-native-statement> db ( class -- obj )
-HOOK: <insert-assigned-statement> db ( class -- obj )
+HOOK: <insert-nonnative-statement> db ( class -- obj )
 
 HOOK: <update-tuple-statement> db ( class -- obj )
 HOOK: <update-tuples-statement> db ( class -- obj )
@@ -36,7 +36,7 @@ HOOK: <update-tuples-statement> db ( class -- obj )
 HOOK: <delete-tuple-statement> db ( class -- obj )
 HOOK: <delete-tuples-statement> db ( class -- obj )
 
-HOOK: <select-by-slots-statement> db ( tuple -- tuple )
+HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
 
 HOOK: insert-tuple* db ( tuple statement -- )
 
@@ -75,21 +75,25 @@ HOOK: insert-tuple* db ( tuple statement -- )
     drop-sql-statement [ execute-statement ] with-disposals ;
 
 : ensure-table ( class -- )
-    [ dup drop-table ] ignore-errors create-table ;
+    [
+        drop-sql-statement make-nonthrowable
+        [ execute-statement ] with-disposals
+    ] [ create-table ] bi ;
 
 : insert-native ( tuple -- )
     dup class
     db get db-insert-statements [ <insert-native-statement> ] cache
     [ bind-tuple ] 2keep insert-tuple* ;
 
-: insert-assigned ( tuple -- )
+: insert-nonnative ( tuple -- )
+! TODO logic here for unique ids
     dup class
-    db get db-insert-statements [ <insert-assigned-statement> ] cache
+    db get db-insert-statements [ <insert-nonnative-statement> ] cache
     [ bind-tuple ] keep execute-statement ;
 
 : insert-tuple ( tuple -- )
-    dup class db-columns find-primary-key assigned-id? [
+    dup class db-columns find-primary-key nonnative-id? [
-        insert-assigned
+        insert-nonnative
     ] [
         insert-native
     ] if ;

extra/db/types/types.factor

@@ -3,7 +3,8 @@
 USING: arrays assocs db kernel math math.parser
 sequences continuations sequences.deep sequences.lib
 words namespaces tools.walker slots slots.private classes
-mirrors tuples combinators calendar.format symbols ;
+mirrors tuples combinators calendar.format symbols
+singleton ;
 IN: db.types
 
 HOOK: modifier-table db ( -- hash )
@@ -14,22 +15,30 @@ HOOK: compound-type db ( str n -- hash )
 
 TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
 
-SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
+SINGLETON: +native-id+
-+serial+ +unique+ +default+ +null+ +not-null+
+SINGLETON: +assigned-id+
+SINGLETON: +random-id+
+UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
+UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
+
+SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
 +foreign-id+ +has-many+ ;
 
-: (primary-key?) ( obj -- ? )
-    { +native-id+ +assigned-id+ } member? ;
-
 : primary-key? ( spec -- ? )
-    sql-spec-primary-key (primary-key?) ;
+    sql-spec-primary-key +primary-key+? ;
+
+: native-id? ( spec -- ? )
+    sql-spec-primary-key +native-id+? ;
+
+: nonnative-id? ( spec -- ? )
+    sql-spec-primary-key +nonnative-id+? ;
 
 : normalize-spec ( spec -- )
-    dup sql-spec-type dup (primary-key?) [
+    dup sql-spec-type dup +primary-key+? [
         swap set-sql-spec-primary-key
     ] [
         drop dup sql-spec-modifiers [
-            (primary-key?)
+            +primary-key+?
         ] deep-find
         [ swap set-sql-spec-primary-key ] [ drop ] if*
     ] if ;
@@ -37,12 +46,6 @@ SYMBOLS: +native-id+ +assigned-id+ +autoincrement+
 : find-primary-key ( specs -- obj )
     [ sql-spec-primary-key ] find nip ;
 
-: native-id? ( spec -- ? )
-    sql-spec-primary-key +native-id+ = ;
-
-: assigned-id? ( spec -- ? )
-    sql-spec-primary-key +assigned-id+ = ;
-
 : relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
 
 SYMBOLS: INTEGER BIG-INTEGER DOUBLE REAL BOOLEAN TEXT VARCHAR
@@ -69,7 +72,7 @@ TUPLE: no-sql-modifier ;
     dup number? [ number>string ] when ;
 
 : maybe-remove-id ( specs -- obj )
-    [ native-id? not ] subset ;
+    [ +native-id+? not ] subset ;
 
 : remove-relations ( specs -- newcolumns )
     [ relation? not ] subset ;

extra/delegate/delegate.factor

@@ -7,7 +7,7 @@ IN: delegate
     swap { } like "protocol-words" set-word-prop ;
 
 : PROTOCOL:
-    CREATE dup reset-generic dup define-symbol
+    CREATE-WORD dup define-symbol
     parse-definition swap define-protocol ; parsing
 
 PREDICATE: word protocol "protocol-words" word-prop ;
@@ -27,11 +27,11 @@ M: tuple-class group-words
     swap [ slot-spec-writer ] map append ;
 
 : define-consult-method ( word class quot -- )
-    pick add spin define-method ;
+    pick add >r swap create-method r> define ;
 
 : define-consult ( class group quot -- )
-    >r group-words r>
+    >r group-words swap r>
-    swapd [ define-consult-method ] 2curry each ;
+    [ define-consult-method ] 2curry each ;
 
 : CONSULT:
     scan-word scan-word parse-definition swapd define-consult ; parsing
@@ -39,7 +39,7 @@ M: tuple-class group-words
 : define-mimic ( group mimicker mimicked -- )
     >r >r group-words r> r> [
         pick "methods" word-prop at dup
-        [ "method-def" word-prop spin define-method ]
+        [ >r swap create-method r> word-def define ]
         [ 3drop ] if
     ] 2curry each ; 
 

extra/destructors/destructors.factor

@@ -26,11 +26,14 @@ M: destructor dispose
 : add-always-destructor ( obj -- )
     <destructor> always-destructors get push ;
 
+: dispose-each ( seq -- )
+    <reversed> [ dispose ] each ;
+
 : do-always-destructors ( -- )
-    always-destructors get [ dispose ] each ;
+    always-destructors get dispose-each ;
 
 : do-error-destructors ( -- )
-    error-destructors get [ dispose ] each ;
+    error-destructors get dispose-each ;
 
 : with-destructors ( quot -- )
     [

extra/hello-world/deploy.factor

@@ -1,14 +1,14 @@
 USING: tools.deploy.config ;
 H{
-    { deploy-io 2 }
-    { deploy-math? f }
-    { deploy-threads? f }
-    { deploy-compiler? f }
-    { deploy-word-props? f }
-    { deploy-word-defs? f }
     { deploy-name "Hello world (console)" }
-    { deploy-reflection 2 }
+    { deploy-threads? f }
     { deploy-c-types? f }
+    { deploy-compiler? f }
     { deploy-ui? f }
+    { deploy-math? f }
+    { deploy-reflection 1 }
+    { deploy-word-defs? f }
+    { deploy-io 2 }
+    { deploy-word-props? f }
     { "stop-after-last-window?" t }
 }

extra/help/help-tests.factor

@@ -0,0 +1,5 @@
+IN: help.tests
+USING: tools.test help kernel ;
+
+[ 3 throw ] must-fail
+[ ] [ :help ] unit-test

extra/help/help.factor

@@ -136,7 +136,7 @@ M: word set-article-parent swap "help-parent" set-word-prop ;
     ":edit - jump to source location (parse errors only)" print
 
     ":get  ( var -- value ) accesses variables at time of the error" print
-    ":vars - list all variables at error time";
+    ":vars - list all variables at error time" print ;
 
 : :help ( -- )
     error get delegates [ error-help ] map [ ] subset

extra/http/client/client-tests.factor

@@ -18,6 +18,7 @@ tuple-syntax namespaces ;
         port: 80
         version: "1.1"
         cookies: V{ }
+        header: H{ }
     }
 ] [
     [

extra/http/http-tests.factor

@@ -5,8 +5,8 @@ IN: http.tests
 [ "hello%20world" ] [ "hello world" url-encode ] unit-test
 [ "hello world" ] [ "hello%20world" url-decode ] unit-test
 [ "~hello world" ] [ "%7ehello+world" url-decode ] unit-test
-[ "" ] [ "%XX%XX%XX" url-decode ] unit-test
+[ f ] [ "%XX%XX%XX" url-decode ] unit-test
-[ "" ] [ "%XX%XX%X" url-decode ] unit-test
+[ f ] [ "%XX%XX%X" url-decode ] unit-test
 
 [ "hello world"   ] [ "hello+world"    url-decode ] unit-test
 [ "hello world"   ] [ "hello%20world"  url-decode ] unit-test

extra/http/http.factor

@@ -180,6 +180,7 @@ cookies ;
     request construct-empty
         "1.1" >>version
         http-port >>port
+        H{ } clone >>header
         H{ } clone >>query
         V{ } clone >>cookies ;
 

extra/http/server/actions/actions-tests.factor

@@ -1,11 +1,16 @@
 IN: http.server.actions.tests
-USING: http.server.actions tools.test math math.parser
+USING: http.server.actions http.server.validators
-multiline namespaces http io.streams.string http.server
+tools.test math math.parser multiline namespaces http
-sequences accessors ;
+io.streams.string http.server sequences accessors ;
+
+[
+    "a" [ v-number ] { { "a" "123" } } validate-param
+    [ 123 ] [ "a" get ] unit-test
+] with-scope
 
 <action>
     [ "a" get "b" get + ] >>display
-    { { "a" [ string>number ] } { "b" [ string>number ] } } >>get-params
+    { { "a" [ v-number ] } { "b" [ v-number ] } } >>get-params
 "action-1" set
 
 STRING: action-request-test-1
@@ -23,7 +28,7 @@ blah
 
 <action>
     [ +path+ get "xxx" get "X" <repetition> concat append ] >>submit
-    { { +path+ [ ] } { "xxx" [ string>number ] } } >>post-params
+    { { +path+ [ ] } { "xxx" [ v-number ] } } >>post-params
 "action-2" set
 
 STRING: action-request-test-2

extra/http/server/actions/actions.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors new-slots sequences kernel assocs combinators
 http.server http.server.validators http hashtables namespaces
-combinators.cleave fry continuations ;
+combinators.cleave fry continuations locals ;
 IN: http.server.actions
 
 SYMBOL: +path+
@@ -17,17 +17,13 @@ TUPLE: action init display submit get-params post-params ;
         [ <400> ] >>display
         [ <400> ] >>submit ;
 
-: with-validator ( string quot -- result error? )
+:: validate-param ( name validator assoc -- )
-    '[ , @ f ] [
+    name assoc at validator with-validator name set ; inline
-        dup validation-error? [ t ] [ rethrow ] if
-    ] recover ; inline
-
-: validate-param ( name validator assoc -- error? )
-    swap pick
-    >r >r at r> with-validator swap r> set ;
 
 : action-params ( validators -- error? )
-    [ params get validate-param ] { } assoc>map [ ] contains? ;
+    validation-failed? off
+    params get '[ , validate-param ] assoc-each
+    validation-failed? get ;
 
 : handle-get ( -- response )
     action get get-params>> action-params [ <400> ] [
@@ -42,10 +38,13 @@ TUPLE: action init display submit get-params post-params ;
     action get display>> call exit-with ;
 
 M: action call-responder ( path action -- response )
-    [ +path+ associate request-params union params set ]
+    '[
-    [ action set ] bi*
+        , ,
-    request get method>> {
+        [ +path+ associate request-params union params set ]
-        { "GET" [ handle-get ] }
+        [ action set ] bi*
-        { "HEAD" [ handle-get ] }
+        request get method>> {
-        { "POST" [ handle-post ] }
+            { "GET" [ handle-get ] }
-    } case ;
+            { "HEAD" [ handle-get ] }
+            { "POST" [ handle-post ] }
+        } case
+    ] with-exit-continuation ;

extra/http/server/auth/auth.factor

@@ -1,9 +1,26 @@
 ! Copyright (c) 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: http.server.sessions accessors
-http.server.auth.providers ;
+http.server.auth.providers assocs namespaces kernel ;
 IN: http.server.auth
 
 SYMBOL: logged-in-user
+SYMBOL: user-profile-changed?
+
+GENERIC: init-user-profile ( responder -- )
+
+M: object init-user-profile drop ;
 
 : uid ( -- string ) logged-in-user sget username>> ;
+
+: profile ( -- assoc ) logged-in-user sget profile>> ;
+
+: uget ( key -- value )
+    profile at ;
+
+: uset ( value key -- )
+    profile set-at user-profile-changed? on ;
+
+: uchange ( quot key -- )
+    profile swap change-at
+    user-profile-changed? on ; inline

extra/http/server/auth/login/edit-profile.fhtml

@@ -0,0 +1,77 @@
+<% USING: http.server.components http.server.auth.login
+http.server namespaces kernel combinators ; %>
+<html>
+<body>
+<h1>Edit profile</h1>
+
+<form method="POST" action="edit-profile">
+<% hidden-form-field %>
+
+<table>
+
+<tr>
+<td>User name:</td>
+<td><% "username" component render-view %></td>
+</tr>
+
+<tr>
+<td>Real name:</td>
+<td><% "realname" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>Specifying a real name is optional.</td>
+</tr>
+
+<tr>
+<td>Current password:</td>
+<td><% "password" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>If you don't want to change your current password, leave this field blank.</td>
+</tr>
+
+<tr>
+<td>New password:</td>
+<td><% "new-password" component render-edit %></td>
+</tr>
+
+<tr>
+<td>Verify:</td>
+<td><% "verify-password" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>If you are changing your password, enter it twice to ensure it is correct.</td>
+</tr>
+
+<tr>
+<td>E-mail:</td>
+<td><% "email" component render-edit %></td>
+</tr>
+
+<tr>
+<td></td>
+<td>Specifying an e-mail address is optional. It enables the "recover password" feature.</td>
+</tr>
+
+</table>
+
+<p><input type="submit" value="Update" />
+
+<% {
+    { [ login-failed? get ] [ "invalid password" render-error ] }
+    { [ password-mismatch? get ] [ "passwords do not match" render-error ] }
+    { [ t ] [ ] }
+} cond %>
+
+</p>
+
+</form>
+
+</body>
+</html>

extra/http/server/auth/login/login.factor

@@ -7,15 +7,30 @@ http.server.actions http.server.components http.server.sessions
 http.server.templating.fhtml http.server.validators
 http.server.auth http sequences io.files namespaces hashtables
 fry io.sockets combinators.cleave arrays threads locals
-qualified ;
+qualified continuations destructors ;
 IN: http.server.auth.login
 QUALIFIED: smtp
 
-TUPLE: login users ;
-
 SYMBOL: post-login-url
 SYMBOL: login-failed?
 
+TUPLE: login users ;
+
+: users login get users>> ;
+
+! Destructor
+TUPLE: user-saver user ;
+
+C: <user-saver> user-saver
+
+M: user-saver dispose
+    user-profile-changed? get [
+        user>> users update-user
+    ] [ drop ] if ;
+
+: save-user-after ( user -- )
+    <user-saver> add-always-destructor ;
+
 ! ! ! Login
 
 : <login-form>
@@ -49,7 +64,7 @@ SYMBOL: login-failed?
                 form validate-form
 
                 "password" value "username" value
-                login get users>> check-login [
+                users check-login [
                     successful-login
                 ] [
                     login-failed? on
@@ -67,7 +82,7 @@ SYMBOL: login-failed?
             t >>required
             add-field
         "realname" <string> add-field
-        "password" <password>
+        "new-password" <password>
             t >>required
             add-field
         "verify-password" <password>
@@ -80,7 +95,7 @@ SYMBOL: password-mismatch?
 SYMBOL: user-exists?
 
 : same-password-twice ( -- )
-    "password" value "verify-password" value = [ 
+    "new-password" value "verify-password" value = [ 
         password-mismatch? on
         validation-failed
     ] unless ;
@@ -102,19 +117,76 @@ SYMBOL: user-exists?
 
                 same-password-twice
 
-                <user> values get [
+                <user>
-                    "username" get >>username
+                    "username" value >>username
-                    "realname" get >>realname
+                    "realname" value >>realname
-                    "password" get >>password
+                    "new-password" value >>password
-                    "email" get >>email
+                    "email" value >>email
-                ] bind
 
-                login get users>> new-user [
+                users new-user [
                     user-exists? on
                     validation-failed
                 ] unless*
 
                 successful-login
+
+                login get responder>> init-user-profile
+            ] >>submit
+    ] ;
+
+! ! ! Editing user profile
+
+: <edit-profile-form> ( -- form )
+    "edit-profile" <form>
+        "resource:extra/http/server/auth/login/edit-profile.fhtml" >>edit-template
+        "username" <username> add-field
+        "realname" <string> add-field
+        "password" <password> add-field
+        "new-password" <password> add-field
+        "verify-password" <password> add-field
+        "email" <email> add-field ;
+
+SYMBOL: previous-page
+
+:: <edit-profile-action> ( -- action )
+    [let | form [ <edit-profile-form> ] |
+        <action>
+            [
+                blank-values
+                logged-in-user sget
+                dup username>> "username" set-value
+                dup realname>> "realname" set-value
+                dup email>> "email" set-value
+            ] >>init
+
+            [
+                "text/html" <content>
+                [ form edit-form ] >>body
+            ] >>display
+
+            [
+                blank-values
+                uid "username" set-value
+
+                form validate-form
+
+                logged-in-user sget
+
+                "password" value empty? [
+                    same-password-twice
+
+                    "password" value uid users check-login
+                    [ login-failed? on validation-failed ] unless
+
+                    "new-password" value set-password
+                ] unless
+
+                "realname" value >>realname
+                "email" value >>email
+
+                user-profile-changed? on
+
+                previous-page sget f <permanent-redirect>
             ] >>submit
     ] ;
 
@@ -186,7 +258,7 @@ SYMBOL: lost-password-from
                 form validate-form
 
                 "email" value "username" value
-                login get users>> issue-ticket [
+                users issue-ticket [
                     send-password-email
                 ] when*
 
@@ -200,7 +272,7 @@ SYMBOL: lost-password-from
         "username" <username> <hidden>
             t >>required
             add-field
-        "password" <password>
+        "new-password" <password>
             t >>required
             add-field
         "verify-password" <password>
@@ -239,9 +311,9 @@ SYMBOL: lost-password-from
 
                 "ticket" value
                 "username" value
-                login get users>> claim-ticket [
+                users claim-ticket [
-                    "password" value >>password
+                    "new-password" value >>password
-                    login get users>> update-user
+                    users update-user
 
                     "resource:extra/http/server/auth/login/recover-4.fhtml"
                     serve-template
@@ -265,13 +337,19 @@ TUPLE: protected responder ;
 
 C: <protected> protected
 
+: show-login-page ( -- response )
+    request get request-url post-login-url sset
+    "login" f <permanent-redirect> ;
+
 M: protected call-responder ( path responder -- response )
-    logged-in-user sget [ responder>> call-responder ] [
+    logged-in-user sget [
+        dup save-user-after
+        request get request-url previous-page sset
+        responder>> call-responder
+    ] [
         2drop
-        request get method>> { "GET" "HEAD" } member? [
+        request get method>> { "GET" "HEAD" } member?
-            request get request-url post-login-url sset
+        [ show-login-page ] [ <400> ] if
-            "login" f <permanent-redirect>
-        ] [ <400> ] if
     ] if ;
 
 M: login call-responder ( path responder -- response )
@@ -283,10 +361,13 @@ M: login call-responder ( path responder -- response )
         swap <protected> >>default
         <login-action> "login" add-responder
         <logout-action> "logout" add-responder
-        no >>users ;
+        no-users >>users ;
 
 ! ! ! Configuration
 
+: allow-edit-profile ( login -- login )
+    <edit-profile-action> <protected> "edit-profile" add-responder ;
+
 : allow-registration ( login -- login )
     <register-action> "register" add-responder ;
 
@@ -294,6 +375,9 @@ M: login call-responder ( path responder -- response )
     <recover-action-1> "recover-password" add-responder
     <recover-action-3> "new-password" add-responder ;
 
+: allow-edit-profile? ( -- ? )
+    login get responders>> "edit-profile" swap key? ;
+
 : allow-registration? ( -- ? )
     login get responders>> "register" swap key? ;
 

extra/http/server/auth/login/recover-3.fhtml

@@ -17,7 +17,7 @@ namespaces kernel combinators ; %>
 
 <tr>
 <td>Password:</td>
-<td><% "password" component render-edit %></td>
+<td><% "new-password" component render-edit %></td>
 </tr>
 
 <tr>

extra/http/server/auth/login/register.fhtml

@@ -26,7 +26,7 @@ http.server namespaces kernel combinators ; %>
 
 <tr>
 <td>Password:</td>
-<td><% "password" component render-edit %></td>
+<td><% "new-password" component render-edit %></td>
 </tr>
 
 <tr>

extra/http/server/auth/providers/assoc/assoc-tests.factor

@@ -3,7 +3,7 @@ USING: http.server.auth.providers
 http.server.auth.providers.assoc tools.test
 namespaces accessors kernel ;
 
-<in-memory> "provider" set
+<users-in-memory> "provider" set
 
 [ t ] [
     <user>
@@ -22,11 +22,11 @@ namespaces accessors kernel ;
 
 [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
 
-[ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
+[ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test
 
-[ f ] [ "xx" "blah" "provider" get set-password ] unit-test
+[ t ] [ "user" get >boolean ] unit-test
 
-[ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
+[ ] [ "user" get "fdasf" set-password drop ] unit-test
 
 [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
 

extra/http/server/auth/providers/assoc/assoc.factor

@@ -4,16 +4,16 @@ IN: http.server.auth.providers.assoc
 USING: new-slots accessors assocs kernel
 http.server.auth.providers ;
 
-TUPLE: in-memory assoc ;
+TUPLE: users-in-memory assoc ;
 
-: <in-memory> ( -- provider )
+: <users-in-memory> ( -- provider )
-    H{ } clone in-memory construct-boa ;
+    H{ } clone users-in-memory construct-boa ;
 
-M: in-memory get-user ( username provider -- user/f )
+M: users-in-memory get-user ( username provider -- user/f )
     assoc>> at ;
 
-M: in-memory update-user ( user provider -- ) 2drop ;
+M: users-in-memory update-user ( user provider -- ) 2drop ;
 
-M: in-memory new-user ( user provider -- user/f )
+M: users-in-memory new-user ( user provider -- user/f )
     >r dup username>> r> assoc>>
     2dup key? [ 3drop f ] [ pick >r set-at r> ] if ;

extra/http/server/auth/providers/db/db-tests.factor

@@ -4,35 +4,36 @@ http.server.auth.providers.db tools.test
 namespaces db db.sqlite db.tuples continuations
 io.files accessors kernel ;
 
-from-db "provider" set
+users-in-db "provider" set
 
 "auth-test.db" temp-file sqlite-db [
 
-    [ user drop-table ] ignore-errors
+    init-users-table
-    [ user create-table ] ignore-errors
 
     [ t ] [
         <user>
-        "slava" >>username
+            "slava" >>username
-        "foobar" >>password
+            "foobar" >>password
-        "slava@factorcode.org" >>email
+            "slava@factorcode.org" >>email
-        "provider" get new-user
+            "provider" get new-user
-        username>> "slava" =
+            username>> "slava" =
     ] unit-test
 
     [ f ] [
         <user>
-        "slava" >>username
+            "slava" >>username
         "provider" get new-user
     ] unit-test
 
     [ f ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
 
-    [ t ] [ "foobar" "slava" "provider" get check-login >boolean ] unit-test
+    [ ] [ "foobar" "slava" "provider" get check-login "user" set ] unit-test
 
-    [ f ] [ "xx" "blah" "provider" get set-password ] unit-test
+    [ t ] [ "user" get >boolean ] unit-test
 
-    [ t ] [ "fdasf" "slava" "provider" get set-password ] unit-test
+    [ ] [ "user" get "fdasf" set-password drop ] unit-test
+
+    [ ] [ "user" get "provider" get update-user ] unit-test
 
     [ t ] [ "fdasf" "slava" "provider" get check-login >boolean ] unit-test
 

extra/http/server/auth/providers/db/db.factor

@@ -1,7 +1,8 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: db db.tuples db.types new-slots accessors
-http.server.auth.providers kernel continuations ;
+http.server.auth.providers kernel continuations
+singleton ;
 IN: http.server.auth.providers.db
 
 user "USERS"
@@ -16,20 +17,18 @@ user "USERS"
 
 : init-users-table user ensure-table ;
 
-TUPLE: from-db ;
+SINGLETON: users-in-db
-
-: from-db T{ from-db } ;
 
 : find-user ( username -- user )
     <user>
         swap >>username
     select-tuple ;
 
-M: from-db get-user
+M: users-in-db get-user
     drop
     find-user ;
 
-M: from-db new-user
+M: users-in-db new-user
     drop
     [
         dup username>> find-user [
@@ -39,5 +38,5 @@ M: from-db new-user
         ] if
     ] with-transaction ;
 
-M: from-db update-user
+M: users-in-db update-user
     drop update-tuple ;

extra/http/server/auth/providers/null/null.factor

@@ -3,14 +3,12 @@
 USING: http.server.auth.providers kernel ;
 IN: http.server.auth.providers.null
 
-! Named "no" because we can say  no >>users
+TUPLE: no-users ;
 
-TUPLE: no ;
+: no-users T{ no-users } ;
 
-: no T{ no } ;
+M: no-users get-user 2drop f ;
 
-M: no get-user 2drop f ;
+M: no-users new-user 2drop f ;
 
-M: no new-user 2drop f ;
+M: no-users update-user 2drop ;
-
-M: no update-user 2drop ;

extra/http/server/auth/providers/providers.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: kernel new-slots accessors random math.parser locals
-sequences math ;
+sequences math crypto.sha2 ;
 IN: http.server.auth.providers
 
 TUPLE: user username realname password email ticket profile ;
@@ -17,14 +17,7 @@ GENERIC: new-user ( user provider -- user/f )
 : check-login ( password username provider -- user/f )
     get-user dup [ [ password>> = ] keep and ] [ 2drop f ] if ;
 
-:: set-password ( password username provider -- ? )
+: set-password ( user password -- user ) >>password ;
-    [let | user [ username provider get-user ] |
-        user [
-            user
-                password >>password
-            provider update-user t
-        ] [ f ] if
-    ] ;
 
 ! Password recovery support
 

extra/http/server/callbacks/callbacks.factor

@@ -4,7 +4,7 @@
 USING: html http http.server io kernel math namespaces
 continuations calendar sequences assocs new-slots hashtables
 accessors arrays alarms quotations combinators
-combinators.cleave fry ;
+combinators.cleave fry assocs.lib ;
 IN: http.server.callbacks
 
 SYMBOL: responder
@@ -98,11 +98,18 @@ SYMBOL: current-show
     cont-id query-param swap callbacks>> at ;
 
 M: callback-responder call-responder ( path responder -- response )
-    [ callback-responder set ]
+    '[
-    [ request get resuming-callback ] bi
+        , ,
 
-    [ invoke-callback ]
+        [ callback-responder set ]
-    [ callback-responder get responder>> call-responder ] ?if ;
+        [ request get resuming-callback ] bi
+
+        [
+            invoke-callback
+        ] [
+            callback-responder get responder>> call-responder
+        ] ?if
+    ] with-exit-continuation ;
 
 : show-page ( quot -- )
     >r redirect-to-here store-current-show r>

extra/http/server/components/components-tests.factor

@@ -86,3 +86,24 @@ TUPLE: test-tuple text number more-text ;
 
     [ t ] [ "number" value validation-error? ] unit-test
 ] with-scope
+
+[
+    [ ] [
+        "n" <number>
+            0 >>min-value
+            10 >>max-value
+        "n" set
+    ] unit-test
+
+    [ "123" ] [
+        "123" "n" get validate value>>
+    ] unit-test
+    
+    [ ] [ "n" get t >>integer drop ] unit-test
+
+    [ 3 ] [
+        "3" "n" get validate
+    ] unit-test
+] with-scope
+
+[ t ] [ "wake up sheeple" dup "n" <text> validate = ] unit-test

extra/http/server/components/components.factor

@@ -7,8 +7,6 @@ http.server.actions splitting mirrors hashtables
 combinators.cleave fry continuations math ;
 IN: http.server.components
 
-SYMBOL: validation-failed?
-
 SYMBOL: components
 
 TUPLE: component id required default ;
@@ -30,16 +28,13 @@ SYMBOL: values
 
 : validate ( value component -- result )
     '[
-        , ,
+        ,
         over empty? [
             [ default>> [ v-default ] when* ]
             [ required>> [ v-required ] when ]
             bi
         ] [ validate* ] if
-    ] [
+    ] with-validator ;
-        dup validation-error?
-        [ validation-failed? on ] [ rethrow ] if
-    ] recover ;
 
 : render-view ( component -- )
     [ id>> value ] [ render-view* ] bi ;
@@ -192,15 +187,16 @@ M: password render-error*
     render-edit* render-error ;
 
 ! Number fields
-TUPLE: number min-value max-value ;
+TUPLE: number min-value max-value integer ;
 
 : <number> ( id -- component ) number <component> ;
 
 M: number validate*
     [ v-number ] [
+        [ integer>> [ v-integer ] when ]
         [ min-value>> [ v-min-value ] when* ]
         [ max-value>> [ v-max-value ] when* ]
-        bi
+        tri
     ] bi* ;
 
 M: number render-view*
@@ -215,7 +211,12 @@ M: number render-error*
 ! Text areas
 TUPLE: text ;
 
-: <text> ( id -- component ) <string> text construct-delegate ;
+: <text> ( id -- component ) text <component> ;
+
+M: text validate* drop ;
+
+M: text render-view*
+    drop write ;
 
 : render-textarea
     <textarea

extra/http/server/server.factor

@@ -108,10 +108,6 @@ TUPLE: dispatcher default responders ;
 : <dispatcher> ( -- dispatcher )
     404-responder get H{ } clone dispatcher construct-boa ;
 
-: set-main ( dispatcher name -- dispatcher )
-    '[ , f <permanent-redirect> ] <trivial-responder>
-    >>default ;
-
 : split-path ( path -- rest first )
     [ CHAR: / = ] left-trim "/" split1 swap ;
 
@@ -124,28 +120,36 @@ TUPLE: dispatcher default responders ;
 
 M: dispatcher call-responder ( path dispatcher -- response )
     over [
-        2dup find-responder call-responder [
+        find-responder call-responder
-            2nip
-        ] [
-            default>> [
-                call-responder
-            ] [
-                drop f
-            ] if*
-        ] if*
     ] [
         2drop redirect-with-/
     ] if ;
 
+: <webapp> ( class -- dispatcher )
+    <dispatcher> swap construct-delegate ; inline
+
+TUPLE: vhost-dispatcher default responders ;
+
+: <vhost-dispatcher> ( -- dispatcher )
+    404-responder get H{ } clone vhost-dispatcher construct-boa ;
+
+: find-vhost ( dispatcher -- responder )
+    request get host>> over responders>> at*
+    [ nip ] [ drop default>> ] if ;
+
+M: vhost-dispatcher call-responder ( path dispatcher -- response )
+    find-vhost call-responder ;
+
+: set-main ( dispatcher name -- dispatcher )
+    '[ , f <permanent-redirect> ] <trivial-responder>
+    >>default ;
+
 : add-responder ( dispatcher responder path -- dispatcher )
     pick responders>> set-at ;
 
 : add-main-responder ( dispatcher responder path -- dispatcher )
     [ add-responder ] keep set-main ;
 
-: <webapp> ( class -- dispatcher )
-    <dispatcher> swap construct-delegate ; inline
-
 SYMBOL: main-responder
 
 main-responder global
@@ -181,21 +185,20 @@ SYMBOL: exit-continuation
 
 : exit-with exit-continuation get continue-with ;
 
+: with-exit-continuation ( quot -- )
+    '[ exit-continuation set @ ] callcc1 exit-continuation off ;
+
 : do-request ( request -- response )
-    '[
+    [
-        exit-continuation set ,
+        [ log-request ]
-        [
+        [ request set ]
-            [ log-request ]
+        [ path>> main-responder get call-responder ] tri
-            [ request set ]
+        [ <404> ] unless*
-            [ path>> main-responder get call-responder ] tri
+    ] [
-            [ <404> ] unless*
+        [ \ do-request log-error ]
-        ] [
+        [ <500> ]
-            [ \ do-request log-error ]
+        bi
-            [ <500> ]
+    ] recover ;
-            bi
-        ] recover
-    ] callcc1
-    exit-continuation off ;
 
 : default-timeout 1 minutes stdio get set-timeout ;
 
@@ -219,11 +222,3 @@ SYMBOL: exit-continuation
 : httpd-main ( -- ) 8888 httpd ;
 
 MAIN: httpd-main
-
-! Utility
-: generate-key ( assoc -- str )
-    >r random-256 >hex r>
-    2dup key? [ nip generate-key ] [ drop ] if ;
-
-: set-at-unique ( value assoc -- key )
-    dup generate-key [ swap set-at ] keep ;

extra/http/server/sessions/sessions-tests.factor

@@ -1,6 +1,8 @@
 IN: http.server.sessions.tests
-USING: tools.test http.server.sessions math namespaces
+USING: tools.test http http.server.sessions
-kernel accessors ;
+http.server.sessions.storage http.server.sessions.storage.assoc
+http.server.actions http.server math namespaces kernel accessors
+prettyprint io.streams.string splitting destructors sequences ;
 
 [ H{ } ] [ H{ } add-session-id ] unit-test
 
@@ -12,7 +14,16 @@ C: <foo> foo
 
 M: foo init-session* drop 0 "x" sset ;
 
-f <session> "123" >>id [
+M: foo call-responder
+    2drop
+    "x" [ 1+ ] schange
+    "text/html" <content> [ "x" sget pprint ] >>body ;
+
+[
+    "123" session-id set
+    H{ } clone session set
+    session-changed? off
+
     [ H{ { "factorsessid" "123" } } ] [ H{ } add-session-id ] unit-test
 
     [ ] [ 3 "x" sset ] unit-test
@@ -22,22 +33,113 @@ f <session> "123" >>id [
     [ ] [ "x" [ 1- ] schange ] unit-test
     
     [ 4 ] [ "x" sget sq ] unit-test
-] with-session
+
+    [ t ] [ session-changed? get ] unit-test
+] with-scope
 
 [ t ] [ f <url-sessions> url-sessions? ] unit-test
 [ t ] [ f <cookie-sessions> cookie-sessions? ] unit-test
 
 [ ] [
     <foo> <url-sessions>
+        <sessions-in-memory> >>sessions
     "manager" set
 ] unit-test
 
 [ { 5 0 } ] [
     [
-        "manager" get new-session
+        "manager" get begin-session drop
-        dup "manager" get get-session [ 5 "a" sset ] with-session
+        dup "manager" get sessions>> get-session [ 5 "a" sset ] with-session
-        dup "manager" get get-session [ "a" sget , ] with-session
+        dup "manager" get sessions>> get-session [ "a" sget , ] with-session
-        dup "manager" get get-session [ "x" sget , ] with-session
+        dup "manager" get sessions>> get-session [ "x" sget , ] with-session
-        "manager" get get-session delete-session
+        "manager" get sessions>> get-session
+        "manager" get sessions>> delete-session
     ] { } make
 ] unit-test
+
+[ ] [
+    <request>
+        "GET" >>method
+    request set
+    "/etc" "manager" get call-responder
+    response set
+] unit-test
+
+[ 307 ] [ response get code>> ] unit-test
+
+[ ] [ response get "location" header "=" split1 nip "id" set ] unit-test
+
+: url-responder-mock-test
+    [
+        <request>
+            "GET" >>method
+            "id" get session-id-key set-query-param
+            "/" >>path
+        request set
+        "/" "manager" get call-responder
+        [ write-response-body drop ] with-string-writer
+    ] with-destructors ;
+
+[ "1" ] [ url-responder-mock-test ] unit-test
+[ "2" ] [ url-responder-mock-test ] unit-test
+[ "3" ] [ url-responder-mock-test ] unit-test
+[ "4" ] [ url-responder-mock-test ] unit-test
+
+[ ] [
+    <foo> <cookie-sessions>
+        <sessions-in-memory> >>sessions
+    "manager" set
+] unit-test
+
+[
+    <request>
+    "GET" >>method
+    "/" >>path
+    request set
+    "/etc" "manager" get call-responder response set
+    [ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
+    response get
+] with-destructors
+response set
+
+[ ] [ response get cookies>> "cookies" set ] unit-test
+
+: cookie-responder-mock-test
+    [
+        <request>
+            "GET" >>method
+            "cookies" get >>cookies
+            "/" >>path
+        request set
+        "/" "manager" get call-responder
+        [ write-response-body drop ] with-string-writer
+    ] with-destructors ;
+
+[ "2" ] [ cookie-responder-mock-test ] unit-test
+[ "3" ] [ cookie-responder-mock-test ] unit-test
+[ "4" ] [ cookie-responder-mock-test ] unit-test
+
+: <exiting-action>
+    <action>
+        [
+            "text/plain" <content> exit-with
+        ] >>display ;
+
+[
+    [ ] [
+        <request>
+            "GET" >>method
+            "id" get session-id-key set-query-param
+            "/" >>path
+        request set
+
+        [
+            "/" <exiting-action> <cookie-sessions>
+            call-responder
+        ] with-destructors response set
+    ] unit-test
+
+    [ "text/plain" ] [ response get "content-type" header ] unit-test
+
+    [ f ] [ response get cookies>> empty? ] unit-test
+] with-scope

extra/http/server/sessions/sessions.factor

@@ -1,9 +1,10 @@
 ! Copyright (C) 2008 Doug Coleman, Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs calendar kernel math.parser namespaces random
-boxes alarms new-slots accessors http http.server
+new-slots accessors http http.server
+http.server.sessions.storage http.server.sessions.storage.assoc
 quotations hashtables sequences fry combinators.cleave
-html.elements ;
+html.elements symbols continuations destructors ;
 IN: http.server.sessions
 
 ! ! ! ! ! !
@@ -12,61 +13,56 @@ IN: http.server.sessions
 
 GENERIC: init-session* ( responder -- )
 
-M: dispatcher init-session* drop ;
+M: object init-session* drop ;
 
 TUPLE: session-manager responder sessions ;
 
 : <session-manager> ( responder class -- responder' )
-    >r H{ } clone session-manager construct-boa r>
+    >r <sessions-in-memory> session-manager construct-boa
-    construct-delegate ; inline
+    r> construct-delegate ; inline
 
-TUPLE: session manager id namespace alarm ;
+SYMBOLS: session session-id session-changed? ;
 
-: <session> ( manager -- session )
+: sget ( key -- value )
-    f H{ } clone <box> \ session construct-boa ;
+    session get at ;
 
-: timeout ( -- dt ) 20 minutes ;
+: sset ( value key -- )
+    session get set-at
+    session-changed? on ;
 
-: cancel-timeout ( session -- )
+: schange ( key quot -- )
-    alarm>> [ cancel-alarm ] if-box? ;
+    session get swap change-at
+    session-changed? on ; inline
 
-: delete-session ( session -- )
+: sessions session-manager get sessions>> ;
-    [ cancel-timeout ]
-    [ dup manager>> sessions>> delete-at ]
-    bi ;
 
-: touch-session ( session -- session )
+: managed-responder session-manager get responder>> ;
-    [ cancel-timeout ]
-    [ [ '[ , delete-session ] timeout later ] keep alarm>> >box ]
-    [ ]
-    tri ;
 
-: session ( -- assoc ) \ session get namespace>> ;
+: init-session ( managed -- session )
+    H{ } clone [ session [ init-session* ] with-variable ] keep ;
 
-: sget ( key -- value ) session at ;
+: begin-session ( responder -- id session )
+    [ responder>> init-session ] [ sessions>> ] bi
+    [ new-session ] [ drop ] 2bi ;
 
-: sset ( value key -- ) session set-at ;
+! Destructor
+TUPLE: session-saver id session ;
 
-: schange ( key quot -- ) session swap change-at ; inline
+C: <session-saver> session-saver
 
-: init-session ( session -- session )
+M: session-saver dispose
-    dup dup \ session [
+    session-changed? get [
-        manager>> responder>> init-session*
+        [ session>> ] [ id>> ] bi
-    ] with-variable ;
+        sessions update-session
+    ] [ drop ] if ;
 
-: new-session ( responder -- id )
+: save-session-after ( id session -- )
-    [ <session> init-session touch-session ]
+    <session-saver> add-always-destructor ;
-    [ [ sessions>> set-at-unique ] [ drop swap >>id ] 2bi ]
-    bi id>> ;
 
-: get-session ( id responder -- session/f )
+: call-responder/session ( path responder id session -- response )
-    sessions>> at* [ touch-session ] when ;
+    [ save-session-after ]
-
+    [ [ session-id set ] [ session set ] bi* ] 2bi
-: call-responder/session ( path responder session -- response )
+    [ session-manager set ] [ responder>> call-responder ] bi ;
-    \ session set responder>> call-responder ;
-
-: sessions ( -- manager/f )
-    \ session get dup [ manager>> ] when ;
 
 TUPLE: null-sessions ;
 
@@ -74,56 +70,64 @@ TUPLE: null-sessions ;
     null-sessions <session-manager> ;
 
 M: null-sessions call-responder ( path responder -- response )
-    dup <session> call-responder/session ;
+    H{ } clone f call-responder/session ;
 
 TUPLE: url-sessions ;
 
 : <url-sessions> ( responder -- responder' )
     url-sessions <session-manager> ;
 
-: sess-id "factorsessid" ;
+: session-id-key "factorsessid" ;
 
-: current-session ( responder -- session )
+: current-url-session ( responder -- id/f session/f )
-    >r request-params sess-id swap at r> get-session ;
+    [ request-params session-id-key swap at ] [ sessions>> ] bi*
+    [ drop ] [ get-session ] 2bi ;
 
 : add-session-id ( query -- query' )
-    \ session get [ id>> sess-id associate union ] when* ;
+    session-id get [ session-id-key associate union ] when* ;
 
 : session-form-field ( -- )
     <input
-    "hidden" =type
+        "hidden" =type
-    sess-id =id
+        session-id-key =id
-    sess-id =name
+        session-id-key =name
-    \ session get id>> =value
+        session-id get =value
     input/> ;
 
+: new-url-session ( responder -- response )
+    [ f ] [ begin-session drop session-id-key associate ] bi*
+    <temporary-redirect> ;
+
 M: url-sessions call-responder ( path responder -- response )
     [ add-session-id ] link-hook set
     [ session-form-field ] form-hook set
-    dup current-session [
+    dup current-url-session dup [
         call-responder/session
     ] [
-        nip
+        2drop nip new-url-session
-        f swap new-session sess-id associate <temporary-redirect>
+    ] if ;
-    ] if* ;
 
 TUPLE: cookie-sessions ;
 
 : <cookie-sessions> ( responder -- responder' )
     cookie-sessions <session-manager> ;
 
-: get-session-cookie ( responder -- cookie )
+: current-cookie-session ( responder -- id namespace/f )
-    request get sess-id get-cookie
+    request get session-id-key get-cookie dup
-    [ value>> swap get-session ] [ drop f ] if* ;
+    [ value>> dup rot sessions>> get-session ] [ 2drop f f ] if ;
 
 : <session-cookie> ( id -- cookie )
-    sess-id <cookie> ;
+    session-id-key <cookie> ;
+
+: call-responder/new-session ( path responder -- response )
+    dup begin-session
+    [ call-responder/session ]
+    [ drop <session-cookie> ] 2bi
+    put-cookie ;
 
 M: cookie-sessions call-responder ( path responder -- response )
-    dup get-session-cookie [
+    dup current-cookie-session dup [
         call-responder/session
     ] [
-        dup new-session
+        2drop call-responder/new-session
-        [ over get-session call-responder/session ] keep
+    ] if ;
-        <session-cookie> put-cookie
-    ] if* ;

extra/http/server/sessions/storage/assoc/assoc.factor

@@ -0,0 +1,38 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs assocs.lib new-slots accessors
+http.server.sessions.storage combinators.cleave alarms kernel
+fry http.server ;
+IN: http.server.sessions.storage.assoc
+
+TUPLE: sessions-in-memory sessions alarms ;
+
+: <sessions-in-memory> ( -- storage )
+    H{ } clone H{ } clone sessions-in-memory construct-boa ;
+
+: cancel-session-timeout ( id storage -- )
+    alarms>> at [ cancel-alarm ] when* ;
+
+: touch-session ( id storage -- )
+    [ cancel-session-timeout ]
+    [ '[ , , delete-session ] timeout later ]
+    [ alarms>> set-at ]
+    2tri ;
+
+M: sessions-in-memory get-session ( id storage -- namespace )
+    [ sessions>> at ] [ touch-session ] 2bi ;
+
+M: sessions-in-memory update-session ( namespace id storage -- )
+    [ sessions>> set-at ]
+    [ touch-session ]
+    2bi ;
+
+M: sessions-in-memory delete-session ( id storage -- )
+    [ sessions>> delete-at ]
+    [ cancel-session-timeout ]
+    2bi ;
+
+M: sessions-in-memory new-session ( namespace storage -- id )
+    [ sessions>> set-at-unique ]
+    [ [ touch-session ] [ drop ] 2bi ]
+    bi ;

extra/http/server/sessions/storage/db/db-tests.factor

@@ -0,0 +1,24 @@
+IN: http.server.sessions.storage.db
+USING: http.server.sessions.storage
+http.server.sessions.storage.db namespaces io.files
+db.sqlite db accessors math tools.test kernel assocs
+sequences ;
+
+sessions-in-db "storage" set
+
+"auth-test.db" temp-file sqlite-db [
+    [ ] [ init-sessions-table ] unit-test
+
+    [ f ] [ H{ } "storage" get new-session empty? ] unit-test
+
+    H{ } "storage" get new-session "id" set
+
+    "id" get "storage" get get-session "session" set
+    "a" "b" "session" get set-at
+
+    "session" get "id" get "storage" get update-session
+
+    [ H{ { "b" "a" } } ] [
+        "id" get "storage" get get-session
+    ] unit-test
+] with-db

extra/http/server/sessions/storage/db/db.factor

@@ -0,0 +1,46 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs new-slots accessors http.server.sessions.storage
+alarms kernel http.server db.tuples db.types singleton
+combinators.cleave math.parser ;
+IN: http.server.sessions.storage.db
+
+SINGLETON: sessions-in-db
+
+TUPLE: session id namespace ;
+
+session "SESSIONS"
+{
+    { "id" "ID" INTEGER +native-id+ }
+    { "namespace" "NAMESPACE" FACTOR-BLOB }
+} define-persistent
+
+: init-sessions-table session ensure-table ;
+
+: <session> ( id -- session )
+    session construct-empty
+        swap dup [ string>number ] when >>id ;
+
+M: sessions-in-db get-session ( id storage -- namespace/f )
+    drop
+    dup [
+        <session>
+        select-tuple dup [ namespace>> ] when
+    ] when ;
+
+M: sessions-in-db update-session ( namespace id storage -- )
+    drop
+    <session>
+        swap >>namespace
+    update-tuple ;
+
+M: sessions-in-db delete-session ( id storage -- )
+    drop
+    <session>
+    delete-tuple ;
+
+M: sessions-in-db new-session ( namespace storage -- id )
+    drop
+    f <session>
+        swap >>namespace
+    [ insert-tuple ] [ id>> number>string ] bi ;

extra/http/server/sessions/storage/storage.factor

@@ -0,0 +1,14 @@
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: calendar ;
+IN: http.server.sessions.storage
+
+: timeout 20 minutes ;
+
+GENERIC: get-session ( id storage -- namespace )
+
+GENERIC: update-session ( namespace id storage -- )
+
+GENERIC: delete-session ( id storage -- )
+
+GENERIC: new-session ( namespace storage -- id )

extra/http/server/validators/validators-tests.factor

@@ -2,7 +2,8 @@ IN: http.server.validators.tests
 USING: kernel sequences tools.test http.server.validators
 accessors ;
 
-[ "foo" v-number ] [ validation-error? ] must-fail-with
+[ "foo" v-number ] must-fail
+[ 123 ] [ "123" v-number ] unit-test
 
 [ "slava@factorcode.org" ] [
     "slava@factorcode.org" v-email
@@ -13,10 +14,10 @@ accessors ;
 ] unit-test
 
 [ "slava@factorcode.o" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
 
 [ "sla@@factorcode.o" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with
 
 [ "slava@factorcodeorg" v-email ]
-[ reason>> "invalid e-mail" = ] must-fail-with
+[ "invalid e-mail" = ] must-fail-with

extra/http/server/validators/validators.factor

@@ -5,21 +5,26 @@ math.parser assocs new-slots regexp fry unicode.categories
 combinators.cleave sequences ;
 IN: http.server.validators
 
+SYMBOL: validation-failed?
+
 TUPLE: validation-error value reason ;
 
-: validation-error ( value reason -- * )
+C: <validation-error> validation-error
-    \ validation-error construct-boa throw ;
+
+: with-validator ( value quot -- result )
+    [ validation-failed? on <validation-error> ] recover ;
+    inline
 
 : v-default ( str def -- str )
     over empty? spin ? ;
 
 : v-required ( str -- str )
-    dup empty? [ "required" validation-error ] when ;
+    dup empty? [ "required" throw ] when ;
 
 : v-min-length ( str n -- str )
     over length over < [
         [ "must be at least " % # " characters" % ] "" make
-        validation-error
+        throw
     ] [
         drop
     ] if ;
@@ -27,35 +32,34 @@ TUPLE: validation-error value reason ;
 : v-max-length ( str n -- str )
     over length over > [
         [ "must be no more than " % # " characters" % ] "" make
-        validation-error
+        throw
     ] [
         drop
     ] if ;
 
 : v-number ( str -- n )
-    dup string>number [ ] [
+    dup string>number [ ] [ "must be a number" throw ] ?if ;
-        "must be a number" validation-error
+
-    ] ?if ;
+: v-integer ( n -- n )
+    dup integer? [ "must be an integer" throw ] unless ;
 
 : v-min-value ( x n -- x )
     2dup < [
-        [ "must be at least " % # ] "" make
+        [ "must be at least " % # ] "" make throw
-        validation-error
     ] [
         drop
     ] if ;
 
 : v-max-value ( x n -- x )
     2dup > [
-        [ "must be no more than " % # ] "" make
+        [ "must be no more than " % # ] "" make throw
-        validation-error
     ] [
         drop
     ] if ;
 
 : v-regexp ( str what regexp -- str )
     >r over r> matches?
-    [ drop ] [ "invalid " swap append validation-error ] if ;
+    [ drop ] [ "invalid " swap append throw ] if ;
 
 : v-email ( str -- str )
     #! From http://www.regular-expressions.info/email.html
@@ -64,12 +68,12 @@ TUPLE: validation-error value reason ;
     v-regexp ;
 
 : v-captcha ( str -- str )
-    dup empty? [ "must remain blank" validation-error ] unless ;
+    dup empty? [ "must remain blank" throw ] unless ;
 
 : v-one-line ( str -- str )
     dup "\r\n" seq-intersect empty?
-    [ "must be a single line" validation-error ] unless ;
+    [ "must be a single line" throw ] unless ;
 
 : v-one-word ( str -- str )
     dup [ alpha? ] all?
-    [ "must be a single word" validation-error ] unless ;
+    [ "must be a single word" throw ] unless ;

extra/io/unix/launcher/launcher-tests.factor

@@ -34,7 +34,7 @@ accessors kernel sequences ;
     ascii <process-stream> contents
 ] unit-test
 
-[ "" ] [
+[ f ] [
     <process>
         "cat"
         "launcher-test-1" temp-file
@@ -55,7 +55,7 @@ accessors kernel sequences ;
     try-process
 ] unit-test
 
-[ "" ] [
+[ f ] [
     "cat"
     "launcher-test-1" temp-file
     2array

extra/io/unix/unix.factor

@@ -3,5 +3,3 @@ io.unix.launcher io.unix.mmap io.backend
 combinators namespaces system vocabs.loader sequences ;
 
 "io.unix." os append require
-
-"tools.vocabs.monitor" require

extra/io/windows/files/files.factor

@@ -7,7 +7,7 @@ sequences namespaces words symbols ;
 IN: io.windows.files
 
 SYMBOLS: +read-only+ +hidden+ +system+
-+directory+ +archive+ +device+ +normal+ +temporary+
++archive+ +device+ +normal+ +temporary+
 +sparse-file+ +reparse-point+ +compressed+ +offline+
 +not-content-indexed+ +encrypted+ ;
 

extra/io/windows/nt/nt.factor

@@ -13,5 +13,3 @@ USE: io.windows.files
 USE: io.backend
 
 T{ windows-nt-io } set-io-backend
-
-"tools.vocabs.monitor" require

extra/io/windows/windows.factor

@@ -76,11 +76,8 @@ M: win32-file close-handle ( handle -- )
     ] when drop ;
 
 : open-append ( path -- handle length )
-    dup file-info file-info-size dup [
+    [ dup file-info file-info-size ] [ drop 0 ] recover
-        >r (open-append) r> 2dup set-file-pointer
+    >r (open-append) r> 2dup set-file-pointer ;
-    ] [
-        drop open-write
-    ] if ;
 
 TUPLE: FileArgs
     hFile lpBuffer nNumberOfBytesToRead lpNumberOfBytesRet lpOverlapped ;

extra/ldap/libldap/libldap.factor

@@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
 IN: ldap.libldap
 
 << "libldap" {
-    { [ win32? ] [ "libldap.dll" "stdcall" ] }
+    { [ win32? ]  [ "libldap.dll" "stdcall" ] }
     { [ macosx? ] [ "libldap.dylib" "cdecl" ] }
-    { [ unix? ] [ "$LD_LIBRARY_PATH/libldap.so" "cdecl" ] }
+    { [ unix? ]   [ "libldap.so" "cdecl" ] }
 } cond add-library >>
  
 : LDAP_VERSION1     1 ; inline

extra/locals/locals-tests.factor

@@ -1,5 +1,6 @@
 USING: locals math sequences tools.test hashtables words kernel
-namespaces arrays strings prettyprint ;
+namespaces arrays strings prettyprint io.streams.string parser
+;
 IN: locals.tests
 
 :: foo ( a b -- a a ) a a ;
@@ -178,3 +179,19 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
 [ "[| a! | ]" ] [
     [| a! | ] unparse
 ] unit-test
+
+DEFER: xyzzy
+
+[ ] [
+    "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;"
+    <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 10 ] [ 10 xyzzy ] unit-test
+
+[ ] [
+    "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;"
+    <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 5 ] [ 10 xyzzy ] unit-test

extra/locals/locals.factor

@@ -249,13 +249,14 @@ M: wlet local-rewrite*
     word [ over "declared-effect" set-word-prop ] when*
     effect-in make-locals ;
 
-: ((::)) ( word -- word quot )
+: parse-locals-definition ( word -- word quot )
     scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
     2dup "lambda" set-word-prop
     lambda-rewrite first ;
 
-: (::) ( -- word quot )
+: (::) CREATE-WORD parse-locals-definition ;
-    CREATE dup reset-generic ((::)) ;
+
+: (M::) CREATE-METHOD parse-locals-definition ;
 
 PRIVATE>
 
@@ -275,18 +276,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ;
 
 : :: (::) define ; parsing
 
-! This will be cleaned up when method tuples and method words
+: M:: (M::) define ; parsing
-! are unified
-: create-method ( class generic -- method )
-    2dup method dup
-    [ 2nip ]
-    [ drop 2dup [ ] -rot define-method create-method ] if ;
-
-: CREATE-METHOD ( -- class generic body )
-    scan-word bootstrap-word scan-word 2dup
-    create-method f set-word dup save-location ;
-
-: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing
 
 : MACRO:: (::) define-macro ; parsing
 

extra/logging/logging.factor

@@ -127,8 +127,7 @@ PRIVATE>
 
 : LOG:
     #! Syntax: name level
-    CREATE
+    CREATE-WORD
-    dup reset-generic
     dup scan-word
     [ >r >r 1array stack>message r> r> log-message ] 2curry
     define ; parsing

extra/logging/server/server.factor

@@ -3,8 +3,8 @@
 USING: namespaces kernel io calendar sequences io.files
 io.sockets continuations prettyprint assocs math.parser
 words debugger math combinators concurrency.messaging
-threads arrays init math.ranges strings calendar.format
+threads arrays init math.ranges strings calendar.format
-io.encodings.ascii ;
+io.encodings.utf8 ;
 IN: logging.server
 
 : log-root ( -- string )
@@ -21,7 +21,7 @@ SYMBOL: log-files
 : open-log-stream ( service -- stream )
     log-path
     dup make-directories
-    1 log# ascii <file-appender> ;
+    1 log# utf8 <file-appender> ;
 
 : log-stream ( service -- stream )
     log-files get [ open-log-stream ] cache ;

extra/memoize/memoize.factor

@@ -40,7 +40,7 @@ IN: memoize
     over make-memoizer define ;
 
 : MEMO:
-    CREATE dup reset-generic parse-definition define-memoized ; parsing
+    CREATE-WORD parse-definition define-memoized ; parsing
 
 PREDICATE: word memoized "memoize" word-prop ;
 

extra/multiline/multiline.factor

@@ -18,7 +18,7 @@ IN: multiline
     lexer get next-line ;
 
 : STRING:
-    CREATE dup reset-generic
+    CREATE-WORD
     parse-here 1quotation define-inline ; parsing
 
 : (parse-multiline-string) ( start-index end-text -- end-index )

extra/namespaces/lib/lib-tests.factor

@@ -0,0 +1,6 @@
+IN: namespaces.lib.tests
+USING: namespaces.lib tools.test ;
+
+[ ] [ [ ] { } nmake ] unit-test
+
+[ { 1 } { 2 } ] [ [ 1 0, 2 1, ] { { } { } } nmake ] unit-test

extra/namespaces/lib/lib.factor

@@ -2,7 +2,7 @@
 ! USING: kernel quotations namespaces sequences assocs.lib ;
 
 USING: kernel namespaces namespaces.private quotations sequences
-       assocs.lib math.parser math sequences.lib ;
+       assocs.lib math.parser math sequences.lib locals ;
 
 IN: namespaces.lib
 
@@ -42,11 +42,19 @@ SYMBOL: building-seq
 : 4% 4 n% ;
 : 4# 4 n# ;
 
-: nmake ( quot exemplars -- seqs )
+MACRO:: nmake ( quot exemplars -- )
-    dup length dup zero? [ 1+ ] when
+    [let | n [ exemplars length ] |
-    [
         [
-            [ drop 1024 swap new-resizable ] 2map
+            [
-            [ building-seq set call ] keep
+                exemplars
-        ] 2keep >r [ like ] 2map r> firstn 
+                [ 0 swap new-resizable ] map
-    ] with-scope ;
+                building-seq set
+
+                quot call
+
+                building-seq get
+                exemplars [ like ] 2map
+                n firstn
+            ] with-scope
+        ]
+    ] ;

extra/opengl/gl/gl-docs.factor

@@ -0,0 +1,85 @@
+
+USING: help.syntax help.markup ;
+
+IN: opengl.gl
+
+ARTICLE: "opengl-low-level" "OpenGL Library (low level)"
+  { $subsection "opengl-specifying-vertices" }
+  { $subsection "opengl-geometric-primitives" }
+  { $subsection "opengl-modeling-transformations" } ;
+
+ARTICLE: "opengl-specifying-vertices" "Specifying Vertices"
+
+  { $subsection glVertex2d }
+  { $subsection glVertex2f }
+  { $subsection glVertex2i }
+  { $subsection glVertex2s }
+  { $subsection glVertex3d }
+  { $subsection glVertex3f }
+  { $subsection glVertex3i }
+  { $subsection glVertex3s }
+  { $subsection glVertex4d }
+  { $subsection glVertex4f }
+  { $subsection glVertex4i }
+  { $subsection glVertex4s }
+  { $subsection glVertex2dv }
+  { $subsection glVertex2fv }
+  { $subsection glVertex2iv }
+  { $subsection glVertex2sv }
+  { $subsection glVertex3dv }
+  { $subsection glVertex3fv }
+  { $subsection glVertex3iv }
+  { $subsection glVertex3sv }
+  { $subsection glVertex4dv }
+  { $subsection glVertex4fv }
+  { $subsection glVertex4iv }
+  { $subsection glVertex4sv } ;
+
+ARTICLE: "opengl-geometric-primitives" "OpenGL Geometric Primitives"
+
+  { $table
+      { { $link GL_POINTS         } "individual points" }
+      { { $link GL_LINES          } { "pairs of vertices interpreted as "
+                                      "individual line segments" } }
+      { { $link GL_LINE_STRIP     } "series of connected line segments" }
+      { { $link GL_LINE_LOOP      } { "same as above, with a segment added "
+                                      "between last and first vertices" } }
+      { { $link GL_TRIANGLES      }
+        "triples of vertices interpreted as triangles" }
+      { { $link GL_TRIANGLE_STRIP } "linked strip of triangles" }
+      { { $link GL_TRIANGLE_FAN   } "linked fan of triangles" }
+      { { $link GL_QUADS          }
+        "quadruples of vertices interpreted as four-sided polygons" }
+      { { $link GL_QUAD_STRIP     } "linked strip of quadrilaterals" }
+      { { $link GL_POLYGON        } "boundary of a simple, convex polygon" } }
+
+;
+
+HELP: glBegin
+  { $values { "mode"
+              { "One of the " { $link "opengl-geometric-primitives" } } } } ;
+
+HELP: glPolygonMode
+  { $values { "face" { "One of the following:"
+                       { $list { $link GL_FRONT }
+                               { $link GL_BACK }
+                               { $link GL_FRONT_AND_BACK } } } }
+            { "mode" { "One of the following:"
+                       { $list
+                         { $link GL_POINT }
+                         { $link GL_LINE }
+                         { $link GL_FILL } } } } } ;
+
+ARTICLE: "opengl-modeling-transformations" "Modeling Transformations"
+  { $subsection glTranslatef }
+  { $subsection glTranslated }
+  { $subsection glRotatef }
+  { $subsection glRotated }
+  { $subsection glScalef }
+  { $subsection glScaled } ;
+
+
+{ glTranslatef glTranslated glRotatef glRotated glScalef glScaled }
+related-words
+
+

extra/opengl/opengl-docs.factor

@@ -10,7 +10,11 @@ HELP: gl-error
 { $description "If the most recent OpenGL call resulted in an error, print the error to the " { $link stdio } " stream." } ;
 
 HELP: do-state
-{ $values { "what" integer } { "quot" quotation } }
+  {
+    $values
+      { "mode" { "One of the " { $link "opengl-geometric-primitives" } } }
+      { "quot" quotation }
+  }
 { $description "Wraps a quotation in " { $link glBegin } "/" { $link glEnd } " calls." } ;
 
 HELP: do-enabled

extra/opengl/opengl.factor

@@ -25,7 +25,7 @@ IN: opengl
         "GL error: " over gluErrorString append throw
     ] unless drop ;
 
-: do-state ( what quot -- )
+: do-state ( mode quot -- )
     swap glBegin call glEnd ; inline
 
 : do-enabled ( what quot -- )

extra/openssl/libcrypto/libcrypto.factor

@@ -9,11 +9,13 @@ USING: alien alien.syntax combinators kernel system ;
 
 IN: openssl.libcrypto
 
+<<
 "libcrypto" {
-    { [ win32? ] [ "libeay32.dll" "stdcall" ] }
+    { [ win32? ]  [ "libeay32.dll" "cdecl" ] }
     { [ macosx? ] [ "libcrypto.dylib" "cdecl" ] }
-    { [ unix? ] [ "$LD_LIBRARY_PATH/libcrypto.so" "cdecl" ] }
+    { [ unix? ]   [ "libcrypto.so" "cdecl" ] }
 } cond add-library
+>>
 
 C-STRUCT: bio-method
     { "int" "type" }

extra/openssl/libssl/libssl.factor

@@ -10,9 +10,9 @@ USING: alien alien.syntax combinators kernel system ;
 IN: openssl.libssl
 
 << "libssl" {
-    { [ win32? ] [ "ssleay32.dll" "stdcall" ] }
+    { [ win32? ]  [ "ssleay32.dll" "cdecl" ] }
     { [ macosx? ] [ "libssl.dylib" "cdecl" ] }
-    { [ unix? ] [ "$LD_LIBRARY_PATH/libssl.so" "cdecl" ] }
+    { [ unix? ]   [ "libssl.so" "cdecl" ] }
 } cond add-library >>
 
 : X509_FILETYPE_PEM       1 ; inline

extra/openssl/openssl-tests.factor

@@ -21,55 +21,55 @@ namespaces math math.parser openssl prettyprint sequences tools.test ;
 ! Initialize context
 ! =========================================================
 
-init load-error-strings
+[ ] [ init load-error-strings ] unit-test
 
-ssl-v23 new-ctx
+[ ] [ ssl-v23 new-ctx ] unit-test
 
-get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain
+[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path use-cert-chain ] unit-test
 
 ! TODO: debug 'Memory protection fault at address 6c'
 ! get-ctx 1024 "char" malloc-array 1024 0 f password-cb set-default-passwd
 
-get-ctx "password" string>char-alien set-default-passwd-userdata
+[ ] [ get-ctx "password" string>char-alien set-default-passwd-userdata ] unit-test
 
 ! Enter PEM pass phrase: password
-get-ctx "/extra/openssl/test/server.pem" resource-path
+[ ] [ get-ctx "/extra/openssl/test/server.pem" resource-path
-SSL_FILETYPE_PEM use-private-key
+SSL_FILETYPE_PEM use-private-key ] unit-test
 
-get-ctx "/extra/openssl/test/root.pem" resource-path f
+[ ] [ get-ctx "/extra/openssl/test/root.pem" resource-path f
-verify-load-locations
+verify-load-locations ] unit-test
 
-get-ctx 1 set-verify-depth
+[ ] [ get-ctx 1 set-verify-depth ] unit-test
 
 ! =========================================================
 ! Load Diffie-Hellman parameters
 ! =========================================================
 
-"/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file
+[ ] [ "/extra/openssl/test/dh1024.pem" resource-path "r" bio-new-file ] unit-test
 
-get-bio f f f read-pem-dh-params
+[ ] [ get-bio f f f read-pem-dh-params ] unit-test
 
-get-bio bio-free
+[ ] [ get-bio bio-free ] unit-test
 
 ! TODO: debug SSL_CTX_set_tmp_dh 'No such symbol'
-! get-ctx get-dh set-tmp-dh-callback
+[ ] [ get-ctx get-dh set-tmp-dh-callback ] unit-test
 
 ! Workaround (this function should never be called directly)
-get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl
+! [ ] [ get-ctx SSL_CTRL_SET_TMP_DH 0 get-dh set-ctx-ctrl ] unit-test
 
 ! =========================================================
 ! Generate ephemeral RSA key
 ! =========================================================
 
-512 RSA_F4 f f generate-rsa-key
+[ ] [ 512 RSA_F4 f f generate-rsa-key ] unit-test
 
 ! TODO: debug SSL_CTX_set_tmp_rsa 'No such symbol'
 ! get-ctx get-rsa set-tmp-rsa-callback
 
 ! Workaround (this function should never be called directly)
-get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl
+[ ] [ get-ctx SSL_CTRL_SET_TMP_RSA 0 get-rsa set-ctx-ctrl ] unit-test
 
-get-rsa free-rsa
+[ ] [ get-rsa free-rsa ] unit-test
 
 ! =========================================================
 ! Listen and accept on socket
@@ -129,11 +129,11 @@ get-rsa free-rsa
 ! Dump errors to file
 ! =========================================================
 
-"/extra/openssl/test/errors.txt" resource-path "w" bio-new-file
+[ ] [ "/extra/openssl/test/errors.txt" resource-path "w" bio-new-file ] unit-test
 
 [ 6 ] [ get-bio "Hello\n" bio-print ] unit-test
 
-get-bio bio-free
+[ ] [ get-bio bio-free ] unit-test
 
 ! =========================================================
 ! Clean-up

extra/promises/promises.factor

@@ -40,6 +40,6 @@ TUPLE: promise quot forced? value ;
   ] [ ] make ;
 
 : LAZY:
-  CREATE dup reset-generic
+  CREATE-WORD
   dup parse-definition
   make-lazy-quot define ; parsing

extra/reports/noise/noise.factor

@@ -0,0 +1,174 @@
+USING: assocs math kernel shuffle combinators.lib
+words quotations arrays combinators sequences math.vectors
+io.styles combinators.cleave prettyprint vocabs sorting io
+generic locals.private math.statistics ;
+IN: reports.noise
+
+: badness ( word -- n )
+    H{
+        { -nrot 5 }
+        { -roll 4 }
+        { -rot 3 }
+        { 2apply 1 }
+        { 2curry 1 }
+        { 2drop 1 }
+        { 2dup 1 }
+        { 2keep 1 }
+        { 2nip 2 }
+        { 2over 4 }
+        { 2slip 2 }
+        { 2swap 3 }
+        { 2with 2 }
+        { 2with* 3 }
+        { 3apply 1/2 }
+        { 3curry 2 }
+        { 3drop 1 }
+        { 3dup 2 }
+        { 3keep 3 }
+        { 3nip 4 }
+        { 3slip 3 }
+        { 3with 3 }
+        { 3with* 4 }
+        { 4drop 2 }
+        { 4dup 3 }
+        { 4slip 4 }
+        { compose 1/2 }
+        { curry 1/3 }
+        { dip 1 }
+        { dipd 2 }
+        { drop 1/3 }
+        { dup 1/3 }
+        { if 1/3 }
+        { when 1/4 }
+        { unless 1/4 }
+        { when* 1/3 }
+        { unless* 1/3 }
+        { ?if 1/2 }
+        { cond 1/2 }
+        { case 1/2 }
+        { keep 1 }
+        { napply 2 }
+        { ncurry 3 }
+        { ndip 5 }
+        { ndrop 2 }
+        { ndup 3 }
+        { nip 2 }
+        { nipd 3 }
+        { nkeep 5 }
+        { npick 6 }
+        { nrev 5 }
+        { nrot 5 }
+        { nslip 5 }
+        { ntuck 6 }
+        { nwith 4 }
+        { over 2 }
+        { pick 4 }
+        { roll 4 }
+        { rot 3 }
+        { slip 1 }
+        { spin 3 }
+        { swap 1 }
+        { swapd 3 }
+        { tuck 2 }
+        { tuckd 4 }
+        { with 1/2 }
+        { with* 2 }
+        { r> 1 }
+        { >r 1 }
+
+        { bi 1/2 }
+        { tri 1 }
+        { bi* 1/2 }
+        { tri* 1 }
+
+        { cleave 2 }
+        { spread 2 }
+    } at 0 or ;
+
+: vsum { 0 0 } [ v+ ] reduce ;
+
+GENERIC: noise ( obj -- pair )
+
+M: word noise badness 1 2array ;
+
+M: wrapper noise wrapped noise ;
+
+M: let noise let-body noise ;
+
+M: wlet noise wlet-body noise ;
+
+M: lambda noise lambda-body noise ;
+
+M: object noise drop { 0 0 } ;
+
+M: quotation noise [ noise ] map vsum { 1/4 1/2 } v+ ;
+
+M: array noise [ noise ] map vsum ;
+
+: noise-factor / 100 * >integer ;
+
+: quot-noise-factor ( quot -- n )
+    #! For very short words, noise doesn't count so much
+    #! (so dup foo swap bar isn't penalized as badly).
+    noise first2 {
+        { [ over 4 <= ] [ >r drop 0 r> ] }
+        { [ over 15 >= ] [ >r 2 * r> ] }
+        { [ t ] [ ] }
+    } cond
+    {
+        ! short words are easier to read
+        { [ dup 10 <= ] [ >r 2 / r> ] }
+        { [ dup 5 <= ] [ >r 3 / r> ] }
+        ! long words are penalized even more
+        { [ dup 25 >= ] [ >r 2 * r> 20 max ] }
+        { [ dup 20 >= ] [ >r 5/3 * r> ] }
+        { [ dup 15 >= ] [ >r 3/2 * r> ] }
+        { [ t ] [ ] }
+    } cond noise-factor ;
+
+GENERIC: word-noise-factor ( word -- factor )
+
+M: word word-noise-factor
+    word-def quot-noise-factor ;
+
+M: lambda-word word-noise-factor
+    "lambda" word-prop quot-noise-factor ;
+
+: flatten-generics ( words -- words' )
+    [
+        dup generic? [ methods values ] [ 1array ] if
+    ] map concat ;
+
+: noisy-words ( -- alist )
+    all-words flatten-generics
+    [ dup word-noise-factor ] { } map>assoc
+    sort-values reverse ;
+
+: noise. ( alist -- )
+    standard-table-style [
+        [
+            [ [ pprint-cell ] [ pprint-cell ] bi* ] with-row
+        ] assoc-each
+    ] tabular-output ;
+
+: vocab-noise-factor ( vocab -- factor )
+    words flatten-generics
+    [ word-noise-factor dup 20 < [ drop 0 ] when ] map
+    dup empty? [ drop 0 ] [
+        [ [ sum ] [ length 5 max ] bi /i ]
+        [ supremum ]
+        bi +
+    ] if ;
+
+: noisy-vocabs ( -- alist )
+    vocabs [ dup vocab-noise-factor ] { } map>assoc
+    sort-values reverse ;
+
+: noise-report ( -- )
+    "NOISY WORDS:" print
+    noisy-words 80 head noise.
+    nl
+    "NOISY VOCABS:" print
+    noisy-vocabs 80 head noise. ;
+
+MAIN: noise-report

extra/reports/optimizer/optimizer.factor

@@ -0,0 +1,33 @@
+USING: assocs words sequences arrays compiler tools.time
+io.styles io prettyprint vocabs kernel sorting generator
+optimizer math combinators.cleave ;
+IN: report.optimizer
+
+: count-optimization-passes ( nodes n -- n )
+    >r optimize-1
+    [ r> 1+ count-optimization-passes ] [ drop r> ] if ;
+
+: results
+    [ [ second ] swap compose compare ] curry sort 20 tail*
+    print
+    standard-table-style
+    [
+        [ [ [ pprint-cell ] each ] with-row ] each
+    ] tabular-output ; inline
+
+: optimizer-measurements ( -- alist )
+    all-words [ compiled? ] subset
+    [
+        dup [
+            word-dataflow nip 1 count-optimization-passes
+        ] benchmark nip 2array
+    ] { } map>assoc ;
+
+: optimizer-measurements. ( alist -- )
+    [ [ first ] "Worst number of optimizer passes:" results ]
+    [ [ second ] "Worst compile times:" results ] bi ;
+
+: optimizer-report ( -- )
+    optimizer-measurements optimizer-measurements. ;
+
+MAIN: optimizer-report

extra/sequences/lib/lib-tests.factor

@@ -79,3 +79,6 @@ IN: sequences.lib.tests
 [ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
 
 [ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test
+
+[ ] [ { } 0 firstn ] unit-test
+[ "a" ] [ { "a" } 1 firstn ] unit-test