Merge branch 'master' of git://factorcode.org/git/factor into clean-linux-x86-32

.gitignore

@@ -25,3 +25,5 @@ build-support/wordsize
 .#*
 *.swo
 checksums.txt
+*.so
+a.out

basis/alien/parser/parser.factor

@@ -1,7 +1,7 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals ;
+parser sequences splitting words fry locals lexer namespaces ;
 IN: alien.parser
 
 : parse-arglist ( parameters return -- types effect )
@@ -12,8 +12,15 @@ IN: alien.parser
 : function-quot ( return library function types -- quot )
     '[ _ _ _ _ alien-invoke ] ;
 
-:: define-function ( return library function parameters -- )
+:: make-function ( return library function parameters -- word quot effect )
     function create-in dup reset-generic
     return library function
-    parameters return parse-arglist [ function-quot ] dip
+    parameters return parse-arglist [ function-quot ] dip ;
-    define-declared ;
+
+: (FUNCTION:) ( -- word quot effect )
+    scan "c-library" get scan ";" parse-tokens
+    [ "()" subseq? not ] filter
+    make-function ;
+
+: define-function ( return library function parameters -- )
+    make-function define-declared ;

basis/alien/syntax/syntax.factor

@@ -16,9 +16,7 @@ SYNTAX: BAD-ALIEN <bad-alien> parsed ;
 SYNTAX: LIBRARY: scan "c-library" set ;
 
 SYNTAX: FUNCTION:
-    scan "c-library" get scan ";" parse-tokens
+    (FUNCTION:) define-declared ;
-    [ "()" subseq? not ] filter
-    define-function ;
 
 SYNTAX: TYPEDEF:
     scan scan typedef ;

basis/bootstrap/finish-bootstrap.factor

@@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ;
         (command-line) parse-command-line
         load-vocab-roots
         run-user-init
-        "e" get [ eval ] when*
+        "e" get [ eval( -- ) ] when*
         ignore-cli-args? not script get and
         [ run-script ] [ "run" get run ] if*
         output-stream get [ stream-flush ] when*

basis/compiler/errors/errors-docs.factor

@@ -2,33 +2,4 @@ IN: compiler.errors
 USING: help.markup help.syntax vocabs.loader words io
 quotations words.symbol ;
 
-ARTICLE: "compiler-errors" "Compiler warnings and errors"
-"After loading a vocabulary, you might see messages like:"
-{ $code
-    ":errors - print 2 compiler errors"
-    ":warnings - print 50 compiler warnings"
-}
-"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "."
-$nl
-"Words to view warnings and errors:"
-{ $subsection :warnings }
-{ $subsection :errors }
-{ $subsection :linkage }
-"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ;
-
-HELP: compiler-error
-{ $values { "error" "an error" } { "word" word } }
-{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ;
-
-HELP: :errors
-{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
-
-HELP: :warnings
-{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
-
-HELP: :linkage
-{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
-
-{ :errors :warnings } related-words
-
 ABOUT: "compiler-errors"

basis/compiler/errors/errors.factor

@@ -1,7 +1,6 @@
 ! Copyright (C) 2007, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors source-files.errors kernel namespaces assocs
+USING: accessors source-files.errors kernel namespaces assocs ;
-tools.errors ;
 IN: compiler.errors
 
 TUPLE: compiler-error < source-file-error ;
@@ -44,6 +43,7 @@ T{ error-type
    { icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
    { quot [ +linkage-error+ errors-of-type values ] }
    { forget-quot [ compiler-errors get delete-at ] }
+   { fatal? f }
 } define-error-type
 
 : <compiler-error> ( error word -- compiler-error )
@@ -52,12 +52,3 @@ T{ error-type
 : compiler-error ( error word -- )
     compiler-errors get-global pick
     [ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
-
-: compiler-errors. ( type -- )
-    errors-of-type values errors. ;
-
-: :errors ( -- ) +compiler-error+ compiler-errors. ;
-
-: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
-
-: :linkage ( -- ) +linkage-error+ compiler-errors. ;

basis/compiler/tests/folding.factor

@@ -12,7 +12,7 @@ IN: compiler.tests
     IN: compiler.tests.folding
     GENERIC: foldable-generic ( a -- b ) foldable
     M: integer foldable-generic f <array> ;
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ ] [
@@ -20,7 +20,7 @@ IN: compiler.tests
     USING: math arrays ;
     IN: compiler.tests.folding
     : fold-test ( -- x ) 10 foldable-generic ;
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ t ] [

basis/compiler/tests/redefine1.factor

@@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
 
 [ 6 ] [ method-redefine-test-1 ] unit-test
 
-[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" (( -- )) eval ] unit-test
+[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
 
 [ 7 ] [ method-redefine-test-1 ] unit-test
 
@@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
 
 [ 6 ] [ method-redefine-test-2 ] unit-test
 
-[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" (( -- )) eval ] unit-test
+[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
 
 [ 7 ] [ method-redefine-test-2 ] unit-test
 
@@ -43,10 +43,10 @@ M: integer method-redefine-generic-2 3 + ;
 
 [ t ] [ \ hey optimized>> ] unit-test
 [ t ] [ \ there optimized>> ] unit-test
-[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" (( -- )) eval ] unit-test
+[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test
 [ f ] [ \ hey optimized>> ] unit-test
 [ f ] [ \ there optimized>> ] unit-test
-[ ] [ "IN: compiler.tests : hey ( -- ) ;" (( -- )) eval ] unit-test
+[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
 [ t ] [ \ there optimized>> ] unit-test
 
 : good ( -- ) ;
@@ -59,7 +59,7 @@ M: integer method-redefine-generic-2 3 + ;
 
 [ f ] [ \ good compiled-usage assoc-empty? ] unit-test
 
-[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" (( -- )) eval ] unit-test
+[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test
 
 [ f ] [ \ good optimized>> ] unit-test
 [ f ] [ \ bad optimized>> ] unit-test
@@ -67,7 +67,7 @@ M: integer method-redefine-generic-2 3 + ;
 
 [ t ] [ \ good compiled-usage assoc-empty? ] unit-test
 
-[ ] [ "IN: compiler.tests : good ( -- ) ;" (( -- )) eval ] unit-test
+[ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test
 
 [ t ] [ \ good optimized>> ] unit-test
 [ t ] [ \ bad optimized>> ] unit-test

basis/compiler/tests/redefine10.factor

@@ -13,7 +13,7 @@ IN: compiler.tests
     MIXIN: my-mixin
     INSTANCE: fixnum my-mixin
     : my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ ] [
@@ -21,7 +21,7 @@ IN: compiler.tests
     USE: math
     IN: compiler.tests.redefine10
     INSTANCE: float my-mixin
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ 2.0 ] [

basis/compiler/tests/redefine11.factor

@@ -17,7 +17,7 @@ IN: compiler.tests
     M: my-mixin my-generic drop 0 ;
     M: object my-generic drop 1 ;
     : my-inline ( -- b ) { } my-generic ;
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ ] [

basis/compiler/tests/redefine12.factor

@@ -15,6 +15,6 @@ M: object g drop t ;
 
 TUPLE: jeah ;
 
-[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" (( -- )) eval ] unit-test
+[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval( -- ) ] unit-test
 
 [ f ] [ T{ jeah } h ] unit-test

basis/compiler/tests/redefine2.factor

@@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ;
 
 DEFER: redefine2-test
 
-[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" (( -- )) eval ] unit-test
+[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
 
 [ t ] [ \ redefine2-test symbol? ] unit-test
 

basis/compiler/tests/redefine3.factor

@@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
 [ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 [ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
 
-[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" (( -- )) eval ] unit-test
+[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
 
 [ "wake up" ] [ sheeple-test ] unit-test
 [ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

basis/compiler/tests/redefine4.factor

@@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
 
 [ "" ] [ [ declaration-test ] with-string-writer ] unit-test
 
-[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" (( -- )) eval ] unit-test
+[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
 
 [ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

basis/compiler/tests/redefine5.factor

@@ -14,7 +14,7 @@ IN: compiler.tests
     GENERIC: my-generic ( a -- b )
     M: object my-generic [ <=> ] sort ;
     : my-inline ( a -- b ) my-generic ;
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ ] [
@@ -23,7 +23,7 @@ IN: compiler.tests
     IN: compiler.tests.redefine5
     TUPLE: my-tuple ;
     M: my-tuple my-generic drop 0 ;
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ 0 ] [

basis/compiler/tests/redefine6.factor

@@ -14,7 +14,7 @@ IN: compiler.tests
     MIXIN: my-mixin
     M: my-mixin my-generic drop 0 ;
     : my-inline ( a -- b ) { my-mixin } declare my-generic ;
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ ] [
@@ -24,7 +24,7 @@ IN: compiler.tests
     TUPLE: my-tuple ;
     M: my-tuple my-generic drop 1 ;
     INSTANCE: my-tuple my-mixin
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ 1 ] [

basis/compiler/tests/redefine7.factor

@@ -13,7 +13,7 @@ IN: compiler.tests
     MIXIN: my-mixin
     INSTANCE: fixnum my-mixin
     : my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ ] [
@@ -21,7 +21,7 @@ IN: compiler.tests
     USE: math
     IN: compiler.tests.redefine7
     INSTANCE: float my-mixin
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ 2.0 ] [

basis/compiler/tests/redefine8.factor

@@ -16,7 +16,7 @@ IN: compiler.tests
     ! We add the bogus quotation here to hinder inlining
     ! since otherwise we cannot trigger this bug.
     M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ ] [
@@ -24,7 +24,7 @@ IN: compiler.tests
     USE: math
     IN: compiler.tests.redefine8
     INSTANCE: float my-mixin
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ 2.0 ] [

basis/compiler/tests/redefine9.factor

@@ -16,7 +16,7 @@ IN: compiler.tests
     ! We add the bogus quotation here to hinder inlining
     ! since otherwise we cannot trigger this bug.
     M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [ ] [
@@ -25,7 +25,7 @@ IN: compiler.tests
     IN: compiler.tests.redefine9
     TUPLE: my-tuple ;
     INSTANCE: my-tuple my-mixin
-    "> (( -- )) eval
+    "> eval( -- )
 ] unit-test
 
 [

basis/compiler/tests/simple.factor

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

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

@@ -302,7 +302,7 @@ cell-bits 32 = [
 ] unit-test
 
 [ t ] [
-    [ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
+    [ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
 ] unit-test
 
 : rec ( a -- b )

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

@@ -17,13 +17,13 @@ sequences accessors tools.test kernel math ;
 
 [ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
 
-: foo ( a b -- b a ) swap ; inline recursive
+: foo ( quot: ( -- ) -- ) call ; inline recursive
 
 : recursive-inputs ( nodes -- n )
     [ #recursive? ] find nip child>> first in-d>> length ;
 
-[ 0 2 ] [
+[ 1 3 ] [
-    [ foo ] build-tree
+    [ [ swap ] foo ] build-tree
     [ recursive-inputs ]
     [ analyze-recursive normalize recursive-inputs ] bi
 ] unit-test

basis/cpu/ppc/bootstrap.factor

@@ -310,7 +310,7 @@ CONSTANT: rs-reg 30
     4 ds-reg 0 LWZ
     5 ds-reg -4 LWZU
     5 0 4 CMP
-    2 swap execute ! magic number
+    2 swap execute( offset -- ) ! magic number
     \ f tag-number 3 LI
     3 ds-reg 0 STW ;
 
@@ -341,7 +341,7 @@ CONSTANT: rs-reg 30
 : jit-math ( insn -- )
     3 ds-reg 0 LWZ
     4 ds-reg -4 LWZU
-    [ 5 3 4 ] dip execute
+    [ 5 3 4 ] dip execute( dst src1 src2 -- )
     5 ds-reg 0 STW ;
 
 [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive

basis/cpu/x86/bootstrap.factor

@@ -334,7 +334,7 @@ big-endian off
     ! compare with second value
     ds-reg [] temp0 CMP
     ! move t if true
-    [ temp1 temp3 ] dip execute
+    [ temp1 temp3 ] dip execute( dst src -- )
     ! store
     ds-reg [] temp1 MOV ;
 
@@ -355,7 +355,7 @@ big-endian off
     ! pop stack
     ds-reg bootstrap-cell SUB
     ! compute result
-    [ ds-reg [] temp0 ] dip execute ;
+    [ ds-reg [] temp0 ] dip execute( dst src -- ) ;
 
 [ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive
 

basis/delegate/delegate-tests.factor

@@ -35,7 +35,7 @@ M: hello bing hello-test ;
 [ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
 [ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
 
-[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" (( -- )) eval ] times ] unit-test
+[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test
 [ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
 [ H{ } ] [ bee protocol-consult ] unit-test
 
@@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ;
 [ 0 ] [ 1 <hey> three ] unit-test
 [ { hey } ] [ alpha protocol-users ] unit-test
 [ { hey } ] [ beta protocol-users ] unit-test
-[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" (( -- )) eval ] unit-test
+[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test
 [ f ] [ hey \ two method ] unit-test
 [ f ] [ hey \ four method ] unit-test
-[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" (( -- )) eval ] unit-test
+[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test
 [ { hey } ] [ alpha protocol-users ] unit-test
 [ { hey } ] [ beta protocol-users ] unit-test
 [ 2 ] [ 1 <hey> one ] unit-test
 [ 0 ] [ 1 <hey> two ] unit-test
 [ 0 ] [ 1 <hey> three ] unit-test
 [ 0 ] [ 1 <hey> four ] unit-test
-[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" (( -- )) eval ] unit-test
+[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test
 [ 2 ] [ 1 <hey> one ] unit-test
 [ -1 ] [ 1 <hey> two ] unit-test
 [ -1 ] [ 1 <hey> three ] unit-test
 [ -1 ] [ 1 <hey> four ] unit-test
-[ ] [ "IN: delegate.tests FORGET: alpha" (( -- )) eval ] unit-test
+[ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test
 [ f ] [ hey \ one method ] unit-test
 
 TUPLE: slot-protocol-test-1 a b ;

basis/editors/gedit/authors.txt

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

basis/editors/gedit/gedit.factor

@@ -0,0 +1,17 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: editors io.launcher kernel make math.parser namespaces
+sequences ;
+IN: editors.gedit
+
+: gedit-path ( -- path )
+    \ gedit-path get-global [
+        "gedit"
+    ] unless* ;
+
+: gedit ( file line -- )
+    [
+        gedit-path , number>string "+" prepend , ,
+    ] { } make run-detached drop ;
+
+[ gedit ] edit-hook set-global

basis/editors/gedit/summary.txt

@@ -0,0 +1 @@
+gedit integration

basis/eval/eval-tests.factor

@@ -1,4 +1,6 @@
 IN: eval.tests
 USING: eval tools.test ;
 
+[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test
+[ "USE: math 2 2 +" eval( -- ) ] must-fail
 [ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test

basis/fry/fry-tests.factor

@@ -56,7 +56,7 @@ sequences eval accessors ;
     3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
 ] unit-test
 
-[ "USING: fry locals.backend ; f '[ load-local _ ]" (( -- quot )) eval ]
+[ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ]
 [ error>> >r/r>-in-fry-error? ] must-fail-with
 
 [ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [

basis/generalizations/generalizations-docs.factor

@@ -272,8 +272,8 @@ HELP: nweave
 
 HELP: n*quot
 { $values
-     { "n" integer } { "seq" sequence }
+     { "n" integer } { "quot" quotation }
-     { "seq'" sequence }
+     { "quot'" quotation }
 }
 { $examples
     { $example "USING: generalizations prettyprint math ;"

basis/generalizations/generalizations.factor

@@ -7,7 +7,7 @@ IN: generalizations
 
 <<
 
-: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
+: n*quot ( n quot -- quot' ) <repetition> concat >quotation ;
 
 : repeat ( n obj quot -- ) swapd times ; inline
 

basis/help/crossref/crossref-tests.factor

@@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays
 io.streams.string continuations debugger compiler.units eval ;
 
 [ ] [
-    "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" (( -- )) eval
+    "IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
 ] unit-test
 
 [ $subsection ] [
@@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
 ] unit-test
 
 [ ] [
-    "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" (( -- )) eval
+    "IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval( -- )
 ] unit-test
 
 [ ] [

basis/help/definitions/definitions-tests.factor

@@ -32,7 +32,7 @@ IN: help.definitions.tests
         "hello" "help.definitions.tests" lookup "help" word-prop
     ] unit-test
 
-    [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" (( -- )) eval ] unit-test
+    [ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval( -- ) ] unit-test
 
     [ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test
 

basis/help/syntax/syntax-tests.factor

@@ -4,12 +4,12 @@ IN: help.syntax.tests
 
 [
     [ "foobar" ] [
-        "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" (( -- )) eval
+        "IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval( -- )
         "help.syntax.tests" vocab vocab-help
     ] unit-test
     
     [ { "foobar" } ] [
-        "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" (( -- )) eval
+        "IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval( -- )
         "help.syntax.tests" vocab vocab-help
     ] unit-test
     

basis/help/topics/topics-tests.factor

@@ -29,7 +29,7 @@ SYMBOL: foo
     } "\n" join
     [
         "testfile" source-file file set
-        (( -- )) eval
+        eval( -- )
     ] with-scope
 ] unit-test
 

basis/http/client/client.factor

@@ -184,6 +184,12 @@ ERROR: download-failed response ;
 : http-put ( post-data url -- response data )
     <put-request> http-request ;
 
+: <delete-request> ( url -- request )
+    "DELETE" <client-request> ;
+
+: http-delete ( url -- response data )
+    <delete-request> http-request ;
+
 USING: vocabs vocabs.loader ;
 
 "debugger" vocab [ "http.client.debugger" require ] when

basis/io/crlf/crlf-tests.factor

@@ -0,0 +1,8 @@
+IN: io.crlf.tests
+USING: io.crlf tools.test io.streams.string io ;
+
+[ "Hello, world." ] [ "Hello, world." [ read-crlf ] with-string-reader ] unit-test
+[ "Hello, world." ] [ "Hello, world.\r\n" [ read-crlf ] with-string-reader ] unit-test
+[ "Hello, world.\r" [ read-crlf ] with-string-reader ] must-fail
+[ f ] [ "" [ read-crlf ] with-string-reader ] unit-test
+[ "" ] [ "\r\n" [ read-crlf ] with-string-reader ] unit-test

basis/io/crlf/crlf.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: io kernel ;
+USING: io kernel sequences ;
 IN: io.crlf
 
 : crlf ( -- )
@@ -8,4 +8,4 @@ IN: io.crlf
 
 : read-crlf ( -- seq )
     "\r" read-until
-    [ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
+    [ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ;

basis/io/launcher/windows/nt/nt-tests.factor

@@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests
         <process>
             console-vm "-script" "env.factor" 3array >>command
         ascii <process-reader> contents
-    ] with-directory eval
+    ] with-directory eval( -- alist )
 
     os-envs =
 ] unit-test
@@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests
             +replace-environment+ >>environment-mode
             os-envs >>environment
         ascii <process-reader> contents
-    ] with-directory eval
+    ] with-directory eval( -- alist )
     
     os-envs =
 ] unit-test
@@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests
             console-vm "-script" "env.factor" 3array >>command
             { { "A" "B" } } >>environment
         ascii <process-reader> contents
-    ] with-directory eval
+    ] with-directory eval( -- alist )
 
     "A" swap at
 ] unit-test
@@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests
             { { "USERPROFILE" "XXX" } } >>environment
             +prepend-environment+ >>environment-mode
         ascii <process-reader> contents
-    ] with-directory eval
+    ] with-directory eval( -- alist )
 
     "USERPROFILE" swap at "XXX" =
 ] unit-test

basis/listener/listener-tests.factor

@@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ;
                 "\\ + 1 2 3 4" parse-interactive
                 "cont" get continue-with
             ] ignore-errors
-            "USE: debugger :1" (( -- quot )) eval
+            "USE: debugger :1" eval( -- quot )
         ] callcc1
     ] unit-test
 ] with-file-vocabs

basis/locals/locals-tests.factor

@@ -261,7 +261,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
 
 CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
 
-[ ] [ new-definition (( -- )) eval ] unit-test
+[ ] [ new-definition eval( -- ) ] unit-test
 
 [ t ] [
     [ \ a-word-with-locals see ] with-string-writer
@@ -461,7 +461,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 
 [
     "USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
-    (( -- )) eval call
+    eval( -- ) call
 ] [ error>> >r/r>-in-fry-error? ] must-fail-with
     
 :: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
@@ -473,10 +473,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 [ f ] [ 2 funny-macro-test ] unit-test
 
 ! Some odd parser corner cases
-[ "USE: locals [let" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [let |" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [let | a" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
-[ "USE: locals [|" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
+[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
 
 [ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
 [ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
@@ -491,19 +491,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
 
 [ 3 ] [ 3 [| a | \ a ] call ] unit-test
 
-[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail
+[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
 
-[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail
+[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
 
-[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail
+[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
 
-[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" (( -- )) eval ] must-fail
+[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
 
-[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" (( -- )) eval ] must-fail
+[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
 
-[ "USE: locals [| | { :> a } ]" (( -- )) eval ] must-fail
+[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
 
-[ "USE: locals 3 :> a" (( -- )) eval ] must-fail
+[ "USE: locals 3 :> a" eval( -- ) ] must-fail
 
 [ 3 ] [ 3 [| | :> a a ] call ] unit-test
 

basis/macros/macros-tests.factor

@@ -13,11 +13,11 @@ unit-test
 [ t ] [ \ see-test macro? ] unit-test
 
 [ t ] [
-    "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup (( -- )) eval
+    "USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval( -- )
     [ \ see-test see ] with-string-writer =
 ] unit-test
 
 [ f ] [ \ see-test macro? ] unit-test
 
-[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" (( -- )) eval ] unit-test
+[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test
 

basis/memoize/memoize-tests.factor

@@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
 
 [ 89 ] [ 10 fib ] unit-test
 
-[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" (( -- )) eval ] must-fail
+[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail
 
 MEMO: see-test ( a -- b ) reverse ;
 
@@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ;
 [ [ \ see-test see ] with-string-writer ]
 unit-test
 
-[ ] [ "IN: memoize.tests : fib ( -- ) ;" (( -- )) eval ] unit-test
+[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval( -- ) ] unit-test
 
 [ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test
 

basis/mirrors/mirrors-tests.factor

@@ -56,6 +56,6 @@ TUPLE: color
 ! Test reshaping with a mirror
 1 2 3 color boa <mirror> "mirror" set
 
-[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" (( -- )) eval ] unit-test
+[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval( -- ) ] unit-test
 
 [ 1 ] [ "red" "mirror" get at ] unit-test

basis/peg/ebnf/ebnf-tests.factor

@@ -445,11 +445,11 @@ foo=<foreign any-char> 'd'
 ] unit-test
 
 { } [
- "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n'  => [[ drop \"\n\" ]] EBNF] drop" (( -- )) eval 
+ "USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n'  => [[ drop \"\n\" ]] EBNF] drop" eval( -- ) 
 ] unit-test
 
 [
-  "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" (( -- )) eval drop
+  "USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval( -- ) drop
 ] must-fail
 
 { t } [
@@ -521,12 +521,12 @@ Tok                = Spaces (Number | Special )
   "\\" [EBNF foo="\\" EBNF]
 ] unit-test
 
-[ "USE: peg.ebnf [EBNF EBNF]" (( -- )) eval ] must-fail
+[ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail
 
 [ <" USE: peg.ebnf [EBNF
     lol = a
     lol = b
-  EBNF] "> (( -- )) eval
+  EBNF] "> eval( -- )
 ] [
     error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
 ] must-fail-with

basis/prettyprint/prettyprint-tests.factor

@@ -2,8 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex
 kernel math namespaces parser prettyprint prettyprint.config
 prettyprint.sections sequences tools.test vectors words
 effects splitting generic.standard prettyprint.private
-continuations generic compiler.units tools.walker eval
+continuations generic compiler.units tools.continuations
-accessors make vocabs.parser see ;
+tools.continuations.private eval accessors make vocabs.parser see ;
 IN: prettyprint.tests
 
 [ "4" ] [ 4 unparse ] unit-test
@@ -254,7 +254,7 @@ M: class-see-layout class-see-layout ;
 ! Regression
 [ t ] [
     "IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
-    dup (( -- )) eval
+    dup eval( -- )
     "generic-decl-test" "prettyprint.tests" lookup
     [ see ] with-string-writer =
 ] unit-test

basis/refs/authors.txt

@@ -1 +1,2 @@
 Slava Pestov
+Alex Chapman

basis/refs/refs-docs.factor

@@ -1,37 +1,89 @@
-! Copyright (C) 2007 Slava Pestov
+! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax kernel ;
+USING: boxes help.markup help.syntax kernel math namespaces ;
 IN: refs
 
-ARTICLE: "refs" "References to assoc entries"
+ARTICLE: "refs" "References"
-"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary."
+"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "."
 { $subsection get-ref }
 { $subsection set-ref }
+{ $subsection set-ref* }
 { $subsection delete-ref }
-"References to keys:"
+"References to objects:"
+{ $subsection obj-ref }
+{ $subsection <obj-ref> }
+"References to assoc keys:"
 { $subsection key-ref }
 { $subsection <key-ref> }
-"References to values:"
+"References to assoc values:"
 { $subsection value-ref }
 { $subsection <value-ref> }
+"References to variables:"
+{ $subsection var-ref }
+{ $subsection <var-ref> }
+{ $subsection global-var-ref }
+{ $subsection <global-var-ref> }
+"References to tuple slots:"
+{ $subsection slot-ref }
+{ $subsection <slot-ref> }
+"Using boxes as references:"
+{ $subsection "box-refs" }
 "References are used by the UI inspector." ;
 
 ABOUT: "refs"
 
+ARTICLE: "refs-protocol" "Reference Protocol"
+"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
+{ $subsection get-ref }
+{ $subsection set-ref }
+"References may also implement:"
+{ $subsection delete-ref } ;
+
+ARTICLE: "box-refs" "Using Boxes as References"
+"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
+
 HELP: ref
-{ $class-description "A class whose instances identify a key or value location in an associative structure. Instances of this clas are never used directly; only instances of " { $link key-ref } " and " { $link value-ref } " should be created." } ;
+{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
 
 HELP: delete-ref
 { $values { "ref" ref } }
-{ $description "Deletes the association entry pointed at by this reference." } ;
+{ $description "Deletes the value pointed to by this reference. In most references this simply sets the value to f, but in some cases it is more destructive, such as in " { $link value-ref } " and " { $link key-ref } ", where it actually deletes the entry from the underlying assoc." } ;
 
 HELP: get-ref
 { $values { "ref" ref } { "obj" object } }
-{ $description "Outputs the key or the value pointed at by this reference." } ;
+{ $description "Outputs the value pointed at by this reference." } ;
 
 HELP: set-ref
 { $values { "obj" object } { "ref" ref } }
-{ $description "Stores a new key or value at by this reference." } ;
+{ $description "Stores a new value at this reference." } ;
+
+HELP: obj-ref
+{ $class-description "Instances of this class contain a value which can be changed using the " { $link "refs-protocol" } ". New object references are created by calling " { $link <obj-ref> } "." } ;
+
+HELP: <obj-ref>
+{ $values { "obj" object } { "obj-ref" obj-ref } }
+{ $description "Creates a reference which contains the value it references." } ;
+
+HELP: var-ref
+{ $class-description "Instances of this class reference a variable as defined by the " { $vocab-link "namespaces" } " vocabulary. New variable references are created by calling " { $link <var-ref> } "." } ;
+
+HELP: <var-ref>
+{ $values { "var" object } { "var-ref" var-ref } }
+{ $description "Creates a reference to the given variable. Note that this reference behaves just like any variable when it comes to dynamic scope. For example, if you use " { $link set-ref } " in an inner scope and then leave that scope, then calling " { $link get-ref } " may not return the expected value. If this is not what you want, try using an " { $link obj-ref } " instead." } ;
+ 
+HELP: global-var-ref
+{ $class-description "Instances of this class reference a global variable. New global references are created by calling " { $link <global-var-ref> } "." } ;
+
+HELP: <global-var-ref>
+{ $values { "var" object } { "global-var-ref" global-var-ref } }
+{ $description "Creates a reference to a global variable." } ;
+
+HELP: slot-ref
+{ $class-description "Instances of this class identify a particular slot of a particular instance of a tuple. New slot references are created by calling " { $link <slot-ref> } "." } ;
+
+HELP: <slot-ref>
+{ $values { "tuple" tuple } { "slot" integer } { "slot-ref" slot-ref } }
+{ $description "Creates a reference to the value in a particular slot of the given tuple. The slot must be given as an integer, where the first user-defined slot is number 2. This is mostly just a proof of concept until we have a way of generating this slot number from a slot name." } ;
   
 HELP: key-ref
 { $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;
@@ -47,6 +99,37 @@ HELP: <value-ref>
 { $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } }
 { $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;
 
-{ get-ref set-ref delete-ref } related-words
+{ get-ref set-ref delete-ref set-ref* } related-words
   
-{ <key-ref> <value-ref> } related-words
+{ <obj-ref> <var-ref> <global-var-ref> <slot-ref> <key-ref> <value-ref> } related-words
+
+HELP: set-ref*
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Just like " { $link set-ref } ", but leave the ref on the stack." } ;
+
+HELP: ref-on
+{ $values { "ref" ref } }
+{ $description "Sets the value of the ref to t." } ;
+
+HELP: ref-off
+{ $values { "ref" ref } }
+{ $description "Sets the value of the ref to f." } ;
+
+HELP: ref-inc
+{ $values { "ref" ref } }
+{ $description "Increment the value of the ref by 1." } ;
+
+HELP: ref-dec
+{ $values { "ref" ref } }
+{ $description "Decrement the value of the ref by 1." } ;
+
+HELP: take
+{ $values { "ref" ref } { "obj" object } }
+{ $description "Retrieve the value of the ref and then delete it, returning the value." } ;
+  
+{ ref-on ref-off ref-inc ref-dec take } related-words
+{ take delete-ref } related-words
+{ on ref-on } related-words
+{ off ref-off } related-words
+{ inc ref-inc } related-words
+{ dec ref-dec } related-words

basis/refs/refs-tests.factor

@@ -1,5 +1,7 @@
-USING: refs tools.test kernel ;
+USING: boxes kernel namespaces refs tools.test ;
+IN: refs.tests
 
+! assoc-refs
 [ 3 ] [
     H{ { "a" 3 } } "a" <value-ref> get-ref
 ] unit-test
@@ -20,3 +22,84 @@ USING: refs tools.test kernel ;
         set-ref
     ] keep
 ] unit-test
+
+SYMBOLS: lion giraffe elephant rabbit ;
+
+! obj-refs
+[ rabbit ] [ rabbit <obj-ref> get-ref ] unit-test
+[ rabbit ] [ f <obj-ref> rabbit set-ref* get-ref ] unit-test
+[ rabbit ] [ rabbit <obj-ref> take ] unit-test
+[ rabbit f ] [ rabbit <obj-ref> [ take ] keep get-ref ] unit-test
+[ lion ] [ rabbit <obj-ref> dup [ drop lion ] change-ref get-ref ] unit-test
+
+! var-refs 
+[ giraffe ] [ [ giraffe rabbit set rabbit <var-ref> get-ref ] with-scope ] unit-test
+
+[ rabbit ]
+[
+    [
+        lion rabbit set [
+            rabbit rabbit set rabbit <var-ref> get-ref
+        ] with-scope
+    ] with-scope
+] unit-test
+
+[ rabbit ] [
+    rabbit <var-ref>
+    [
+        lion rabbit set [
+            rabbit rabbit set get-ref
+        ] with-scope
+    ] with-scope
+] unit-test
+
+[ elephant ] [
+    rabbit <var-ref>
+    [
+        elephant rabbit set [
+            rabbit rabbit set
+        ] with-scope
+        get-ref
+    ] with-scope
+] unit-test
+
+[ rabbit ] [
+    rabbit <var-ref>
+    [
+        elephant set-ref* [
+            rabbit set-ref* get-ref
+        ] with-scope
+    ] with-scope
+] unit-test
+
+[ elephant ] [
+    rabbit <var-ref>
+    [
+        elephant set-ref* [
+            rabbit set-ref*
+        ] with-scope
+        get-ref
+    ] with-scope
+] unit-test
+
+! Top Hats
+[ lion ] [ lion rabbit set-global rabbit <global-var-ref> get-ref ] unit-test
+[ giraffe ] [ rabbit <global-var-ref> giraffe set-ref* get-ref ] unit-test
+
+! Tuple refs
+TUPLE: foo bar ;
+C: <foo> foo
+
+: test-tuple ( -- tuple )
+    rabbit <foo> ;
+
+: test-slot-ref ( -- slot-ref )
+    test-tuple 2 <slot-ref> ; ! hack!
+
+[ rabbit ] [ test-slot-ref get-ref ] unit-test
+[ lion ] [ test-slot-ref lion set-ref* get-ref ] unit-test
+
+! Boxes as refs
+[ rabbit ] [ <box> rabbit set-ref* get-ref ] unit-test
+[ <box> rabbit set-ref* lion set-ref* ] must-fail
+[ <box> get-ref ] must-fail

basis/refs/refs.factor

@@ -1,22 +1,77 @@
-! Copyright (C) 2007, 2008 Slava Pestov
+! Copyright (C) 2007, 2008 Slava Pestov, 2009 Alex Chapman
 ! See http://factorcode.org/license.txt for BSD license.
-USING: classes.tuple kernel assocs accessors ;
+USING: kernel assocs accessors boxes math namespaces ;
 IN: refs
 
-TUPLE: ref assoc key ;
+MIXIN: ref
 
-: >ref< ( ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
-
-: delete-ref ( ref -- ) >ref< delete-at ;
 GENERIC: get-ref ( ref -- obj )
 GENERIC: set-ref ( obj ref -- )
+GENERIC: delete-ref ( ref -- )
 
-TUPLE: key-ref < ref ;
+! works like >>slot words
+: set-ref* ( ref obj -- ref ) over set-ref ;
+
+! very similar to change, on, off, +@, inc, and dec from namespaces
+: change-ref ( ref quot -- )
+    [ [ get-ref ] keep ] dip dip set-ref ; inline
+: ref-on ( ref -- ) t swap set-ref ;
+: ref-off ( ref -- ) f swap set-ref ;
+: ref-+@ ( n ref -- ) [ 0 or + ] change-ref ;
+: ref-inc ( ref -- ) 1 swap ref-+@ ;
+: ref-dec ( ref -- ) -1 swap ref-+@ ;
+
+: take ( ref -- obj )
+    dup get-ref swap delete-ref ;
+
+! delete-ref defaults to setting ref to f
+M: ref delete-ref ref-off ;
+
+TUPLE: obj-ref obj ;
+C: <obj-ref> obj-ref
+M: obj-ref get-ref obj>> ;
+M: obj-ref set-ref (>>obj) ;
+INSTANCE: obj-ref ref
+
+TUPLE: var-ref var ;
+C: <var-ref> var-ref
+M: var-ref get-ref var>> get ;
+M: var-ref set-ref var>> set ;
+INSTANCE: var-ref ref
+
+TUPLE: global-var-ref var ;
+C: <global-var-ref> global-var-ref
+M: global-var-ref get-ref var>> get-global ;
+M: global-var-ref set-ref var>> set-global ;
+INSTANCE: global-var-ref ref
+
+USE: slots.private
+TUPLE: slot-ref tuple slot ;
+C: <slot-ref> slot-ref
+: >slot-ref< ( slot-ref -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
+M: slot-ref get-ref >slot-ref< slot ;
+M: slot-ref set-ref >slot-ref< set-slot ;
+INSTANCE: slot-ref ref
+
+M: box get-ref box> ;
+M: box set-ref >box ;
+M: box delete-ref box> drop ;
+INSTANCE: box ref
+
+TUPLE: assoc-ref assoc key ;
+
+: >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
+
+M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ;
+
+TUPLE: key-ref < assoc-ref ;
 C: <key-ref> key-ref
 M: key-ref get-ref key>> ;
-M: key-ref set-ref >ref< rename-at ;
+M: key-ref set-ref >assoc-ref< rename-at ;
+INSTANCE: key-ref ref
 
-TUPLE: value-ref < ref ;
+TUPLE: value-ref < assoc-ref ;
 C: <value-ref> value-ref
-M: value-ref get-ref >ref< at ;
+M: value-ref get-ref >assoc-ref< at ;
-M: value-ref set-ref >ref< set-at ;
+M: value-ref set-ref >assoc-ref< set-at ;
+INSTANCE: value-ref ref

basis/regexp/regexp-tests.factor

@@ -262,11 +262,11 @@ IN: regexp-tests
 ! Comment inside a regular expression
 [ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
 
-[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" (( -- )) eval ] unit-test
+[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval( -- ) ] unit-test
 
-[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" (( -- )) eval ] unit-test
+[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval( -- ) ] unit-test
 
-[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" (( -- )) eval ] unit-test
+[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval( -- ) ] unit-test
 
 [ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
 [ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test

basis/smtp/authors.txt

@@ -1,3 +1,5 @@
 Elie Chaftari
 Dirk Vleugels
 Slava Pestov
+Doug Coleman
+Daniel Ehrenberg

basis/smtp/server/server.factor

@@ -36,6 +36,7 @@ SYMBOL: data-mode
 
 : process ( -- )
     read-crlf {
+        { [ dup not ] [ f ] }
         {
             [ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
             [ "220 and..?\r\n" write flush t ]

basis/smtp/smtp-docs.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2008 Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors kernel quotations help.syntax help.markup
-io.sockets strings calendar ;
+io.sockets strings calendar io.encodings.utf8 ;
 IN: smtp
 
 HELP: smtp-domain
@@ -42,6 +42,8 @@ HELP: email
         { { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." }
         { { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." }
         { { $slot "subject" } "The subject of the e-mail. A string." }
+        { { $slot "content-type" } { "The MIME type of the body. A string, default is " { $snippet "text/plain" } "." } }
+        { { $slot "encoding" } { "An encoding to send the body as. Default is " { $link utf8 } "." } }
         { { $slot "body" } " The body of the e-mail. A string." }
     }
 "The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional."

basis/smtp/smtp-tests.factor

@@ -16,7 +16,7 @@ IN: smtp.tests
 [ { "hello" "." "world" } validate-message ] must-fail
 
 [ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
-    "hello\nworld" [ send-body ] with-string-writer
+    T{ email { body "hello\nworld" } } [ send-body ] with-string-writer
 ] unit-test
 
 [ { "500 syntax error" } <response> check-response ]
@@ -51,7 +51,7 @@ IN: smtp.tests
 [
     {
         { "Content-Transfer-Encoding" "base64" }
-        { "Content-Type" "Text/plain; charset=utf-8" }
+        { "Content-Type" "text/plain; charset=UTF-8" }
         { "From" "Doug <erg@factorcode.org>" }
         { "MIME-Version" "1.0" }
         { "Subject" "Factor rules" }

basis/smtp/smtp.factor

@@ -1,12 +1,12 @@
 ! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
-! Slava Pestov, Doug Coleman.
+! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: arrays namespaces make io io.encodings.string
+USING: arrays namespaces make io io.encodings.string io.encodings.utf8
-io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
+io.encodings.iana io.timeouts io.sockets io.sockets.secure
-io.encodings.ascii kernel logging sequences combinators
+io.encodings.ascii kernel logging sequences combinators splitting
-splitting assocs strings math.order math.parser random system
+assocs strings math.order math.parser random system calendar summary
-calendar summary calendar.format accessors sets hashtables
+calendar.format accessors sets hashtables base64 debugger classes
-base64 debugger classes prettyprint io.crlf ;
+prettyprint io.crlf words ;
 IN: smtp
 
 SYMBOL: smtp-domain
@@ -44,6 +44,8 @@ TUPLE: email
     { cc array }
     { bcc array }
     { subject string }
+    { content-type string initial: "text/plain" }
+    { encoding word initial: utf8 }
     { body string } ;
 
 : <email> ( -- email ) email new ; inline
@@ -85,8 +87,8 @@ M: message-contains-dot summary ( obj -- string )
     "." over member?
     [ message-contains-dot ] when ;
 
-: send-body ( body -- )
+: send-body ( email -- )
-    utf8 encode
+    [ body>> ] [ encoding>> ] bi encode
     >base64-lines write crlf
     "." command ;
 
@@ -195,24 +197,23 @@ ERROR: invalid-header-string string ;
     ! This could be much smarter.
     " " split1-last swap or "<" ?head drop ">" ?tail drop ;
 
-: utf8-mime-header ( -- alist )
+: email-content-type ( email -- content-type )
-    {
+    [ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
-        { "MIME-Version" "1.0" }
-        { "Content-Transfer-Encoding" "base64" }
-        { "Content-Type" "Text/plain; charset=utf-8" }
-    } ;
 
-: email>headers ( email -- hashtable )
+: email>headers ( email -- assoc )
     [
+        now timestamp>rfc822 "Date" set
+        message-id "Message-Id" set
+        "1.0" "MIME-Version" set
+        "base64" "Content-Transfer-Encoding" set
         {
             [ from>> "From" set ]
             [ to>> ", " join "To" set ]
             [ cc>> ", " join [ "Cc" set ] unless-empty ]
             [ subject>> "Subject" set ]
+            [ email-content-type "Content-Type" set ]
         } cleave
-        now timestamp>rfc822 "Date" set
+    ] { } make-assoc ;
-        message-id "Message-Id" set
-    ] { } make-assoc utf8-mime-header append ;
 
 : (send-email) ( headers email -- )
     [
@@ -227,7 +228,7 @@ ERROR: invalid-header-string string ;
         data get-ok
         swap write-headers
         crlf
-        body>> send-body get-ok
+        send-body get-ok
         quit get-ok
     ] with-smtp-connection ;
 

basis/sorting/slots/slots-docs.factor

@@ -14,7 +14,7 @@ HELP: compare-slots
 HELP: sort-by-slots
 { $values
      { "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
-     { "sortedseq" sequence }
+     { "seq'" sequence }
 }
 { $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
 { $examples
@@ -42,7 +42,7 @@ HELP: split-by-slots
 HELP: sort-by
 { $values
     { "seq" sequence } { "sort-seq" "a sequence of comparators" }
-    { "sortedseq" sequence }
+    { "seq'" sequence }
 }
 { $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
 

basis/sorting/slots/slots-tests.factor

@@ -159,3 +159,15 @@ TUPLE: tuple2 d ;
     { { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
     { length-test<=> <=> } sort-by
 ] unit-test
+
+[ { { 0 1 } { 1 2 } { 1 1 } { 3 2 } } ]
+[
+    { { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
+    { length-test<=> <=> } sort-keys-by
+] unit-test
+
+[ { { 0 1 } { 1 1 } { 3 2 } { 1 2 } } ]
+[
+    { { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
+    { length-test<=> <=> } sort-values-by
+] unit-test

basis/sorting/slots/slots.factor

@@ -8,12 +8,13 @@ IN: sorting.slots
 <PRIVATE
 
 : short-circuit-comparator ( obj1 obj2 word --  comparator/? )
-    execute dup +eq+ eq? [ drop f ] when ; inline
+    execute( obj1 obj2 -- obj3 )
+    dup +eq+ eq? [ drop f ] when ; inline
 
 : slot-comparator ( seq -- quot )
     [
         but-last-slice
-        [ '[ [ _ execute ] bi@ ] ] map concat
+        [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat
     ] [
         peek
         '[ @ _ short-circuit-comparator ]
@@ -25,21 +26,22 @@ MACRO: compare-slots ( sort-specs -- <=> )
     #! sort-spec: { accessors comparator }
     [ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
 
-MACRO: sort-by-slots ( sort-specs -- quot )
+: sort-by-slots ( seq sort-specs -- seq' )
-    '[ [ _ compare-slots ] sort ] ;
+    '[ _ compare-slots ] sort ;
 
 MACRO: compare-seq ( seq -- quot )
     [ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
 
-MACRO: sort-by ( sort-seq -- quot )
+: sort-by ( seq sort-seq -- seq' )
-    '[ [ _ compare-seq ] sort ] ;
+    '[ _ compare-seq ] sort ;
 
-MACRO: sort-keys-by ( sort-seq -- quot )
+: sort-keys-by ( seq sort-seq -- seq' )
     '[ [ first ] bi@ _ compare-seq ] sort ;
 
-MACRO: sort-values-by ( sort-seq -- quot )
+: sort-values-by ( seq sort-seq -- seq' )
     '[ [ second ] bi@ _ compare-seq ] sort ;
 
 MACRO: split-by-slots ( accessor-seqs -- quot )
-    [ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
+    [ [ '[ [ _ execute( tuple -- value ) ] bi@ ] ] map concat
+    [ = ] compose ] map
     '[ [ _ 2&& ] slice monotonic-slice ] ;

basis/stack-checker/stack-checker-tests.factor

@@ -524,7 +524,7 @@ ERROR: custom-error ;
 
 { 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
 
-[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" (( -- )) eval ] unit-test
+[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval( -- ) ] unit-test
 
 [ 3 ] [ inference-invalidation-c ] unit-test
 
@@ -536,7 +536,7 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
 
 \ inference-invalidation-d must-infer
 
-[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" (( -- )) eval ] unit-test
+[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval( -- ) ] unit-test
 
 [ [ inference-invalidation-d ] infer ] must-fail
 

basis/tools/annotations/annotations-tests.factor

@@ -18,7 +18,7 @@ M: integer some-generic 1+ ;
 
 [ 4 ] [ 3 some-generic ] unit-test
 
-[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" (( -- )) eval ] unit-test
+[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test
 
 [ 2 ] [ 3 some-generic ] unit-test
 
@@ -33,7 +33,7 @@ M: object another-generic ;
 
 \ another-generic watch
 
-[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" (( -- )) eval ] unit-test
+[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval( -- ) ] unit-test
 
 [ ] [ \ another-generic reset ] unit-test
 

basis/tools/deploy/shaker/shaker.factor

@@ -357,7 +357,7 @@ IN: tools.deploy.shaker
     V{ } set-namestack
     V{ } set-catchstack
     "Saving final image" show
-    [ save-image-and-exit ] call-clear ;
+    save-image-and-exit ;
 
 SYMBOL: deploy-vocab
 
@@ -421,10 +421,10 @@ SYMBOL: deploy-vocab
 : deploy-error-handler ( quot -- )
     [
         strip-debugger?
-        [ error-continuation get call>> callstack>array die ]
+        [ error-continuation get call>> callstack>array die 1 exit ]
         ! Don't reference these words literally, if we're stripping the
         ! debugger out we don't want to load the prettyprinter at all
-        [ [:c] execute nl [print-error] execute flush ] if
+        [ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
         1 exit
     ] recover ; inline
 

basis/tools/errors/errors-docs.factor

@@ -1,5 +1,35 @@
 IN: tools.errors
-USING: help.markup help.syntax source-files.errors ;
+USING: help.markup help.syntax source-files.errors words io
+compiler.errors ;
+
+ARTICLE: "compiler-errors" "Compiler warnings and errors"
+"After loading a vocabulary, you might see messages like:"
+{ $code
+    ":errors - print 2 compiler errors"
+    ":warnings - print 50 compiler warnings"
+}
+"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "."
+$nl
+"Words to view warnings and errors:"
+{ $subsection :warnings }
+{ $subsection :errors }
+{ $subsection :linkage }
+"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ;
+
+HELP: compiler-error
+{ $values { "error" "an error" } { "word" word } }
+{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ;
+
+HELP: :errors
+{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
+
+HELP: :warnings
+{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
+
+HELP: :linkage
+{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
+
+{ :errors :warnings :linkage } related-words
 
 HELP: errors.
 { $values { "errors" "a sequence of " { $link source-file-error } " instances" } }

basis/tools/errors/errors.factor

@@ -1,35 +1,28 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: assocs debugger io kernel sequences source-files.errors
-summary accessors continuations make math.parser io.styles namespaces ;
+summary accessors continuations make math.parser io.styles namespaces
+compiler.errors ;
 IN: tools.errors
 
 #! Tools for source-files.errors. Used by tools.tests and others
 #! for error reporting
 
-M: source-file-error summary
-    error>> summary ;
-
 M: source-file-error compute-restarts
     error>> compute-restarts ;
 
 M: source-file-error error-help
     error>> error-help ;
 
-M: source-file-error error.
+M: source-file-error summary
     [
-        [
+        [ file>> [ % ": " % ] [ "<Listener input>" % ] if* ]
-            [
+        [ line#>> [ # ] when* ] bi
-                [ file>> [ % ": " % ] when* ]
-                [ line#>> [ # "\n" % ] when* ] bi
     ] "" make
-        ] [
+    ;
-            [
+
-                presented set
+M: source-file-error error.
-                bold font-style set
+    [ summary print nl ] [ error>> error. ] bi ;
-            ] H{ } make-assoc
-        ] bi format
-    ] [ error>> error. ] bi ;
 
 : errors. ( errors -- )
     group-by-source-file sort-errors
@@ -38,3 +31,12 @@ M: source-file-error error.
         [ [ nl ] [ error. ] interleave ]
         bi*
     ] assoc-each ;
+
+: compiler-errors. ( type -- )
+    errors-of-type values errors. ;
+
+: :errors ( -- ) +compiler-error+ compiler-errors. ;
+
+: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
+
+: :linkage ( -- ) +linkage-error+ compiler-errors. ;

basis/tools/scaffold/scaffold.factor

@@ -24,6 +24,9 @@ ERROR: no-vocab vocab ;
 
 : contains-separator? ( string -- ? ) [ path-separator? ] any? ;
 
+: ensure-vocab-exists ( string -- string )
+    dup vocabs member? [ no-vocab ] unless ;
+
 : check-vocab-name ( string -- string )
     [ ]
     [ contains-dot? [ vocab-name-contains-dot ] when ]
@@ -234,6 +237,7 @@ PRIVATE>
     [ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
 
 : scaffold-help ( vocab -- )
+    ensure-vocab-exists
     [
         dup "-docs.factor" vocab/suffix>path scaffolding? [
             set-scaffold-docs-file
@@ -268,6 +272,7 @@ PRIVATE>
 PRIVATE>
 
 : scaffold-tests ( vocab -- )
+    ensure-vocab-exists
     dup "-tests.factor" vocab/suffix>path
     scaffolding? [
         set-scaffold-tests-file

basis/tools/test/test.factor

@@ -129,13 +129,13 @@ TEST: must-infer
 TEST: must-fail-with
 TEST: must-fail
 
-M: test-failure summary
-    asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ;
-
 M: test-failure error. ( error -- )
-    [ call-next-method ]
+    {
+        [ summary print nl ]
+        [ asset>> [ experiment. nl ] when* ]
+        [ error>> error. ]
         [ traceback-button. ]
-    bi ;
+    } cleave ;
 
 : :test-failures ( -- ) test-failures get errors. ;
 

basis/ui/backend/x11/x11.factor

@@ -3,11 +3,11 @@
 USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets
 ui.gadgets.private ui.gestures ui.backend ui.clipboards
 ui.gadgets.worlds ui.render ui.event-loop assocs kernel math
-namespaces opengl sequences strings x11.xlib x11.events x11.xim
+namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
-x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
+x11.glx x11.clipboard x11.constants x11.windows x11.io
-io.encodings.ascii io.encodings.utf8 combinators command-line
+io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
-math.vectors classes.tuple opengl.gl threads math.rectangles
+command-line math.vectors classes.tuple opengl.gl threads
-environment ascii ;
+math.rectangles environment ascii ;
 IN: ui.backend.x11
 
 SINGLETON: x11-ui-backend
@@ -196,7 +196,7 @@ M: world client-event
     QueuedAfterFlush events-queued 0 > [
         next-event dup
         None XFilterEvent 0 = [ drop wait-event ] unless
-    ] [ ui-wait wait-event ] if ;
+    ] [ wait-for-display wait-event ] if ;
 
 M: x11-ui-backend do-events
     wait-event dup XAnyEvent-window window dup

basis/ui/gadgets/paragraphs/paragraphs-tests.factor

@@ -27,7 +27,7 @@ INSTANCE: fake-break word-break
 
 [ { 0 0 } ] [ "a" get loc>> ] unit-test
 
-[ { 45 15 } ] [ "b" get loc>> ] unit-test
+[ { 45 7 } ] [ "b" get loc>> ] unit-test
 
 [ { 0 30 } ] [ "c" get loc>> ] unit-test
 

basis/ui/tools/error-list/error-list.factor

@@ -26,7 +26,7 @@ MEMO: error-icon ( type -- image-name )
 
 : <error-toggle> ( -- model gadget )
     #! Linkage errors are not shown by default.
-    error-types get keys [ dup +linkage-error+ eq? not <model> ] { } map>assoc
+    error-types get [ fatal?>> <model> ] assoc-map
     [ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
     [ <mapping> ] bi ;
 
@@ -80,7 +80,7 @@ M: error-renderer row-columns
         {
             [ error-type error-icon ]
             [ line#>> [ number>string ] [ "" ] if* ]
-            [ asset>> unparse-short ]
+            [ asset>> [ unparse-short ] [ "" ] if* ]
             [ error>> summary ]
         } cleave
     ] output>array ;

basis/ui/tools/listener/listener.factor

@@ -358,9 +358,8 @@ interactor "completion" f {
 } define-command-map
 
 : ui-error-summary ( -- )
-    all-errors [
+    error-counts keys [
-        [ error-type ] map prune
+        [ icon>> 1array \ $image prefix " " 2array ] { } map-as
-        [ error-icon-path 1array \ $image prefix " " 2array ] { } map-as
         { "Press " { $command tool "common" show-error-list } " to view errors." }
         append print-element nl
     ] unless-empty ;

basis/urls/encoding/encoding-docs.factor

@@ -7,7 +7,11 @@ HELP: url-decode
 
 HELP: url-encode
 { $values { "str" string } { "encoded" string } }
-{ $description "URL-encodes a string." } ;
+{ $description "URL-encodes a string, excluding certain characters, such as \"/\"." } ;
+
+HELP: url-encode-full
+{ $values { "str" string } { "encoded" string } }
+{ $description "URL-encodes a string, including all reserved characters, such as \"/\"." } ;
 
 HELP: url-quotable?
 { $values { "ch" "a character" } { "?" "a boolean" } }

basis/urls/encoding/encoding.factor

@@ -14,6 +14,25 @@ IN: urls.encoding
         [ "/_-.:" member? ]
     } 1|| ; foldable
 
+! see http://tools.ietf.org/html/rfc3986#section-2.2
+: gen-delim? ( ch -- ? )
+    ":/?#[]@" member? ; foldable
+
+: sub-delim? ( ch -- ? )
+    "!$&'()*+,;=" member? ; foldable
+
+: reserved? ( ch -- ? )
+    [ gen-delim? ] [ sub-delim? ] bi or ; foldable
+
+! see http://tools.ietf.org/html/rfc3986#section-2.3
+: unreserved? ( ch -- ? )
+    {
+        [ letter? ]
+        [ LETTER? ]
+        [ digit? ]
+        [ "-._~" member? ]
+    } 1|| ; foldable
+
 <PRIVATE
 
 : push-utf8 ( ch -- )
@@ -27,6 +46,11 @@ PRIVATE>
         [ dup url-quotable? [ , ] [ push-utf8 ] if ] each
     ] "" make ;
 
+: url-encode-full ( str -- encoded )
+    [
+        [ dup unreserved? [ , ] [ push-utf8 ] if ] each
+    ] "" make ;
+
 <PRIVATE
 
 : url-decode-hex ( index str -- )

basis/windows/advapi32/advapi32.factor

@@ -1,5 +1,6 @@
 USING: alien.syntax kernel math windows.types math.bitwise ;
 IN: windows.advapi32
+
 LIBRARY: advapi32
 
 CONSTANT: PROV_RSA_FULL       1
@@ -122,6 +123,34 @@ C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
 
 TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
 
+C-STRUCT: SECURITY_DESCRIPTOR
+    { "UCHAR" "Revision" }
+    { "UCHAR" "Sbz1" }
+    { "WORD" "Control" }
+    { "PVOID" "Owner" }
+    { "PVOID" "Group" }
+    { "PACL" "Sacl" }
+    { "PACL" "Dacl" } ;
+
+TYPEDEF: SECURITY_DESCRIPTOR* PSECURITY_DESCRIPTOR
+
+CONSTANT: SE_OWNER_DEFAULTED 1
+CONSTANT: SE_GROUP_DEFAULTED 2
+CONSTANT: SE_DACL_PRESENT 4
+CONSTANT: SE_DACL_DEFAULTED 8
+CONSTANT: SE_SACL_PRESENT 16
+CONSTANT: SE_SACL_DEFAULTED 32
+CONSTANT: SE_DACL_AUTO_INHERIT_REQ 256
+CONSTANT: SE_SACL_AUTO_INHERIT_REQ 512
+CONSTANT: SE_DACL_AUTO_INHERITED 1024
+CONSTANT: SE_SACL_AUTO_INHERITED 2048
+CONSTANT: SE_DACL_PROTECTED 4096
+CONSTANT: SE_SACL_PROTECTED 8192
+CONSTANT: SE_SELF_RELATIVE 32768
+
+TYPEDEF: DWORD SECURITY_DESCRIPTOR_CONTROL
+TYPEDEF: SECURITY_DESCRIPTOR_CONTROL* PSECURITY_DESCRIPTOR_CONTROL
+
 
 ! typedef enum _TOKEN_INFORMATION_CLASS {
 CONSTANT: TokenUser 1
@@ -141,6 +170,140 @@ CONSTANT: TokenSessionReference 14
 CONSTANT: TokenSandBoxInert 15
 ! } TOKEN_INFORMATION_CLASS;
 
+TYPEDEF: DWORD ACCESS_MODE
+C-ENUM:
+    NOT_USED_ACCESS
+    GRANT_ACCESS
+    SET_ACCESS
+    DENY_ACCESS
+    REVOKE_ACCESS
+    SET_AUDIT_SUCCESS
+    SET_AUDIT_FAILURE ;
+
+TYPEDEF: DWORD MULTIPLE_TRUSTEE_OPERATION
+C-ENUM:
+    NO_MULTIPLE_TRUSTEE
+    TRUSTEE_IS_IMPERSONATE ;
+
+TYPEDEF: DWORD TRUSTEE_FORM
+C-ENUM:
+  TRUSTEE_IS_SID
+  TRUSTEE_IS_NAME
+  TRUSTEE_BAD_FORM
+  TRUSTEE_IS_OBJECTS_AND_SID
+  TRUSTEE_IS_OBJECTS_AND_NAME ;
+
+TYPEDEF: DWORD TRUSTEE_TYPE
+C-ENUM:
+    TRUSTEE_IS_UNKNOWN
+    TRUSTEE_IS_USER
+    TRUSTEE_IS_GROUP
+    TRUSTEE_IS_DOMAIN
+    TRUSTEE_IS_ALIAS
+    TRUSTEE_IS_WELL_KNOWN_GROUP
+    TRUSTEE_IS_DELETED
+    TRUSTEE_IS_INVALID
+    TRUSTEE_IS_COMPUTER ;
+
+TYPEDEF: DWORD SE_OBJECT_TYPE
+C-ENUM:
+    SE_UNKNOWN_OBJECT_TYPE
+    SE_FILE_OBJECT
+    SE_SERVICE
+    SE_PRINTER
+    SE_REGISTRY_KEY
+    SE_LMSHARE
+    SE_KERNEL_OBJECT
+    SE_WINDOW_OBJECT
+    SE_DS_OBJECT
+    SE_DS_OBJECT_ALL
+    SE_PROVIDER_DEFINED_OBJECT
+    SE_WMIGUID_OBJECT
+    SE_REGISTRY_WOW64_32KEY ;
+
+TYPEDEF: TRUSTEE* PTRUSTEE
+
+C-STRUCT: TRUSTEE
+    { "PTRUSTEE" "pMultipleTrustee" }
+    { "MULTIPLE_TRUSTEE_OPERATION" "MultipleTrusteeOperation" }
+    { "TRUSTEE_FORM" "TrusteeForm" }
+    { "TRUSTEE_TYPE" "TrusteeType" }
+    { "LPTSTR" "ptstrName" } ;
+
+C-STRUCT: EXPLICIT_ACCESS
+    { "DWORD" "grfAccessPermissions" }
+    { "ACCESS_MODE" "grfAccessMode" }
+    { "DWORD" "grfInheritance" }
+    { "TRUSTEE" "Trustee" } ;
+
+C-STRUCT: SID_IDENTIFIER_AUTHORITY
+    { { "BYTE" 6 } "Value" } ;
+
+TYPEDEF: SID_IDENTIFIER_AUTHORITY* PSID_IDENTIFIER_AUTHORITY
+
+CONSTANT: SECURITY_NULL_SID_AUTHORITY 0
+CONSTANT: SECURITY_WORLD_SID_AUTHORITY    1
+CONSTANT: SECURITY_LOCAL_SID_AUTHORITY    2
+CONSTANT: SECURITY_CREATOR_SID_AUTHORITY  3
+CONSTANT: SECURITY_NON_UNIQUE_AUTHORITY   4
+CONSTANT: SECURITY_NT_AUTHORITY   5
+CONSTANT: SECURITY_RESOURCE_MANAGER_AUTHORITY 6
+
+CONSTANT: SECURITY_NULL_RID 0
+CONSTANT: SECURITY_WORLD_RID 0
+CONSTANT: SECURITY_LOCAL_RID 0
+CONSTANT: SECURITY_CREATOR_OWNER_RID 0
+CONSTANT: SECURITY_CREATOR_GROUP_RID 1
+CONSTANT: SECURITY_CREATOR_OWNER_SERVER_RID 2
+CONSTANT: SECURITY_CREATOR_GROUP_SERVER_RID 3
+CONSTANT: SECURITY_DIALUP_RID 1
+CONSTANT: SECURITY_NETWORK_RID 2
+CONSTANT: SECURITY_BATCH_RID 3
+CONSTANT: SECURITY_INTERACTIVE_RID 4
+CONSTANT: SECURITY_SERVICE_RID 6
+CONSTANT: SECURITY_ANONYMOUS_LOGON_RID 7
+CONSTANT: SECURITY_PROXY_RID 8
+CONSTANT: SECURITY_SERVER_LOGON_RID 9
+CONSTANT: SECURITY_PRINCIPAL_SELF_RID 10
+CONSTANT: SECURITY_AUTHENTICATED_USER_RID 11
+CONSTANT: SECURITY_LOGON_IDS_RID 5
+CONSTANT: SECURITY_LOGON_IDS_RID_COUNT 3
+CONSTANT: SECURITY_LOCAL_SYSTEM_RID 18
+CONSTANT: SECURITY_NT_NON_UNIQUE 21
+CONSTANT: SECURITY_BUILTIN_DOMAIN_RID 32
+CONSTANT: DOMAIN_USER_RID_ADMIN 500
+CONSTANT: DOMAIN_USER_RID_GUEST 501
+CONSTANT: DOMAIN_GROUP_RID_ADMINS 512
+CONSTANT: DOMAIN_GROUP_RID_USERS 513
+CONSTANT: DOMAIN_GROUP_RID_GUESTS 514
+CONSTANT: DOMAIN_ALIAS_RID_ADMINS 544
+CONSTANT: DOMAIN_ALIAS_RID_USERS 545
+CONSTANT: DOMAIN_ALIAS_RID_GUESTS 546
+CONSTANT: DOMAIN_ALIAS_RID_POWER_USERS 547
+CONSTANT: DOMAIN_ALIAS_RID_ACCOUNT_OPS 548
+CONSTANT: DOMAIN_ALIAS_RID_SYSTEM_OPS 549
+CONSTANT: DOMAIN_ALIAS_RID_PRINT_OPS 550
+CONSTANT: DOMAIN_ALIAS_RID_BACKUP_OPS 551
+CONSTANT: DOMAIN_ALIAS_RID_REPLICATOR 552
+CONSTANT: SE_GROUP_MANDATORY 1
+CONSTANT: SE_GROUP_ENABLED_BY_DEFAULT 2
+CONSTANT: SE_GROUP_ENABLED 4
+CONSTANT: SE_GROUP_OWNER 8
+CONSTANT: SE_GROUP_LOGON_ID -1073741824
+
+! SID is a variable length structure
+TYPEDEF: void* PSID
+
+TYPEDEF: EXPLICIT_ACCESS* PEXPLICIT_ACCESS
+
+TYPEDEF: DWORD SECURITY_INFORMATION
+TYPEDEF: SECURITY_INFORMATION* PSECURITY_INFORMATION
+
+CONSTANT: OWNER_SECURITY_INFORMATION 1
+CONSTANT: GROUP_SECURITY_INFORMATION 2
+CONSTANT: DACL_SECURITY_INFORMATION 4
+CONSTANT: SACL_SECURITY_INFORMATION 8
+
 CONSTANT: DELETE                     HEX: 00010000
 CONSTANT: READ_CONTROL               HEX: 00020000
 CONSTANT: WRITE_DAC                  HEX: 00040000
@@ -187,6 +350,34 @@ CONSTANT: TOKEN_ADJUST_DEFAULT         HEX: 0080
         TOKEN_ADJUST_DEFAULT
     } flags ; foldable
 
+CONSTANT: HKEY_CLASSES_ROOT       1
+CONSTANT: HKEY_CURRENT_CONFIG     2
+CONSTANT: HKEY_CURRENT_USER       3
+CONSTANT: HKEY_LOCAL_MACHINE      4
+CONSTANT: HKEY_USERS              5
+
+CONSTANT: KEY_ALL_ACCESS          HEX: 0001
+CONSTANT: KEY_CREATE_LINK         HEX: 0002
+CONSTANT: KEY_CREATE_SUB_KEY      HEX: 0004
+CONSTANT: KEY_ENUMERATE_SUB_KEYS  HEX: 0008
+CONSTANT: KEY_EXECUTE             HEX: 0010
+CONSTANT: KEY_NOTIFY              HEX: 0020
+CONSTANT: KEY_QUERY_VALUE         HEX: 0040
+CONSTANT: KEY_READ                HEX: 0080
+CONSTANT: KEY_SET_VALUE           HEX: 0100
+CONSTANT: KEY_WOW64_64KEY         HEX: 0200
+CONSTANT: KEY_WOW64_32KEY         HEX: 0400
+CONSTANT: KEY_WRITE               HEX: 0800
+
+CONSTANT: REG_BINARY              1
+CONSTANT: REG_DWORD               2
+CONSTANT: REG_EXPAND_SZ           3
+CONSTANT: REG_MULTI_SZ            4
+CONSTANT: REG_QWORD               5
+CONSTANT: REG_SZ                  6
+
+TYPEDEF: DWORD REGSAM
+
 
 ! : I_ScGetCurrentGroupStateW ;
 ! : A_SHAFinal ;
@@ -224,7 +415,19 @@ FUNCTION: BOOL AdjustTokenPrivileges ( HANDLE TokenHandle,
                                PTOKEN_PRIVILEGES PreviousState,
                                PDWORD ReturnLength ) ;
 
-! : AllocateAndInitializeSid ;
+FUNCTION: BOOL AllocateAndInitializeSid (
+                PSID_IDENTIFIER_AUTHORITY pIdentifierAuthority,
+                BYTE nSubAuthorityCount,
+                DWORD dwSubAuthority0,
+                DWORD dwSubAuthority1,
+                DWORD dwSubAuthority2,
+                DWORD dwSubAuthority3,
+                DWORD dwSubAuthority4,
+                DWORD dwSubAuthority5,
+                DWORD dwSubAuthority6,
+                DWORD dwSubAuthority7,
+                PSID* pSid ) ;
+
 ! : AllocateLocallyUniqueId ;
 ! : AreAllAccessesGranted ;
 ! : AreAnyAccessesGranted ;
@@ -442,7 +645,8 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
 ! : GetExplicitEntriesFromAclA ;
 ! : GetExplicitEntriesFromAclW ;
 ! : GetFileSecurityA ;
-! : GetFileSecurityW ;
+FUNCTION: BOOL GetFileSecurityW ( LPCTSTR lpFileName, SECURITY_INFORMATION RequestedInformation, PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, LPDWORD lpnLengthNeeded ) ;
+ALIAS: GetFileSecurity GetFileSecurityW
 ! : GetInformationCodeAuthzLevelW ;
 ! : GetInformationCodeAuthzPolicyW ;
 ! : GetInheritanceSourceA ;
@@ -459,19 +663,20 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
 ! : GetMultipleTrusteeW ;
 ! : GetNamedSecurityInfoA ;
 ! : GetNamedSecurityInfoExA ;
-! : GetNamedSecurityInfoExW ;
+! FUNCTION: DWORD GetNamedSecurityInfoExW
-! : GetNamedSecurityInfoW ;
+FUNCTION: DWORD GetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID* ppsidOwner, PSID* ppsidGroup, PACL* ppDacl, PACL* ppSacl, PSECURITY_DESCRIPTOR* ppSecurityDescriptor ) ;
+ALIAS: GetNamedSecurityInfo GetNamedSecurityInfoW
 ! : GetNumberOfEventLogRecords ;
 ! : GetOldestEventLogRecord ;
 ! : GetOverlappedAccessResults ;
 ! : GetPrivateObjectSecurity ;
-! : GetSecurityDescriptorControl ;
+FUNCTION: BOOL GetSecurityDescriptorControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSECURITY_DESCRIPTOR_CONTROL pControl, LPDWORD lpdwRevision ) ;
-! : GetSecurityDescriptorDacl ;
+FUNCTION: BOOL GetSecurityDescriptorDacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbDaclPresent, PACL* pDacl, LPBOOL lpDaclDefaulted ) ;
-! : GetSecurityDescriptorGroup ;
+FUNCTION: BOOL GetSecurityDescriptorGroup ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pGroup, LPBOOL lpGroupDefaulted ) ;
-! : GetSecurityDescriptorLength ;
+FUNCTION: BOOL GetSecurityDescriptorLength ( PSECURITY_DESCRIPTOR pSecurityDescriptor ) ;
-! : GetSecurityDescriptorOwner ;
+FUNCTION: BOOL GetSecurityDescriptorOwner ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pOwner, LPBOOL lpOwnerDefaulted ) ;
-! : GetSecurityDescriptorRMControl ;
+FUNCTION: BOOL GetSecurityDescriptorRMControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PUCHAR RMControl ) ;
-! : GetSecurityDescriptorSacl ;
+FUNCTION: BOOL GetSecurityDescriptorSacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbSaclPresent, PACL* pSacl, LPBOOL lpSaclDefaulted ) ;
 ! : GetSecurityInfo ;
 ! : GetSecurityInfoExA ;
 ! : GetSecurityInfoExW ;
@@ -510,7 +715,7 @@ ALIAS: GetUserName GetUserNameW
 ! : ImpersonateNamedPipeClient ;
 ! : ImpersonateSelf ;
 FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
-! : InitializeSecurityDescriptor ;
+FUNCTION: BOOL InitializeSecurityDescriptor ( PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD dwRevision ) ;
 ! : InitializeSid ;
 ! : InitiateSystemShutdownA ;
 ! : InitiateSystemShutdownExA ;
@@ -674,8 +879,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
 ! : RegConnectRegistryW ;
 ! : RegCreateKeyA ;
 ! : RegCreateKeyExA ;
-! : RegCreateKeyExW ;
+FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ;
-! : RegCreateKeyW ;
+! : RegCreateKeyW
 ! : RegDeleteKeyA ;
 ! : RegDeleteKeyW ;
 ! : RegDeleteValueA ;
@@ -692,7 +897,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
 ! : RegLoadKeyA ;
 ! : RegLoadKeyW ;
 ! : RegNotifyChangeKeyValue ;
-! : RegOpenCurrentUser ;
+FUNCTION: LONG RegOpenCurrentUser ( REGSAM samDesired, PHKEY phkResult ) ;
 ! : RegOpenKeyA ;
 ! : RegOpenKeyExA ;
 ! : RegOpenKeyExW ;
@@ -705,7 +910,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
 ! : RegQueryMultipleValuesW ;
 ! : RegQueryValueA ;
 ! : RegQueryValueExA ;
-! : RegQueryValueExW ;
+FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ;
 ! : RegQueryValueW ;
 ! : RegReplaceKeyA ;
 ! : RegReplaceKeyW ;
@@ -756,7 +961,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
 ! : SetEntriesInAccessListA ;
 ! : SetEntriesInAccessListW ;
 ! : SetEntriesInAclA ;
-! : SetEntriesInAclW ;
+FUNCTION: DWORD SetEntriesInAclW ( ULONG cCountOfExplicitEntries, PEXPLICIT_ACCESS pListOfExplicitEntries, PACL OldAcl, PACL* NewAcl ) ;
+ALIAS: SetEntriesInAcl SetEntriesInAclW
 ! : SetEntriesInAuditListA ;
 ! : SetEntriesInAuditListW ;
 ! : SetFileSecurityA ;
@@ -767,7 +973,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
 ! : SetNamedSecurityInfoA ;
 ! : SetNamedSecurityInfoExA ;
 ! : SetNamedSecurityInfoExW ;
-! : SetNamedSecurityInfoW ;
+FUNCTION: DWORD SetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID psidOwner, PSID psidGroup, PACL pDacl, PACL pSacl ) ;
+ALIAS: SetNamedSecurityInfo SetNamedSecurityInfoW
 ! : SetPrivateObjectSecurity ;
 ! : SetPrivateObjectSecurityEx ;
 ! : SetSecurityDescriptorControl ;

basis/windows/gdi32/gdi32.factor

@@ -1501,7 +1501,6 @@ DESTRUCTOR: DeleteObject
 FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ;
 ALIAS: ExtTextOut ExtTextOutW
 ! FUNCTION: FillPath
-FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
 ! FUNCTION: FillRgn
 ! FUNCTION: FixBrushOrgEx
 ! FUNCTION: FlattenPath

basis/windows/kernel32/kernel32.factor

@@ -1477,7 +1477,7 @@ ALIAS: LoadLibraryEx LoadLibraryExW
 ! FUNCTION: LoadLibraryW
 ! FUNCTION: LoadModule
 ! FUNCTION: LoadResource
-! FUNCTION: LocalAlloc
+FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ;
 ! FUNCTION: LocalCompact
 ! FUNCTION: LocalFileTimeToFileTime
 ! FUNCTION: LocalFlags

basis/windows/user32/user32.factor

@@ -807,7 +807,7 @@ FUNCTION: UINT EnumClipboardFormats ( UINT format ) ;
 ! FUNCTION: EqualRect
 ! FUNCTION: ExcludeUpdateRgn
 ! FUNCTION: ExitWindowsEx
-! FUNCTION: FillRect
+FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
 FUNCTION: HWND FindWindowA ( char* lpClassName, char* lpWindowName ) ;
 FUNCTION: HWND FindWindowExA ( HWND hwndParent, HWND childAfter, char* lpClassName, char* lpWindowName ) ;
 ! FUNCTION: FindWindowExW

basis/x11/authors.txt

@@ -0,0 +1,2 @@
+Eduardo Cavazos
+Slava Pestov

basis/x11/clipboard/clipboard.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings alien.syntax arrays
 kernel math namespaces sequences io.encodings.string
-io.encodings.utf8 io.encodings.ascii x11.xlib x11.constants
+io.encodings.utf8 io.encodings.ascii x11 x11.xlib x11.constants
 specialized-arrays.int accessors ;
 IN: x11.clipboard
 

basis/x11/events/events.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types arrays hashtables io kernel math
 math.order namespaces prettyprint sequences strings combinators
-x11.xlib ;
+x11 x11.xlib ;
 IN: x11.events
 
 GENERIC: expose-event ( event window -- )

basis/x11/glx/glx.factor

@@ -2,8 +2,9 @@
 ! See http://factorcode.org/license.txt for BSD license.
 !
 ! based on glx.h from xfree86, and some of glxtokens.h
-USING: alien alien.c-types alien.syntax x11.xlib namespaces make
+USING: alien alien.c-types alien.syntax x11 x11.xlib x11.syntax
-kernel sequences parser words specialized-arrays.int accessors ;
+namespaces make kernel sequences parser words specialized-arrays.int
+accessors ;
 IN: x11.glx
 
 LIBRARY: glx
@@ -36,52 +37,52 @@ TYPEDEF: XID GLXFBConfigID
 TYPEDEF: void* GLXContext  ! typedef struct __GLXcontextRec *GLXContext;
 TYPEDEF: void* GLXFBConfig ! typedef struct __GLXFBConfigRec *GLXFBConfig;
 
-FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ;
+X-FUNCTION: XVisualInfo* glXChooseVisual ( Display* dpy, int screen, int* attribList ) ;
-FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ;
+X-FUNCTION: void glXCopyContext ( Display* dpy, GLXContext src, GLXContext dst, ulong mask ) ;
-FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ;
+X-FUNCTION: GLXContext glXCreateContext ( Display* dpy, XVisualInfo* vis, GLXContext shareList, bool direct ) ;
-FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ;
+X-FUNCTION: GLXPixmap glXCreateGLXPixmap ( Display* dpy, XVisualInfo* vis, Pixmap pixmap ) ;
-FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ;
+X-FUNCTION: void glXDestroyContext ( Display* dpy, GLXContext ctx ) ;
-FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ;
+X-FUNCTION: void glXDestroyGLXPixmap ( Display* dpy, GLXPixmap pix ) ;
-FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ;
+X-FUNCTION: int glXGetConfig ( Display* dpy, XVisualInfo* vis, int attrib, int* value ) ;
-FUNCTION: GLXContext glXGetCurrentContext ( ) ;
+X-FUNCTION: GLXContext glXGetCurrentContext ( ) ;
-FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ;
+X-FUNCTION: GLXDrawable glXGetCurrentDrawable ( ) ;
-FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ;
+X-FUNCTION: bool glXIsDirect ( Display* dpy, GLXContext ctx ) ;
-FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ;
+X-FUNCTION: bool glXMakeCurrent ( Display* dpy, GLXDrawable drawable, GLXContext ctx ) ;
-FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ;
+X-FUNCTION: bool glXQueryExtension ( Display* dpy, int* errorBase, int* eventBase ) ;
-FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ;
+X-FUNCTION: bool glXQueryVersion ( Display* dpy, int* major, int* minor ) ;
-FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ;
+X-FUNCTION: void glXSwapBuffers ( Display* dpy, GLXDrawable drawable ) ;
-FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ;
+X-FUNCTION: void glXUseXFont ( Font font, int first, int count, int listBase ) ;
-FUNCTION: void glXWaitGL ( ) ;
+X-FUNCTION: void glXWaitGL ( ) ;
-FUNCTION: void glXWaitX ( ) ;
+X-FUNCTION: void glXWaitX ( ) ;
-FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ;
+X-FUNCTION: char* glXGetClientString ( Display* dpy, int name ) ;
-FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ;
+X-FUNCTION: char* glXQueryServerString ( Display* dpy, int screen, int name ) ;
-FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ;
+X-FUNCTION: char* glXQueryExtensionsString ( Display* dpy, int screen ) ;
 
 ! New for GLX 1.3
-FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ;
+X-FUNCTION: GLXFBConfig* glXGetFBConfigs ( Display* dpy, int screen, int* nelements ) ;
-FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ;
+X-FUNCTION: GLXFBConfig* glXChooseFBConfig ( Display* dpy, int screen, int* attrib_list, int* nelements ) ;
-FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ;
+X-FUNCTION: int glXGetFBConfigAttrib ( Display* dpy, GLXFBConfig config, int attribute, int* value ) ;
-FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ;
+X-FUNCTION: XVisualInfo* glXGetVisualFromFBConfig ( Display* dpy, GLXFBConfig config ) ;
-FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ;
+X-FUNCTION: GLXWindow glXCreateWindow ( Display* dpy, GLXFBConfig config, Window win, int* attrib_list ) ;
-FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ;
+X-FUNCTION: void glXDestroyWindow ( Display* dpy, GLXWindow win ) ;
-FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ;
+X-FUNCTION: GLXPixmap glXCreatePixmap ( Display* dpy, GLXFBConfig config, Pixmap pixmap, int* attrib_list ) ;
-FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ;
+X-FUNCTION: void glXDestroyPixmap ( Display* dpy, GLXPixmap pixmap ) ;
-FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ;
+X-FUNCTION: GLXPbuffer glXCreatePbuffer ( Display* dpy, GLXFBConfig config, int* attrib_list ) ;
-FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ;
+X-FUNCTION: void glXDestroyPbuffer ( Display* dpy, GLXPbuffer pbuf ) ;
-FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ;
+X-FUNCTION: void glXQueryDrawable ( Display* dpy, GLXDrawable draw, int attribute, uint* value ) ;
-FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ;
+X-FUNCTION: GLXContext glXCreateNewContext ( Display* dpy, GLXFBConfig config, int render_type, GLXContext share_list, bool direct ) ;
-FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ;
+X-FUNCTION: bool glXMakeContextCurrent ( Display* display, GLXDrawable draw, GLXDrawable read, GLXContext ctx ) ;
-FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ;
+X-FUNCTION: GLXDrawable glXGetCurrentReadDrawable ( ) ;
-FUNCTION: Display*  glXGetCurrentDisplay ( ) ;
+X-FUNCTION: Display*  glXGetCurrentDisplay ( ) ;
-FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ;
+X-FUNCTION: int glXQueryContext ( Display* dpy, GLXContext ctx, int attribute, int* value ) ;
-FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ;
+X-FUNCTION: void glXSelectEvent ( Display* dpy, GLXDrawable draw, ulong event_mask ) ;
-FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ;
+X-FUNCTION: void glXGetSelectedEvent ( Display* dpy, GLXDrawable draw, ulong* event_mask ) ;
 
 ! GLX 1.4 and later
-FUNCTION: void* glXGetProcAddress ( char* procname ) ;
+X-FUNCTION: void* glXGetProcAddress ( char* procname ) ;
 
 ! GLX_ARB_get_proc_address extension
-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
+X-FUNCTION: void* glXGetProcAddressARB ( char* procname ) ;
 
 ! GLX Events
 ! (also skipped for now. only has GLXPbufferClobberEvent, the rest is handled by xlib methinks)

basis/x11/io/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/x11/io/io.factor

@@ -0,0 +1,16 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend calendar threads kernel ;
+IN: x11.io
+
+HOOK: init-x-io io-backend ( -- )
+
+M: object init-x-io ;
+
+HOOK: wait-for-display io-backend ( -- )
+
+M: object wait-for-display 10 milliseconds sleep ;
+
+HOOK: awaken-event-loop io-backend ( -- )
+
+M: object awaken-event-loop ;

basis/x11/io/unix/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/x11/io/unix/unix.factor

@@ -0,0 +1,15 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: io.backend.unix io.backend.unix.multiplexers
+namespaces system x11 x11.xlib x11.io
+accessors threads sequences kernel ;
+IN: x11.io.unix
+
+SYMBOL: dpy-fd
+
+M: unix init-x-io dpy get XConnectionNumber <fd> dpy-fd set-global ;
+
+M: unix wait-for-display dpy-fd get +input+ wait-for-fd ;
+
+M: unix awaken-event-loop
+    dpy-fd get [ fd>> mx get remove-input-callbacks [ resume ] each ] when* ;

basis/x11/syntax/authors.txt

@@ -0,0 +1 @@
+Slava Pestov

basis/x11/syntax/syntax.factor

@@ -0,0 +1,9 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax alien.parser words x11.io sequences kernel ;
+IN: x11.syntax
+
+SYNTAX: X-FUNCTION:
+    (FUNCTION:)
+    [ \ awaken-event-loop suffix ] dip
+    define-declared ;

basis/x11/windows/windows.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types hashtables kernel math math.vectors
-math.bitwise namespaces sequences x11.xlib x11.constants x11.glx
+math.bitwise namespaces sequences x11 x11.xlib x11.constants x11.glx
 arrays fry ;
 IN: x11.windows
 
@@ -29,6 +29,8 @@ IN: x11.windows
 
 : window-attributes ( visinfo -- attributes )
     "XSetWindowAttributes" <c-object>
+    0 over set-XSetWindowAttributes-background_pixel
+    0 over set-XSetWindowAttributes-border_pixel
     [ [ create-colormap ] dip set-XSetWindowAttributes-colormap ] keep
     event-mask over set-XSetWindowAttributes-event_mask ;
 

basis/x11/x11.factor

@@ -0,0 +1,36 @@
+! Copyright (C) 2005, 2009 Eduardo Cavazos, Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.strings continuations io
+io.encodings.ascii kernel namespaces x11.xlib x11.io
+vocabs vocabs.loader ;
+IN: x11
+
+SYMBOL: dpy
+SYMBOL: scr
+SYMBOL: root
+
+: init-locale ( -- )
+   LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
+   XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
+
+: flush-dpy ( -- ) dpy get XFlush drop ;
+
+: x-atom ( string -- atom ) [ dpy get ] dip 0 XInternAtom ;
+
+: check-display ( alien -- alien' )
+    [ "Cannot connect to X server - check $DISPLAY" throw ] unless* ;
+
+: init-x ( display-string -- )
+    init-locale
+    dup [ ascii string>alien ] when
+    XOpenDisplay check-display dpy set-global
+    dpy get XDefaultScreen scr set-global
+    dpy get scr get XRootWindow root set-global
+    init-x-io ;
+
+: close-x ( -- ) dpy get XCloseDisplay drop ;
+
+: with-x ( display-string quot -- )
+    [ init-x ] dip [ close-x ] [ ] cleanup ; inline
+
+"io.backend.unix" vocab [ "x11.io.unix" require ] when

basis/x11/xim/xim.factor

@@ -2,7 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien alien.c-types alien.strings arrays byte-arrays
 hashtables io io.encodings.string kernel math namespaces
-sequences strings continuations x11.xlib specialized-arrays.uint
+sequences strings continuations x11 x11.xlib specialized-arrays.uint
 accessors io.encodings.utf16n ;
 IN: x11.xim
 

basis/x11/xlib/xlib.factor

@@ -13,7 +13,7 @@
 
 USING: kernel arrays alien alien.c-types alien.strings
 alien.syntax math math.bitwise words sequences namespaces
-continuations io io.encodings.ascii ;
+continuations io io.encodings.ascii x11.syntax ;
 IN: x11.xlib
 
 LIBRARY: xlib
@@ -71,26 +71,26 @@ C-STRUCT: Display
 { "void*" "free_funcs" }
 { "int" "fd" } ;
 
-FUNCTION: Display* XOpenDisplay ( void* display_name ) ;
+X-FUNCTION: Display* XOpenDisplay ( void* display_name ) ;
 
 ! 2.2 Obtaining Information about the Display, Image Formats, or Screens
 
-FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ;
+X-FUNCTION: ulong XBlackPixel ( Display* display, int screen_number ) ;
-FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ;
+X-FUNCTION: ulong XWhitePixel ( Display* display, int screen_number ) ;
-FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ;
+X-FUNCTION: Colormap XDefaultColormap ( Display* display, int screen_number ) ;
-FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ;
+X-FUNCTION: int XDefaultDepth ( Display* display, int screen_number ) ;
-FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ;
+X-FUNCTION: GC XDefaultGC ( Display* display, int screen_number ) ;
-FUNCTION: int XDefaultScreen ( Display* display ) ;
+X-FUNCTION: int XDefaultScreen ( Display* display ) ;
-FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ;
+X-FUNCTION: Window XRootWindow ( Display* display, int screen_number ) ;
-FUNCTION: Window XDefaultRootWindow ( Display* display ) ;
+X-FUNCTION: Window XDefaultRootWindow ( Display* display ) ;
-FUNCTION: int XProtocolVersion ( Display* display ) ;
+X-FUNCTION: int XProtocolVersion ( Display* display ) ;
-FUNCTION: int XProtocolRevision ( Display* display ) ;
+X-FUNCTION: int XProtocolRevision ( Display* display ) ;
-FUNCTION: int XQLength ( Display* display ) ;
+X-FUNCTION: int XQLength ( Display* display ) ;
-FUNCTION: int XScreenCount ( Display* display ) ;
+X-FUNCTION: int XScreenCount ( Display* display ) ;
-FUNCTION: int XConnectionNumber ( Display* display ) ;
+X-FUNCTION: int XConnectionNumber ( Display* display ) ;
 
 ! 2.5 Closing the Display
-FUNCTION: int XCloseDisplay ( Display* display ) ;
+X-FUNCTION: int XCloseDisplay ( Display* display ) ;
 
 !
 ! 3 - Window Functions
@@ -147,17 +147,17 @@ CONSTANT: StaticGravity         10
 
 ! 3.3 - Creating Windows
 
-FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ;
+X-FUNCTION: Window XCreateWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, int depth, uint class, Visual* visual, ulong valuemask, XSetWindowAttributes* attributes ) ;
-FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ;
+X-FUNCTION: Window XCreateSimpleWindow ( Display* display, Window parent, int x, int y, uint width, uint height, uint border_width, ulong border, ulong background ) ;
-FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XDestroyWindow ( Display* display, Window w ) ;
-FUNCTION: Status XMapWindow ( Display* display, Window window ) ;
+X-FUNCTION: Status XMapWindow ( Display* display, Window window ) ;
-FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ;
+X-FUNCTION: Status XMapSubwindows ( Display* display, Window window ) ;
-FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XUnmapWindow ( Display* display, Window w ) ;
-FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ;
+X-FUNCTION: Status XUnmapSubwindows ( Display* display, Window w ) ;
 
 ! 3.5 Mapping Windows
 
-FUNCTION: int XMapRaised ( Display* display, Window w ) ;
+X-FUNCTION: int XMapRaised ( Display* display, Window w ) ;
 
 ! 3.7 - Configuring Windows
 
@@ -178,25 +178,25 @@ C-STRUCT: XWindowChanges
         { "Window" "sibling" }
         { "int" "stack_mode" } ;
 
-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ;
+X-FUNCTION: Status XConfigureWindow ( Display* display, Window w, uint value_mask, XWindowChanges* values ) ;
-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ;
+X-FUNCTION: Status XMoveWindow ( Display* display, Window w, int x, int y ) ;
-FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ;
+X-FUNCTION: Status XResizeWindow ( Display* display, Window w, uint width, uint height ) ;
-FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ;
+X-FUNCTION: Status XSetWindowBorderWidth ( Display* display, ulong w, uint width ) ;
 
 
 ! 3.8 Changing Window Stacking Order
 
-FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XRaiseWindow ( Display* display, Window w ) ;
-FUNCTION: Status XLowerWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XLowerWindow ( Display* display, Window w ) ;
 
 ! 3.9 - Changing Window Attributes
 
-FUNCTION: Status XChangeWindowAttributes (
+X-FUNCTION: Status XChangeWindowAttributes (
   Display* display, Window w, ulong valuemask, XSetWindowAttributes* attr ) ;
-FUNCTION: Status XSetWindowBackground (
+X-FUNCTION: Status XSetWindowBackground (
   Display* display, Window w, ulong background_pixel ) ;
-FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ;
+X-FUNCTION: Status XDefineCursor ( Display* display, Window w, Cursor cursor ) ;
-FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ;
+X-FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! 4 - Window Information Functions
@@ -204,7 +204,7 @@ FUNCTION: Status XUndefineCursor ( Display* display, Window w ) ;
 
 ! 4.1 - Obtaining Window Information
 
-FUNCTION: Status XQueryTree (
+X-FUNCTION: Status XQueryTree (
   Display* display,
   Window w,
   Window* root_return,
@@ -236,13 +236,13 @@ C-STRUCT: XWindowAttributes
         { "Bool" "override_redirect" }
         { "Screen*" "screen" } ;
 
-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ;
+X-FUNCTION: Status XGetWindowAttributes ( Display* display, Window w, XWindowAttributes* attr ) ;
 
 CONSTANT: IsUnmapped            0
 CONSTANT: IsUnviewable          1
 CONSTANT: IsViewable            2
 
-FUNCTION: Status XGetGeometry (
+X-FUNCTION: Status XGetGeometry (
   Display* display,
   Drawable d,
   Window* root_return,
@@ -255,27 +255,27 @@ FUNCTION: Status XGetGeometry (
 
 ! 4.2 - Translating Screen Coordinates
 
-FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ;
+X-FUNCTION: Bool XQueryPointer ( Display* display, Window w, Window* root_return, Window* child_return, int* root_x_return, int* root_y_return, int* win_x_return, int* win_y_return, uint* mask_return ) ;
 
 ! 4.3 - Properties and Atoms
 
-FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ;
+X-FUNCTION: Atom XInternAtom ( Display* display, char* atom_name, Bool only_if_exists ) ;
 
-FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ;
+X-FUNCTION: char* XGetAtomName ( Display* display, Atom atom ) ;
 
 ! 4.4 - Obtaining and Changing Window Properties
 
-FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ;
+X-FUNCTION: int XGetWindowProperty ( Display* display, Window w, Atom property, long long_offset, long long_length, Bool delete, Atom req_type, Atom* actual_type_return, int* actual_format_return, ulong* nitems_return, ulong* bytes_after_return, char** prop_return ) ;
 
-FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ;
+X-FUNCTION: int XChangeProperty ( Display* display, Window w, Atom property, Atom type, int format, int mode, void* data, int nelements ) ;
 
 ! 4.5 Selections
 
-FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ;
+X-FUNCTION: int XSetSelectionOwner ( Display* display, Atom selection, Window owner, Time time ) ;
 
-FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ;
+X-FUNCTION: Window XGetSelectionOwner ( Display* display, Atom selection ) ;
 
-FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ;
+X-FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target, Atom property, Window requestor, Time time ) ;
 
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -284,8 +284,8 @@ FUNCTION: int XConvertSelection ( Display* display, Atom selection, Atom target,
 
 ! 5.1 - Creating and Freeing Pixmaps
 
-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
+X-FUNCTION: Pixmap XCreatePixmap ( Display* display, Drawable d, uint width, uint height, uint depth ) ;
-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
+X-FUNCTION: int XFreePixmap ( Display* display, Pixmap pixmap ) ;
 
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -300,13 +300,13 @@ C-STRUCT: XColor
         { "char" "flags" }
         { "char" "pad" } ;
 
-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ;
+X-FUNCTION: Status XLookupColor ( Display* display, Colormap colormap, char* color_name, XColor* exact_def_return, XColor* screen_def_return ) ;
-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ;
+X-FUNCTION: Status XAllocColor ( Display* display, Colormap colormap, XColor* screen_in_out ) ;
-FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ;
+X-FUNCTION: Status XQueryColor ( Display* display, Colormap colormap, XColor* def_in_out ) ;
 
 ! 6.4 Creating, Copying, and Destroying Colormaps
 
-FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ;
+X-FUNCTION: Colormap XCreateColormap ( Display* display, Window w, Visual* visual, int alloc ) ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! 7 - Graphics Context Functions
@@ -378,27 +378,27 @@ C-STRUCT: XGCValues
         { "int" "dash_offset" }
         { "char" "dashes" } ;
 
-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ;
+X-FUNCTION: GC XCreateGC ( Display* display, Window d, ulong valuemask, XGCValues* values ) ;
-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ;
+X-FUNCTION: int XChangeGC ( Display* display, GC gc, ulong valuemask, XGCValues* values ) ;
-FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ;
+X-FUNCTION: Status XGetGCValues ( Display* display, GC gc, ulong valuemask, XGCValues* values_return ) ;
-FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ;
+X-FUNCTION: Status XSetForeground ( Display* display, GC gc, ulong foreground ) ;
-FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ;
+X-FUNCTION: Status XSetBackground ( Display* display, GC gc, ulong background ) ;
-FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ;
+X-FUNCTION: Status XSetFunction ( Display* display, GC gc, int function ) ;
-FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ;
+X-FUNCTION: Status XSetSubwindowMode ( Display* display, GC gc, int subwindow_mode ) ;
 
-FUNCTION: GContext XGContextFromGC ( GC gc ) ;
+X-FUNCTION: GContext XGContextFromGC ( GC gc ) ;
 
-FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ;
+X-FUNCTION: Status XSetFont ( Display* display, GC gc, Font font ) ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! 8 - Graphics Functions
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-FUNCTION: Status XClearWindow ( Display* display, Window w ) ;
+X-FUNCTION: Status XClearWindow ( Display* display, Window w ) ;
-FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ;
+X-FUNCTION: Status XDrawPoint ( Display* display, Drawable d, GC gc, int x, int y ) ;
-FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ;
+X-FUNCTION: Status XDrawLine ( Display* display, Drawable d, GC gc, int x1, int y1, int x2, int y2 ) ;
-FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
+X-FUNCTION: Status XDrawArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
-FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
+X-FUNCTION: Status XFillArc ( Display* display, Drawable d, GC gc, int x, int y, uint width, uint height, int angle1, int angle2 ) ;
 
 ! 8.5 - Font Metrics
 
@@ -410,9 +410,9 @@ C-STRUCT: XCharStruct
         { "short" "descent" }
         { "ushort" "attributes" } ;
 
-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
+X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ;
-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
+X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ;
-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
+X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ;
 
 C-STRUCT: XFontStruct
         { "XExtData*" "ext_data" }
@@ -432,11 +432,11 @@ C-STRUCT: XFontStruct
         { "int" "ascent" }
         { "int" "descent" } ;
 
-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
+X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ;
 
 ! 8.6 - Drawing Text
 
-FUNCTION: Status XDrawString (
+X-FUNCTION: Status XDrawString (
         Display* display,
         Drawable d,
         GC gc,
@@ -479,8 +479,8 @@ C-STRUCT: XImage
     { "XPointer"     "obdata" }
     { "XImage-funcs" "f" } ;
 
-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
+X-FUNCTION: XImage* XGetImage ( Display* display, Drawable d, int x, int y, uint width, uint height, ulong plane_mask, int format ) ;
-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
+X-FUNCTION: int XDestroyImage ( XImage *ximage ) ;
 
 : XImage-size ( ximage -- size )
     [ XImage-height ] [ XImage-bytes_per_line ] bi * ;
@@ -492,12 +492,12 @@ FUNCTION: int XDestroyImage ( XImage *ximage ) ;
 ! 9 - Window and Session Manager Functions
 !
 
-FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ;
+X-FUNCTION: Status XReparentWindow ( Display* display, Window w, Window parent, int x, int y ) ;
-FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ;
+X-FUNCTION: Status XAddToSaveSet ( Display* display, Window w ) ;
-FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ;
+X-FUNCTION: Status XRemoveFromSaveSet ( Display* display, Window w ) ;
-FUNCTION: Status XGrabServer ( Display* display ) ;
+X-FUNCTION: Status XGrabServer ( Display* display ) ;
-FUNCTION: Status XUngrabServer ( Display* display ) ;
+X-FUNCTION: Status XUngrabServer ( Display* display ) ;
-FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
+X-FUNCTION: Status XKillClient ( Display* display, XID resource ) ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! 10 - Events
@@ -1066,11 +1066,11 @@ C-UNION: XEvent
 ! 11 - Event Handling Functions
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ;
+X-FUNCTION: Status XSelectInput ( Display* display, Window w, long event_mask ) ;
-FUNCTION: Status XFlush ( Display* display ) ;
+X-FUNCTION: Status XFlush ( Display* display ) ;
-FUNCTION: Status XSync ( Display* display, int discard ) ;
+X-FUNCTION: Status XSync ( Display* display, int discard ) ;
-FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ;
+X-FUNCTION: Status XNextEvent ( Display* display, XEvent* event ) ;
-FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ;
+X-FUNCTION: Status XMaskEvent ( Display* display, long event_mask, XEvent* event_return ) ;
 
 ! 11.3 - Event Queue Management
 
@@ -1078,16 +1078,16 @@ CONSTANT: QueuedAlready 0
 CONSTANT: QueuedAfterReading 1
 CONSTANT: QueuedAfterFlush 2
 
-FUNCTION: int XEventsQueued ( Display* display, int mode ) ;
+X-FUNCTION: int XEventsQueued ( Display* display, int mode ) ;
-FUNCTION: int XPending ( Display* display ) ;
+X-FUNCTION: int XPending ( Display* display ) ;
 
 ! 11.6 - Sending Events to Other Applications
 
-FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ;
+X-FUNCTION: Status XSendEvent ( Display* display, Window w, Bool propagate, long event_mask, XEvent* event_send ) ;
 
 ! 11.8 - Handling Protocol Errors
 
-FUNCTION: int XSetErrorHandler ( void* handler ) ;
+X-FUNCTION: int XSetErrorHandler ( void* handler ) ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! 12 - Input Device Functions
@@ -1095,7 +1095,7 @@ FUNCTION: int XSetErrorHandler ( void* handler ) ;
 
 CONSTANT: None 0
 
-FUNCTION: int XGrabPointer (
+X-FUNCTION: int XGrabPointer (
   Display* display,
   Window grab_window,
   Bool owner_events,
@@ -1106,16 +1106,16 @@ FUNCTION: int XGrabPointer (
   Cursor cursor,
   Time time ) ;
 
-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ;
+X-FUNCTION: Status XUngrabPointer ( Display* display, Time time ) ;
-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ;
+X-FUNCTION: Status XChangeActivePointerGrab ( Display* display, uint event_mask, Cursor cursor, Time time ) ;
-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ;
+X-FUNCTION: Status XGrabKey ( Display* display, int keycode, uint modifiers, Window grab_window, Bool owner_events, int pointer_mode, int keyboard_mode ) ;
-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ;
+X-FUNCTION: Status XSetInputFocus ( Display* display, Window focus, int revert_to, Time time ) ;
 
-FUNCTION: Status XGetInputFocus ( Display* display,
+X-FUNCTION: Status XGetInputFocus ( Display* display,
                                   Window*  focus_return,
                                   int*     revert_to_return ) ;
 
-FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ;
+X-FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, int src_x, int src_y, uint src_width, uint src_height, int dest_x, int dest_y ) ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! 14 - Inter-Client Communication Functions
@@ -1123,15 +1123,15 @@ FUNCTION: Status XWarpPointer ( Display* display, Window src_w, Window dest_w, i
 
 ! 14.1 Client to Window Manager Communication
 
-FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ;
+X-FUNCTION: Status XFetchName ( Display* display, Window w, char** window_name_return ) ;
-FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ;
+X-FUNCTION: Status XGetTransientForHint ( Display* display, Window w, Window* prop_window_return ) ;
 
 ! 14.1.1.  Manipulating Top-Level Windows
 
-FUNCTION: Status XIconifyWindow (
+X-FUNCTION: Status XIconifyWindow (
         Display* display, Window w, int screen_number ) ;
 
-FUNCTION: Status XWithdrawWindow (
+X-FUNCTION: Status XWithdrawWindow (
         Display* display, Window w, int screen_number ) ;
 
 ! 14.1.6 - Setting and Reading the WM_HINTS Property
@@ -1173,10 +1173,10 @@ C-STRUCT: XSizeHints
 
 ! 14.1.10.  Setting and Reading the WM_PROTOCOLS Property
 
-FUNCTION: Status XSetWMProtocols (
+X-FUNCTION: Status XSetWMProtocols (
         Display* display, Window w, Atom* protocols, int count ) ;
 
-FUNCTION: Status XGetWMProtocols (
+X-FUNCTION: Status XGetWMProtocols (
         Display* display,
         Window w,
         Atom** protocols_return,
@@ -1188,9 +1188,9 @@ FUNCTION: Status XGetWMProtocols (
 
 ! 16.1 Keyboard Utility Functions
 
-FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ;
+X-FUNCTION: KeySym XLookupKeysym ( XKeyEvent* key_event, int index ) ;
 
-FUNCTION: int XLookupString (
+X-FUNCTION: int XLookupString (
         XKeyEvent* event_struct,
         void* buffer_return,
         int bytes_buffer,
@@ -1227,7 +1227,7 @@ C-STRUCT: XVisualInfo
 ! Appendix D - Compatibility Functions
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-FUNCTION: Status XSetStandardProperties (
+X-FUNCTION: Status XSetStandardProperties (
         Display* display,
         Window w,
         char* window_name,
@@ -1314,10 +1314,10 @@ CONSTANT: XA_LAST_PREDEFINED 68
 ! The rest of the stuff is not from the book.
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-FUNCTION: void XFree ( void* data ) ;
+X-FUNCTION: void XFree ( void* data ) ;
-FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ;
+X-FUNCTION: int XStoreName ( Display* display, Window w, char* window_name ) ;
-FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ;
+X-FUNCTION: void XSetWMNormalHints ( Display* display, Window w, XSizeHints* hints ) ;
-FUNCTION: int XBell ( Display* display, int percent ) ;
+X-FUNCTION: int XBell ( Display* display, int percent ) ;
 
 ! !!! INPUT METHODS
 
@@ -1381,23 +1381,23 @@ CONSTANT: XLookupChars     2
 CONSTANT: XLookupKeySym    3
 CONSTANT: XLookupBoth      4
 
-FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ;
+X-FUNCTION: Bool XFilterEvent ( XEvent* event, Window w ) ;
 
-FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ;
+X-FUNCTION: XIM XOpenIM ( Display* dpy, void* rdb, char* res_name, char* res_class ) ;
 
-FUNCTION: Status XCloseIM ( XIM im ) ;
+X-FUNCTION: Status XCloseIM ( XIM im ) ;
 
-FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ;
+X-FUNCTION: XIC XCreateIC ( XIM im, char* key1, Window value1, char* key2, Window value2, char* key3, int value3, char* key4, char* value4, char* key5, char* value5, int key6 ) ;
 
-FUNCTION: void XDestroyIC ( XIC ic ) ;
+X-FUNCTION: void XDestroyIC ( XIC ic ) ;
 
-FUNCTION: void XSetICFocus ( XIC ic ) ;
+X-FUNCTION: void XSetICFocus ( XIC ic ) ;
         
-FUNCTION: void XUnsetICFocus ( XIC ic ) ;
+X-FUNCTION: void XUnsetICFocus ( XIC ic ) ;
 
-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
+X-FUNCTION: int XwcLookupString ( XIC ic, XKeyPressedEvent* event, ulong* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
 
-FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
+X-FUNCTION: int Xutf8LookupString ( XIC ic, XKeyPressedEvent* event, char* buffer_return, int bytes_buffer, KeySym* keysym_return, Status* status_return ) ;
 
 ! !!! category of setlocale
 CONSTANT: LC_ALL      0
@@ -1407,37 +1407,8 @@ CONSTANT: LC_MONETARY 3
 CONSTANT: LC_NUMERIC  4
 CONSTANT: LC_TIME     5
 
-FUNCTION: char* setlocale ( int category, char* name ) ;
+X-FUNCTION: char* setlocale ( int category, char* name ) ;
 
-FUNCTION: Bool XSupportsLocale ( ) ;
+X-FUNCTION: Bool XSupportsLocale ( ) ;
 
-FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ;
+X-FUNCTION: char* XSetLocaleModifiers ( char* modifier_list ) ;
-
-SYMBOL: dpy
-SYMBOL: scr
-SYMBOL: root
-
-: init-locale ( -- )
-   LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
-   XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
-
-: flush-dpy ( -- ) dpy get XFlush drop ;
-
-: x-atom ( string -- atom ) dpy get swap 0 XInternAtom ;
-
-: check-display ( alien -- alien' )
-    [
-        "Cannot connect to X server - check $DISPLAY" throw
-    ] unless* ;
-
-: initialize-x ( display-string -- )
-    init-locale
-    dup [ ascii string>alien ] when
-    XOpenDisplay check-display dpy set-global
-    dpy get XDefaultScreen scr set-global
-    dpy get scr get XRootWindow root set-global ;
-
-: close-x ( -- ) dpy get XCloseDisplay drop ;
-
-: with-x ( display-string quot -- )
-    [ initialize-x ] dip [ close-x ] [ ] cleanup ; inline