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

core/alien/alien-docs.factor

@@ -76,8 +76,8 @@ $nl
 { $examples "Here is a typical usage of " { $link add-library } ":"
 { $code
     "<< \"freetype\" {"
-    "    { [ macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
+    "    { [ os macosx? ] [ \"libfreetype.6.dylib\" \"cdecl\" add-library ] }"
-    "    { [ windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
+    "    { [ os windows? ] [ \"freetype6.dll\" \"cdecl\" add-library ] }"
     "    { [ t ] [ drop ] }"
     "} cond >>"
 }

core/alien/alien.factor

@@ -29,7 +29,7 @@ M: f expired? drop t ;
     f <displaced-alien> { simple-c-ptr } declare ; inline
 
 : alien>native-string ( alien -- string )
-    windows? [ alien>u16-string ] [ alien>char-string ] if ;
+    os windows? [ alien>u16-string ] [ alien>char-string ] if ;
 
 : dll-path ( dll -- string )
     (dll-path) alien>native-string ;

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

@@ -388,6 +388,6 @@ M: long-long-type box-return ( type -- )
 
     [ string>u16-alien ] "ushort*" c-type set-c-type-prep
     
-    win64? "longlong" "long" ? "ptrdiff_t" typedef
+    os winnt? cpu x86.64? and "longlong" "long" ? "ptrdiff_t" typedef
     
 ] with-compilation-unit

core/bootstrap/compiler/compiler.factor

@@ -14,7 +14,7 @@ IN: bootstrap.compiler
     "alien.remote-control" require
 ] unless
 
-"cpu." cpu append require
+"cpu." cpu word-name append require
 
 enable-compiler
 

core/bootstrap/image/image.factor

@@ -12,7 +12,8 @@ io.encodings.binary ;
 IN: bootstrap.image
 
 : my-arch ( -- arch )
-    cpu dup "ppc" = [ >r os "-" r> 3append ] when ;
+    cpu word-name
+    dup "ppc" = [ >r os word-name "-" r> 3append ] when ;
 
 : boot-image-name ( arch -- string )
     "boot." swap ".image" 3append ;

core/bootstrap/stage2.factor

@@ -11,7 +11,7 @@ IN: bootstrap.stage2
 SYMBOL: bootstrap-time
 
 : default-image-name ( -- string )
-    vm file-name windows? [ "." split1 drop ] when
+    vm file-name os windows? [ "." split1 drop ] when
     ".image" append resource-path ;
 
 : do-crossref ( -- )
@@ -65,8 +65,8 @@ parse-command-line
 "-no-crossref" cli-args member? [ do-crossref ] unless
 
 ! Set dll paths
-wince? [ "windows.ce" require ] when
+os wince? [ "windows.ce" require ] when
-winnt? [ "windows.nt" require ] when
+os winnt? [ "windows.nt" require ] when
 
 "deploy-vocab" get [
     "stage2: deployment mode" print

core/bootstrap/syntax.factor

@@ -43,6 +43,7 @@ IN: bootstrap.syntax
     "PRIMITIVE:"
     "PRIVATE>"
     "SBUF\""
+    "SINGLETON:"
     "SYMBOL:"
     "TUPLE:"
     "T{"

core/classes/classes-docs.factor

@@ -46,6 +46,7 @@ $nl
 "Other sorts of classes:"
 { $subsection "builtin-classes" }
 { $subsection "unions" }
+{ $subsection "singletons" }
 { $subsection "mixins" }
 { $subsection "predicates" }
 "Classes can be inspected and operated upon:"

core/classes/singleton/singleton-docs.factor

@@ -0,0 +1,28 @@
+USING: help.markup help.syntax kernel words ;
+IN: classes.singleton
+
+ARTICLE: "singletons" "Singleton classes"
+"A singleton is a class with only one instance and with no state.  Methods may dispatch off of singleton classes."
+{ $subsection POSTPONE: SINGLETON: }
+{ $subsection define-singleton-class } ;
+
+HELP: SINGLETON:
+{ $syntax "SINGLETON: class"
+} { $values
+    { "class" "a new singleton to define" }
+} { $description
+    "Defines a new predicate class whose superclass is " { $link word } ".  Only one instance of a singleton may exist because classes are " { $link eq? } " to themselves.  Methods may be defined on a singleton."
+} { $examples
+    { $example "USING: classes.singleton kernel io ;" "SINGLETON: foo\nGENERIC: bar ( obj -- )\nM: foo bar drop \"a foo!\" print ;\nfoo bar" "a foo!" }
+} { $see-also
+    POSTPONE: PREDICATE:
+} ;
+
+HELP: define-singleton-class
+{ $values { "word" "a new word" } }
+{ $description
+    "Defines a newly created word to be a singleton class." } ;
+
+{ POSTPONE: SINGLETON: define-singleton-class } related-words
+
+ABOUT: "singletons"

core/classes/singleton/singleton-tests.factor

@@ -0,0 +1,12 @@
+USING: kernel classes.singleton tools.test prettyprint io.streams.string ;
+IN: classes.singleton.tests
+
+[ ] [ SINGLETON: bzzt ] unit-test
+[ t ] [ bzzt bzzt? ] unit-test
+[ t ] [ bzzt bzzt eq? ] unit-test
+GENERIC: zammo ( obj -- str )
+[ ] [ M: bzzt zammo drop "yes!" ; ] unit-test
+[ "yes!" ] [ bzzt zammo ] unit-test
+[ ] [ SINGLETON: omg ] unit-test
+[ t ] [ omg singleton-class? ] unit-test
+[ "IN: classes.singleton.tests\nSINGLETON: omg\n" ] [ [ omg see ] with-string-writer ] unit-test

core/classes/singleton/singleton.factor

@@ -0,0 +1,11 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.predicate kernel sequences words ;
+IN: classes.singleton
+
+PREDICATE: singleton-class < predicate-class
+    [ "predicate-definition" word-prop ]
+    [ [ eq? ] curry ] bi sequence= ;
+
+: define-singleton-class ( word -- )
+    \ word over [ eq? ] curry define-predicate-class ;

core/command-line/command-line.factor

@@ -47,7 +47,7 @@ SYMBOL: main-vocab-hook
     ] bind ;
 
 : ignore-cli-args? ( -- ? )
-    macosx? "run" get "ui" = and ;
+    os macosx? "run" get "ui" = and ;
 
 : script-mode ( -- )
     t "quiet" set-global

core/cpu/architecture/architecture.factor

@@ -5,8 +5,6 @@ namespaces sequences layouts system hashtables classes alien
 byte-arrays bit-arrays float-arrays combinators words ;
 IN: cpu.architecture
 
-SYMBOL: compiler-backend
-
 ! A pseudo-register class for parameters spilled on the stack
 TUPLE: stack-params ;
 
@@ -26,122 +24,122 @@ GENERIC: vregs ( register-class -- regs )
 ! Load a literal (immediate or indirect)
 GENERIC# load-literal 1 ( obj vreg -- )
 
-HOOK: load-indirect compiler-backend ( obj reg -- )
+HOOK: load-indirect cpu ( obj reg -- )
 
-HOOK: stack-frame compiler-backend ( frame-size -- n )
+HOOK: stack-frame cpu ( frame-size -- n )
 
 : stack-frame* ( -- n )
     \ stack-frame get stack-frame ;
 
 ! Set up caller stack frame
-HOOK: %prologue compiler-backend ( n -- )
+HOOK: %prologue cpu ( n -- )
 
 : %prologue-later \ %prologue-later , ;
 
 ! Tear down stack frame
-HOOK: %epilogue compiler-backend ( n -- )
+HOOK: %epilogue cpu ( n -- )
 
 : %epilogue-later \ %epilogue-later , ;
 
 ! Store word XT in stack frame
-HOOK: %save-word-xt compiler-backend ( -- )
+HOOK: %save-word-xt cpu ( -- )
 
 ! Store dispatch branch XT in stack frame
-HOOK: %save-dispatch-xt compiler-backend ( -- )
+HOOK: %save-dispatch-xt cpu ( -- )
 
 M: object %save-dispatch-xt %save-word-xt ;
 
 ! Call another word
-HOOK: %call compiler-backend ( word -- )
+HOOK: %call cpu ( word -- )
 
 ! Local jump for branches
-HOOK: %jump-label compiler-backend ( label -- )
+HOOK: %jump-label cpu ( label -- )
 
 ! Test if vreg is 'f' or not
-HOOK: %jump-t compiler-backend ( label -- )
+HOOK: %jump-t cpu ( label -- )
 
-HOOK: %dispatch compiler-backend ( -- )
+HOOK: %dispatch cpu ( -- )
 
-HOOK: %dispatch-label compiler-backend ( word -- )
+HOOK: %dispatch-label cpu ( word -- )
 
 ! Return to caller
-HOOK: %return compiler-backend ( -- )
+HOOK: %return cpu ( -- )
 
 ! Change datastack height
-HOOK: %inc-d compiler-backend ( n -- )
+HOOK: %inc-d cpu ( n -- )
 
 ! Change callstack height
-HOOK: %inc-r compiler-backend ( n -- )
+HOOK: %inc-r cpu ( n -- )
 
 ! Load stack into vreg
-HOOK: %peek compiler-backend ( vreg loc -- )
+HOOK: %peek cpu ( vreg loc -- )
 
 ! Store vreg to stack
-HOOK: %replace compiler-backend ( vreg loc -- )
+HOOK: %replace cpu ( vreg loc -- )
 
 ! Box and unbox floats
-HOOK: %unbox-float compiler-backend ( dst src -- )
+HOOK: %unbox-float cpu ( dst src -- )
-HOOK: %box-float compiler-backend ( dst src -- )
+HOOK: %box-float cpu ( dst src -- )
 
 ! FFI stuff
 
 ! Is this integer small enough to appear in value template
 ! slots?
-HOOK: small-enough? compiler-backend ( n -- ? )
+HOOK: small-enough? cpu ( n -- ? )
 
 ! Is this structure small enough to be returned in registers?
-HOOK: struct-small-enough? compiler-backend ( size -- ? )
+HOOK: struct-small-enough? cpu ( size -- ? )
 
 ! Do we pass explode value structs?
-HOOK: value-structs? compiler-backend ( -- ? )
+HOOK: value-structs? cpu ( -- ? )
 
 ! If t, fp parameters are shadowed by dummy int parameters
-HOOK: fp-shadows-int? compiler-backend ( -- ? )
+HOOK: fp-shadows-int? cpu ( -- ? )
 
-HOOK: %prepare-unbox compiler-backend ( -- )
+HOOK: %prepare-unbox cpu ( -- )
 
-HOOK: %unbox compiler-backend ( n reg-class func -- )
+HOOK: %unbox cpu ( n reg-class func -- )
 
-HOOK: %unbox-long-long compiler-backend ( n func -- )
+HOOK: %unbox-long-long cpu ( n func -- )
 
-HOOK: %unbox-small-struct compiler-backend ( size -- )
+HOOK: %unbox-small-struct cpu ( size -- )
 
-HOOK: %unbox-large-struct compiler-backend ( n size -- )
+HOOK: %unbox-large-struct cpu ( n size -- )
 
-HOOK: %box compiler-backend ( n reg-class func -- )
+HOOK: %box cpu ( n reg-class func -- )
 
-HOOK: %box-long-long compiler-backend ( n func -- )
+HOOK: %box-long-long cpu ( n func -- )
 
-HOOK: %prepare-box-struct compiler-backend ( size -- )
+HOOK: %prepare-box-struct cpu ( size -- )
 
-HOOK: %box-small-struct compiler-backend ( size -- )
+HOOK: %box-small-struct cpu ( size -- )
 
-HOOK: %box-large-struct compiler-backend ( n size -- )
+HOOK: %box-large-struct cpu ( n size -- )
 
 GENERIC: %save-param-reg ( stack reg reg-class -- )
 
 GENERIC: %load-param-reg ( stack reg reg-class -- )
 
-HOOK: %prepare-alien-invoke compiler-backend ( -- )
+HOOK: %prepare-alien-invoke cpu ( -- )
 
-HOOK: %prepare-var-args compiler-backend ( -- )
+HOOK: %prepare-var-args cpu ( -- )
 
 M: object %prepare-var-args ;
 
-HOOK: %alien-invoke compiler-backend ( function library -- )
+HOOK: %alien-invoke cpu ( function library -- )
 
-HOOK: %cleanup compiler-backend ( alien-node -- )
+HOOK: %cleanup cpu ( alien-node -- )
 
-HOOK: %alien-callback compiler-backend ( quot -- )
+HOOK: %alien-callback cpu ( quot -- )
 
-HOOK: %callback-value compiler-backend ( ctype -- )
+HOOK: %callback-value cpu ( ctype -- )
 
 ! Return to caller with stdcall unwinding (only for x86)
-HOOK: %unwind compiler-backend ( n -- )
+HOOK: %unwind cpu ( n -- )
 
-HOOK: %prepare-alien-indirect compiler-backend ( -- )
+HOOK: %prepare-alien-indirect cpu ( -- )
 
-HOOK: %alien-indirect compiler-backend ( -- )
+HOOK: %alien-indirect cpu ( -- )
 
 M: stack-params param-reg drop ;
 
@@ -179,15 +177,15 @@ PREDICATE: inline-array < integer 32 < ;
     ] if-small-struct ;
 
 ! Alien accessors
-HOOK: %unbox-byte-array compiler-backend ( dst src -- )
+HOOK: %unbox-byte-array cpu ( dst src -- )
 
-HOOK: %unbox-alien compiler-backend ( dst src -- )
+HOOK: %unbox-alien cpu ( dst src -- )
 
-HOOK: %unbox-f compiler-backend ( dst src -- )
+HOOK: %unbox-f cpu ( dst src -- )
 
-HOOK: %unbox-any-c-ptr compiler-backend ( dst src -- )
+HOOK: %unbox-any-c-ptr cpu ( dst src -- )
 
-HOOK: %box-alien compiler-backend ( dst src -- )
+HOOK: %box-alien cpu ( dst src -- )
 
 : operand ( var -- op ) get v>operand ; inline
 

core/cpu/ppc/allot/allot.factor

@@ -32,7 +32,7 @@ IN: cpu.ppc.allot
     12 11 float tag-number ORI
     f fresh-object ;
 
-M: ppc-backend %box-float ( dst src -- )
+M: ppc %box-float ( dst src -- )
     [ v>operand ] bi@ %allot-float 12 MR ;
 
 : %allot-bignum ( #digits -- )
@@ -78,7 +78,7 @@ M: ppc-backend %box-float ( dst src -- )
         "end" resolve-label
     ] with-scope ;
 
-M: ppc-backend %box-alien ( dst src -- )
+M: ppc %box-alien ( dst src -- )
     { "end" "f" } [ define-label ] each
     0 over v>operand 0 CMPI
     "f" get BEQ

core/cpu/ppc/architecture/architecture.factor

@@ -7,8 +7,6 @@ layouts classes words.private alien combinators
 compiler.constants ;
 IN: cpu.ppc.architecture
 
-TUPLE: ppc-backend ;
-
 ! PowerPC register assignments
 ! r3-r10, r16-r31: integer vregs
 ! f0-f13: float vregs
@@ -21,14 +19,14 @@ TUPLE: ppc-backend ;
 
 : reserved-area-size
     os {
-        { "linux" [ 2 ] }
+        { linux [ 2 ] }
-        { "macosx" [ 6 ] }
+        { macosx [ 6 ] }
     } case cells ; foldable
 
 : lr-save
     os {
-        { "linux" [ 1 ] }
+        { linux [ 1 ] }
-        { "macosx" [ 2 ] }
+        { macosx [ 2 ] }
     } case cells ; foldable
 
 : param@ ( n -- x ) reserved-area-size + ; inline
@@ -44,7 +42,7 @@ TUPLE: ppc-backend ;
 
 : xt-save ( n -- i ) 2 cells - ;
 
-M: ppc-backend stack-frame ( n -- i )
+M: ppc stack-frame ( n -- i )
     local@ factor-area-size + 4 cells align ;
 
 M: temp-reg v>operand drop 11 ;
@@ -60,8 +58,8 @@ M: int-regs vregs
 M: float-regs return-reg drop 1 ;
 M: float-regs param-regs 
     drop os H{
-        { "macosx" { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
+        { macosx { 1 2 3 4 5 6 7 8 9 10 11 12 13 } }
-        { "linux" { 1 2 3 4 5 6 7 8 } }
+        { linux { 1 2 3 4 5 6 7 8 } }
     } at ;
 M: float-regs vregs drop { 0 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
 
@@ -73,14 +71,14 @@ M: rs-loc loc>operand rs-loc-n cells neg rs-reg swap ;
 M: immediate load-literal
     [ v>operand ] bi@ LOAD ;
 
-M: ppc-backend load-indirect ( obj reg -- )
+M: ppc load-indirect ( obj reg -- )
     [ 0 swap LOAD32 rc-absolute-ppc-2/2 rel-literal ] keep
     dup 0 LWZ ;
 
-M: ppc-backend %save-word-xt ( -- )
+M: ppc %save-word-xt ( -- )
     0 11 LOAD32 rc-absolute-ppc-2/2 rel-this ;
 
-M: ppc-backend %prologue ( n -- )
+M: ppc %prologue ( n -- )
     0 MFLR
     1 1 pick neg ADDI
     11 1 pick xt-save STW
@@ -88,7 +86,7 @@ M: ppc-backend %prologue ( n -- )
     11 1 pick next-save STW
     0 1 rot lr-save + STW ;
 
-M: ppc-backend %epilogue ( n -- )
+M: ppc %epilogue ( n -- )
     #! At the end of each word that calls a subroutine, we store
     #! the previous link register value in r0 by popping it off
     #! the stack, set the link register to the contents of r0,
@@ -104,14 +102,14 @@ M: ppc-backend %epilogue ( n -- )
 : %load-dlsym ( symbol dll register -- )
     0 swap LOAD32 rc-absolute-ppc-2/2 rel-dlsym ;
 
-M: ppc-backend %call ( label -- ) BL ;
+M: ppc %call ( label -- ) BL ;
 
-M: ppc-backend %jump-label ( label -- ) B ;
+M: ppc %jump-label ( label -- ) B ;
 
-M: ppc-backend %jump-t ( label -- )
+M: ppc %jump-t ( label -- )
     0 "flag" operand f v>operand CMPI BNE ;
 
-M: ppc-backend %dispatch ( -- )
+M: ppc %dispatch ( -- )
     [
         %epilogue-later
         0 11 LOAD32 rc-absolute-ppc-2/2 rel-here
@@ -124,25 +122,25 @@ M: ppc-backend %dispatch ( -- )
         { +scratch+ { { f "offset" } } }
     } with-template ;
 
-M: ppc-backend %dispatch-label ( word -- )
+M: ppc %dispatch-label ( word -- )
     0 , rc-absolute-cell rel-word ;
 
-M: ppc-backend %return ( -- ) %epilogue-later BLR ;
+M: ppc %return ( -- ) %epilogue-later BLR ;
 
-M: ppc-backend %unwind drop %return ;
+M: ppc %unwind drop %return ;
 
-M: ppc-backend %peek ( vreg loc -- )
+M: ppc %peek ( vreg loc -- )
     >r v>operand r> loc>operand LWZ ;
 
-M: ppc-backend %replace
+M: ppc %replace
     >r v>operand r> loc>operand STW ;
 
-M: ppc-backend %unbox-float ( dst src -- )
+M: ppc %unbox-float ( dst src -- )
     [ v>operand ] bi@ float-offset LFD ;
 
-M: ppc-backend %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
+M: ppc %inc-d ( n -- ) ds-reg dup rot cells ADDI ;
 
-M: ppc-backend %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
+M: ppc %inc-r ( n -- ) rs-reg dup rot cells ADDI ;
 
 M: int-regs %save-param-reg drop 1 rot local@ STW ;
 
@@ -166,19 +164,19 @@ M: stack-params %save-param-reg ( stack reg reg-class -- )
     0 1 rot param@ stack-frame* + LWZ
     0 1 rot local@ STW ;
 
-M: ppc-backend %prepare-unbox ( -- )
+M: ppc %prepare-unbox ( -- )
     ! First parameter is top of stack
     3 ds-reg 0 LWZ
     ds-reg dup cell SUBI ;
 
-M: ppc-backend %unbox ( n reg-class func -- )
+M: ppc %unbox ( n reg-class func -- )
     ! Value must be in r3
     ! Call the unboxer
     f %alien-invoke
     ! Store the return value on the C stack
     over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
 
-M: ppc-backend %unbox-long-long ( n func -- )
+M: ppc %unbox-long-long ( n func -- )
     ! Value must be in r3:r4
     ! Call the unboxer
     f %alien-invoke
@@ -188,7 +186,7 @@ M: ppc-backend %unbox-long-long ( n func -- )
         4 1 rot cell + local@ STW
     ] when* ;
 
-M: ppc-backend %unbox-large-struct ( n size -- )
+M: ppc %unbox-large-struct ( n size -- )
     ! Value must be in r3
     ! Compute destination address
     4 1 roll local@ ADDI
@@ -197,7 +195,7 @@ M: ppc-backend %unbox-large-struct ( n size -- )
     ! Call the function
     "to_value_struct" f %alien-invoke ;
 
-M: ppc-backend %box ( n reg-class func -- )
+M: ppc %box ( n reg-class func -- )
     ! If the source is a stack location, load it into freg #0.
     ! If the source is f, then we assume the value is already in
     ! freg #0.
@@ -205,7 +203,7 @@ M: ppc-backend %box ( n reg-class func -- )
     over [ 0 over param-reg swap %load-param-reg ] [ 2drop ] if
     r> f %alien-invoke ;
 
-M: ppc-backend %box-long-long ( n func -- )
+M: ppc %box-long-long ( n func -- )
     >r [
         3 1 pick local@ LWZ
         4 1 rot cell + local@ LWZ
@@ -215,12 +213,12 @@ M: ppc-backend %box-long-long ( n func -- )
 
 : struct-return@ ( size n -- n ) [ local@ ] [ temp@ ] ?if ;
 
-M: ppc-backend %prepare-box-struct ( size -- )
+M: ppc %prepare-box-struct ( size -- )
     #! Compute target address for value struct return
     3 1 rot f struct-return@ ADDI
     3 1 0 local@ STW ;
 
-M: ppc-backend %box-large-struct ( n size -- )
+M: ppc %box-large-struct ( n size -- )
     #! If n = f, then we're boxing a returned struct
     [ swap struct-return@ ] keep
     ! Compute destination address
@@ -230,7 +228,7 @@ M: ppc-backend %box-large-struct ( n size -- )
     ! Call the function
     "box_value_struct" f %alien-invoke ;
 
-M: ppc-backend %prepare-alien-invoke
+M: ppc %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
@@ -240,20 +238,20 @@ M: ppc-backend %prepare-alien-invoke
     ds-reg 11 8 STW
     rs-reg 11 12 STW ;
 
-M: ppc-backend %alien-invoke ( symbol dll -- )
+M: ppc %alien-invoke ( symbol dll -- )
     11 %load-dlsym (%call) ;
 
-M: ppc-backend %alien-callback ( quot -- )
+M: ppc %alien-callback ( quot -- )
     3 load-indirect "c_to_factor" f %alien-invoke ;
 
-M: ppc-backend %prepare-alien-indirect ( -- )
+M: ppc %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
     3 1 cell temp@ STW ;
 
-M: ppc-backend %alien-indirect ( -- )
+M: ppc %alien-indirect ( -- )
     11 1 cell temp@ LWZ (%call) ;
 
-M: ppc-backend %callback-value ( ctype -- )
+M: ppc %callback-value ( ctype -- )
      ! Save top of data stack
      3 ds-reg 0 LWZ
      3 1 0 local@ STW
@@ -264,7 +262,7 @@ M: ppc-backend %callback-value ( ctype -- )
      ! Unbox former top of data stack to return registers
      unbox-return ;
 
-M: ppc-backend %cleanup ( alien-node -- ) drop ;
+M: ppc %cleanup ( alien-node -- ) drop ;
 
 : %untag ( src dest -- ) 0 0 31 tag-bits get - RLWINM ;
 
@@ -272,34 +270,34 @@ M: ppc-backend %cleanup ( alien-node -- ) drop ;
 
 : %untag-fixnum ( dest src -- ) tag-bits get SRAWI ;
 
-M: ppc-backend value-structs?
+M: ppc value-structs?
     #! On Linux/PPC, value structs are passed in the same way
     #! as reference structs, we just have to make a copy first.
-    linux? not ;
+    os linux? not ;
 
-M: ppc-backend fp-shadows-int? ( -- ? ) macosx? ;
+M: ppc fp-shadows-int? ( -- ? ) os macosx? ;
 
-M: ppc-backend small-enough? ( n -- ? ) -32768 32767 between? ;
+M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
 
-M: ppc-backend struct-small-enough? ( size -- ? ) drop f ;
+M: ppc struct-small-enough? ( size -- ? ) drop f ;
 
-M: ppc-backend %box-small-struct
+M: ppc %box-small-struct
     drop "No small structs" throw ;
 
-M: ppc-backend %unbox-small-struct
+M: ppc %unbox-small-struct
     drop "No small structs" throw ;
 
 ! Alien intrinsics
-M: ppc-backend %unbox-byte-array ( dst src -- )
+M: ppc %unbox-byte-array ( dst src -- )
     [ v>operand ] bi@ byte-array-offset ADDI ;
 
-M: ppc-backend %unbox-alien ( dst src -- )
+M: ppc %unbox-alien ( dst src -- )
     [ v>operand ] bi@ alien-offset LWZ ;
 
-M: ppc-backend %unbox-f ( dst src -- )
+M: ppc %unbox-f ( dst src -- )
     drop 0 swap v>operand LI ;
 
-M: ppc-backend %unbox-any-c-ptr ( dst src -- )
+M: ppc %unbox-any-c-ptr ( dst src -- )
     { "is-byte-array" "end" "start" } [ define-label ] each
     ! Address is computed in R12
     0 12 LI

core/cpu/ppc/ppc.factor

@@ -2,18 +2,13 @@ USING: cpu.ppc.architecture cpu.ppc.intrinsics cpu.architecture
 namespaces alien.c-types kernel system combinators ;
 
 {
-    { [ macosx? ] [
+    { [ os macosx? ] [
         4 "longlong" c-type set-c-type-align
         4 "ulonglong" c-type set-c-type-align
+        4 "double" c-type set-c-type-align
     ] }
-    { [ linux? ] [
+    { [ os linux? ] [
         t "longlong" c-type set-c-type-stack-align?
         t "ulonglong" c-type set-c-type-stack-align?
     ] }
 } cond
-
-T{ ppc-backend } compiler-backend set-global
-
-macosx? [
-    4 "double" c-type set-c-type-align
-] when

core/cpu/x86/32/32.factor

@@ -8,23 +8,20 @@ alien.compiler combinators command-line
 compiler compiler.units io vocabs.loader accessors ;
 IN: cpu.x86.32
 
-PREDICATE: x86-32-backend < x86-backend
-    x86-backend-cell 4 = ;
-
 ! We implement the FFI for Linux, OS X and Windows all at once.
 ! OS X requires that the stack be 16-byte aligned, and we do
 ! this on all platforms, sacrificing some stack space for
 ! code simplicity.
 
-M: x86-32-backend ds-reg ESI ;
+M: x86.32 ds-reg ESI ;
-M: x86-32-backend rs-reg EDI ;
+M: x86.32 rs-reg EDI ;
-M: x86-32-backend stack-reg ESP ;
+M: x86.32 stack-reg ESP ;
-M: x86-32-backend xt-reg ECX ;
+M: x86.32 xt-reg ECX ;
-M: x86-32-backend stack-save-reg EDX ;
+M: x86.32 stack-save-reg EDX ;
 
 M: temp-reg v>operand drop EBX ;
 
-M: x86-32-backend %alien-invoke ( symbol dll -- )
+M: x86.32 %alien-invoke ( symbol dll -- )
     (CALL) rel-dlsym ;
 
 ! On x86, parameters are never passed in registers.
@@ -61,20 +58,20 @@ M: float-regs store-return-reg load/store-float-return FSTP ;
 
 ! On x86, we can always use an address as an operand
 ! directly.
-M: x86-32-backend address-operand ;
+M: x86.32 address-operand ;
 
-M: x86-32-backend fixnum>slot@ 1 SHR ;
+M: x86.32 fixnum>slot@ 1 SHR ;
 
-M: x86-32-backend prepare-division CDQ ;
+M: x86.32 prepare-division CDQ ;
 
-M: x86-32-backend load-indirect
+M: x86.32 load-indirect
     0 [] MOV rc-absolute-cell rel-literal ;
 
 M: object %load-param-reg 3drop ;
 
 M: object %save-param-reg 3drop ;
 
-M: x86-32-backend %prepare-unbox ( -- )
+M: x86.32 %prepare-unbox ( -- )
     #! Move top of data stack to EAX.
     EAX ESI [] MOV
     ESI 4 SUB ;
@@ -87,7 +84,7 @@ M: x86-32-backend %prepare-unbox ( -- )
         f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-32-backend %unbox ( n reg-class func -- )
+M: x86.32 %unbox ( n reg-class func -- )
     #! The value being unboxed must already be in EAX.
     #! If n is f, we're unboxing a return value about to be
     #! returned by the callback. Otherwise, we're unboxing
@@ -96,7 +93,7 @@ M: x86-32-backend %unbox ( n reg-class func -- )
     ! Store the return value on the C stack
     over [ store-return-reg ] [ 2drop ] if ;
 
-M: x86-32-backend %unbox-long-long ( n func -- )
+M: x86.32 %unbox-long-long ( n func -- )
     (%unbox)
     ! Store the return value on the C stack
     [
@@ -104,7 +101,7 @@ M: x86-32-backend %unbox-long-long ( n func -- )
         cell + stack@ EDX MOV
     ] when* ;
 
-M: x86-32-backend %unbox-struct-2
+M: x86.32 %unbox-struct-2
     #! Alien must be in EAX.
     4 [
         EAX PUSH
@@ -115,7 +112,7 @@ M: x86-32-backend %unbox-struct-2
         EAX EAX [] MOV
     ] with-aligned-stack ;
 
-M: x86-32-backend %unbox-large-struct ( n size -- )
+M: x86.32 %unbox-large-struct ( n size -- )
     #! Alien must be in EAX.
     ! Compute destination address
     ECX ESP roll [+] LEA
@@ -147,7 +144,7 @@ M: x86-32-backend %unbox-large-struct ( n size -- )
     over [ [ box@ ] keep [ load-return-reg ] keep ] [ nip ] if
     push-return-reg ;
 
-M: x86-32-backend %box ( n reg-class func -- )
+M: x86.32 %box ( n reg-class func -- )
     over reg-size [
         >r (%box) r> f %alien-invoke
     ] with-aligned-stack ;
@@ -165,12 +162,12 @@ M: x86-32-backend %box ( n reg-class func -- )
     EDX PUSH
     EAX PUSH ;
 
-M: x86-32-backend %box-long-long ( n func -- )
+M: x86.32 %box-long-long ( n func -- )
     8 [
         >r (%box-long-long) r> f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-32-backend %box-large-struct ( n size -- )
+M: x86.32 %box-large-struct ( n size -- )
     ! Compute destination address
     [ swap struct-return@ ] keep
     ECX ESP roll [+] LEA
@@ -183,13 +180,13 @@ M: x86-32-backend %box-large-struct ( n size -- )
         "box_value_struct" f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-32-backend %prepare-box-struct ( size -- )
+M: x86.32 %prepare-box-struct ( size -- )
     ! Compute target address for value struct return
     EAX ESP rot f struct-return@ [+] LEA
     ! Store it as the first parameter
     ESP [] EAX MOV ;
 
-M: x86-32-backend %unbox-struct-1
+M: x86.32 %unbox-struct-1
     #! Alien must be in EAX.
     4 [
         EAX PUSH
@@ -198,7 +195,7 @@ M: x86-32-backend %unbox-struct-1
         EAX EAX [] MOV
     ] with-aligned-stack ;
 
-M: x86-32-backend %box-small-struct ( size -- )
+M: x86.32 %box-small-struct ( size -- )
     #! Box a <= 8-byte struct returned in EAX:DX. OS X only.
     12 [
         PUSH
@@ -207,21 +204,21 @@ M: x86-32-backend %box-small-struct ( size -- )
         "box_small_struct" f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-32-backend %prepare-alien-indirect ( -- )
+M: x86.32 %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
     cell temp@ EAX MOV ;
 
-M: x86-32-backend %alien-indirect ( -- )
+M: x86.32 %alien-indirect ( -- )
     cell temp@ CALL ;
 
-M: x86-32-backend %alien-callback ( quot -- )
+M: x86.32 %alien-callback ( quot -- )
     4 [
         EAX load-indirect
         EAX PUSH
         "c_to_factor" f %alien-invoke
     ] with-aligned-stack ;
 
-M: x86-32-backend %callback-value ( ctype -- )
+M: x86.32 %callback-value ( ctype -- )
     ! Align C stack
     ESP 12 SUB
     ! Save top of data stack
@@ -236,7 +233,7 @@ M: x86-32-backend %callback-value ( ctype -- )
     ! Unbox EAX
     unbox-return ;
 
-M: x86-32-backend %cleanup ( alien-node -- )
+M: x86.32 %cleanup ( alien-node -- )
     #! a) If we just called an stdcall function in Windows, it
     #! cleaned up the stack frame for us. But we don't want that
     #! so we 'undo' the cleanup since we do that in %epilogue.
@@ -254,19 +251,14 @@ M: x86-32-backend %cleanup ( alien-node -- )
         }
     } cond ;
 
-M: x86-32-backend %unwind ( n -- ) %epilogue-later RET ;
+M: x86.32 %unwind ( n -- ) %epilogue-later RET ;
 
-windows? [
+os windows? [
     cell "longlong" c-type set-c-type-align
     cell "ulonglong" c-type set-c-type-align
-] unless
-
-windows? [
     4 "double" c-type set-c-type-align
 ] unless
 
-T{ x86-backend f 4 } compiler-backend set-global
-
 : sse2? "Intrinsic" throw ;
 
 \ sse2? [

core/cpu/x86/64/64.factor

@@ -8,14 +8,11 @@ layouts alien alien.accessors alien.compiler alien.structs slots
 splitting assocs ;
 IN: cpu.x86.64
 
-PREDICATE: amd64-backend < x86-backend
+M: x86.64 ds-reg R14 ;
-    x86-backend-cell 8 = ;
+M: x86.64 rs-reg R15 ;
-
+M: x86.64 stack-reg RSP ;
-M: amd64-backend ds-reg R14 ;
+M: x86.64 xt-reg RCX ;
-M: amd64-backend rs-reg R15 ;
+M: x86.64 stack-save-reg RSI ;
-M: amd64-backend stack-reg RSP ;
-M: amd64-backend xt-reg RCX ;
-M: amd64-backend stack-save-reg RSI ;
 
 M: temp-reg v>operand drop RBX ;
 
@@ -34,18 +31,18 @@ M: float-regs vregs
 M: float-regs param-regs
     drop { XMM0 XMM1 XMM2 XMM3 XMM4 XMM5 XMM6 XMM7 } ;
 
-M: amd64-backend address-operand ( address -- operand )
+M: x86.64 address-operand ( address -- operand )
     #! On AMD64, we have to load 64-bit addresses into a
     #! scratch register first. The usage of R11 here is a hack.
     #! This word can only be called right before a subroutine
     #! call, where all vregs have been flushed anyway.
     temp-reg v>operand [ swap MOV ] keep ;
 
-M: amd64-backend fixnum>slot@ drop ;
+M: x86.64 fixnum>slot@ drop ;
 
-M: amd64-backend prepare-division CQO ;
+M: x86.64 prepare-division CQO ;
 
-M: amd64-backend load-indirect ( literal reg -- )
+M: x86.64 load-indirect ( literal reg -- )
     0 [] MOV rc-relative rel-literal ;
 
 M: stack-params %load-param-reg
@@ -56,27 +53,27 @@ M: stack-params %load-param-reg
 M: stack-params %save-param-reg
     >r stack-frame* + cell + swap r> %load-param-reg ;
 
-M: amd64-backend %prepare-unbox ( -- )
+M: x86.64 %prepare-unbox ( -- )
     ! First parameter is top of stack
     RDI R14 [] MOV
     R14 cell SUB ;
 
-M: amd64-backend %unbox ( n reg-class func -- )
+M: x86.64 %unbox ( n reg-class func -- )
     ! Call the unboxer
     f %alien-invoke
     ! Store the return value on the C stack
     over [ [ return-reg ] keep %save-param-reg ] [ 2drop ] if ;
 
-M: amd64-backend %unbox-long-long ( n func -- )
+M: x86.64 %unbox-long-long ( n func -- )
     T{ int-regs } swap %unbox ;
 
-M: amd64-backend %unbox-struct-1 ( -- )
+M: x86.64 %unbox-struct-1 ( -- )
     #! Alien must be in RDI.
     "alien_offset" f %alien-invoke
     ! Load first cell
     RAX RAX [] MOV ;
 
-M: amd64-backend %unbox-struct-2 ( -- )
+M: x86.64 %unbox-struct-2 ( -- )
     #! Alien must be in RDI.
     "alien_offset" f %alien-invoke
     ! Load second cell
@@ -84,7 +81,7 @@ M: amd64-backend %unbox-struct-2 ( -- )
     ! Load first cell
     RAX RAX [] MOV ;
 
-M: amd64-backend %unbox-large-struct ( n size -- )
+M: x86.64 %unbox-large-struct ( n size -- )
     ! Source is in RDI
     ! Load destination address
     RSI RSP roll [+] LEA
@@ -97,7 +94,7 @@ M: amd64-backend %unbox-large-struct ( n size -- )
     0 over param-reg swap return-reg
     2dup eq? [ 2drop ] [ MOV ] if ;
 
-M: amd64-backend %box ( n reg-class func -- )
+M: x86.64 %box ( n reg-class func -- )
     rot [
         rot [ 0 swap param-reg ] keep %load-param-reg
     ] [
@@ -105,19 +102,19 @@ M: amd64-backend %box ( n reg-class func -- )
     ] if*
     f %alien-invoke ;
 
-M: amd64-backend %box-long-long ( n func -- )
+M: x86.64 %box-long-long ( n func -- )
     T{ int-regs } swap %box ;
 
-M: amd64-backend struct-small-enough? ( size -- ? ) 2 cells <= ;
+M: x86.64 struct-small-enough? ( size -- ? ) 2 cells <= ;
 
-M: amd64-backend %box-small-struct ( size -- )
+M: x86.64 %box-small-struct ( size -- )
     #! Box a <= 16-byte struct returned in RAX:RDX.
     RDI RAX MOV
     RSI RDX MOV
     RDX swap MOV
     "box_small_struct" f %alien-invoke ;
 
-M: amd64-backend %box-large-struct ( n size -- )
+M: x86.64 %box-large-struct ( n size -- )
     ! Struct size is parameter 2
     RSI over MOV
     ! Compute destination address
@@ -125,27 +122,27 @@ M: amd64-backend %box-large-struct ( n size -- )
     ! Copy the struct from the C stack
     "box_value_struct" f %alien-invoke ;
 
-M: amd64-backend %prepare-box-struct ( size -- )
+M: x86.64 %prepare-box-struct ( size -- )
     ! Compute target address for value struct return
     RAX RSP rot f struct-return@ [+] LEA
     RSP 0 [+] RAX MOV ;
 
-M: amd64-backend %prepare-var-args RAX RAX XOR ;
+M: x86.64 %prepare-var-args RAX RAX XOR ;
 
-M: amd64-backend %alien-invoke ( symbol dll -- )
+M: x86.64 %alien-invoke ( symbol dll -- )
     0 address-operand >r rc-absolute-cell rel-dlsym r> CALL ;
 
-M: amd64-backend %prepare-alien-indirect ( -- )
+M: x86.64 %prepare-alien-indirect ( -- )
     "unbox_alien" f %alien-invoke
     cell temp@ RAX MOV ;
 
-M: amd64-backend %alien-indirect ( -- )
+M: x86.64 %alien-indirect ( -- )
     cell temp@ CALL ;
 
-M: amd64-backend %alien-callback ( quot -- )
+M: x86.64 %alien-callback ( quot -- )
     RDI load-indirect "c_to_factor" f %alien-invoke ;
 
-M: amd64-backend %callback-value ( ctype -- )
+M: x86.64 %callback-value ( ctype -- )
     ! Save top of data stack
     %prepare-unbox
     ! Put former top of data stack in RDI
@@ -157,9 +154,9 @@ M: amd64-backend %callback-value ( ctype -- )
     ! Unbox former top of data stack to return registers
     unbox-return ;
 
-M: amd64-backend %cleanup ( alien-node -- ) drop ;
+M: x86.64 %cleanup ( alien-node -- ) drop ;
 
-M: amd64-backend %unwind ( n -- ) drop %epilogue-later 0 RET ;
+M: x86.64 %unwind ( n -- ) drop %epilogue-later 0 RET ;
 
 USE: cpu.x86.intrinsics
 
@@ -171,8 +168,6 @@ USE: cpu.x86.intrinsics
 \ alien-signed-4 small-reg-32 define-signed-getter
 \ set-alien-signed-4 small-reg-32 define-setter
 
-T{ x86-backend f 8 } compiler-backend set-global
-
 ! The ABI for passing structs by value is pretty messed up
 << "void*" c-type clone "__stack_value" define-primitive-type
 T{ stack-params } "__stack_value" c-type set-c-type-reg-class >>

core/cpu/x86/allot/allot.factor

@@ -46,7 +46,7 @@ IN: cpu.x86.allot
     allot-reg swap tag-number OR
     allot-reg MOV ;
 
-M: x86-backend %box-float ( dst src -- )
+M: x86 %box-float ( dst src -- )
     #! Only called by pentium4 backend, uses SSE2 instruction
     #! dest is a loc or a vreg
     float 16 [
@@ -86,7 +86,7 @@ M: x86-backend %box-float ( dst src -- )
         "end" resolve-label
     ] with-scope ;
 
-M: x86-backend %box-alien ( dst src -- )
+M: x86 %box-alien ( dst src -- )
     [
         { "end" "f" } [ define-label ] each
         dup v>operand 0 CMP

core/cpu/x86/architecture/architecture.factor

@@ -6,13 +6,11 @@ memory namespaces sequences words generator generator.registers
 generator.fixup system layouts combinators compiler.constants ;
 IN: cpu.x86.architecture
 
-TUPLE: x86-backend cell ;
+HOOK: ds-reg cpu
-
+HOOK: rs-reg cpu
-HOOK: ds-reg compiler-backend
+HOOK: stack-reg cpu
-HOOK: rs-reg compiler-backend
+HOOK: xt-reg cpu
-HOOK: stack-reg compiler-backend
+HOOK: stack-save-reg cpu
-HOOK: xt-reg compiler-backend
-HOOK: stack-save-reg compiler-backend
 
 : stack@ stack-reg swap [+] ;
 
@@ -33,34 +31,34 @@ GENERIC: push-return-reg ( reg-class -- )
 GENERIC: load-return-reg ( stack@ reg-class -- )
 GENERIC: store-return-reg ( stack@ reg-class -- )
 
-HOOK: address-operand compiler-backend ( address -- operand )
+HOOK: address-operand cpu ( address -- operand )
 
-HOOK: fixnum>slot@ compiler-backend
+HOOK: fixnum>slot@ cpu
 
-HOOK: prepare-division compiler-backend
+HOOK: prepare-division cpu
 
 M: immediate load-literal v>operand swap v>operand MOV ;
 
-M: x86-backend stack-frame ( n -- i )
+M: x86 stack-frame ( n -- i )
     3 cells + 16 align cell - ;
 
-M: x86-backend %save-word-xt ( -- )
+M: x86 %save-word-xt ( -- )
     xt-reg 0 MOV rc-absolute-cell rel-this ;
 
 : factor-area-size 4 cells ;
 
-M: x86-backend %prologue ( n -- )
+M: x86 %prologue ( n -- )
     dup cell + PUSH
     xt-reg PUSH
     stack-reg swap 2 cells - SUB ;
 
-M: x86-backend %epilogue ( n -- )
+M: x86 %epilogue ( n -- )
     stack-reg swap ADD ;
 
 : %alien-global ( symbol dll register -- )
     [ 0 MOV rc-absolute-cell rel-dlsym ] keep dup [] MOV ;
 
-M: x86-backend %prepare-alien-invoke
+M: x86 %prepare-alien-invoke
     #! Save Factor stack pointers in case the C code calls a
     #! callback which does a GC, which must reliably trace
     #! all roots.
@@ -70,11 +68,11 @@ M: x86-backend %prepare-alien-invoke
     temp-reg v>operand 2 cells [+] ds-reg MOV
     temp-reg v>operand 3 cells [+] rs-reg MOV ;
 
-M: x86-backend %call ( label -- ) CALL ;
+M: x86 %call ( label -- ) CALL ;
 
-M: x86-backend %jump-label ( label -- ) JMP ;
+M: x86 %jump-label ( label -- ) JMP ;
 
-M: x86-backend %jump-t ( label -- )
+M: x86 %jump-t ( label -- )
     "flag" operand f v>operand CMP JNE ;
 
 : code-alignment ( -- n )
@@ -83,7 +81,7 @@ M: x86-backend %jump-t ( label -- )
 : align-code ( n -- )
     0 <repetition> % ;
 
-M: x86-backend %dispatch ( -- )
+M: x86 %dispatch ( -- )
     [
         %epilogue-later
         ! Load jump table base. We use a temporary register
@@ -105,27 +103,27 @@ M: x86-backend %dispatch ( -- )
         { +clobber+ { "n" } }
     } with-template ;
 
-M: x86-backend %dispatch-label ( word -- )
+M: x86 %dispatch-label ( word -- )
     0 cell, rc-absolute-cell rel-word ;
 
-M: x86-backend %unbox-float ( dst src -- )
+M: x86 %unbox-float ( dst src -- )
     [ v>operand ] bi@ float-offset [+] MOVSD ;
 
-M: x86-backend %peek [ v>operand ] bi@ MOV ;
+M: x86 %peek [ v>operand ] bi@ MOV ;
 
-M: x86-backend %replace swap %peek ;
+M: x86 %replace swap %peek ;
 
 : (%inc) swap cells dup 0 > [ ADD ] [ neg SUB ] if ;
 
-M: x86-backend %inc-d ( n -- ) ds-reg (%inc) ;
+M: x86 %inc-d ( n -- ) ds-reg (%inc) ;
 
-M: x86-backend %inc-r ( n -- ) rs-reg (%inc) ;
+M: x86 %inc-r ( n -- ) rs-reg (%inc) ;
 
-M: x86-backend fp-shadows-int? ( -- ? ) f ;
+M: x86 fp-shadows-int? ( -- ? ) f ;
 
-M: x86-backend value-structs? t ;
+M: x86 value-structs? t ;
 
-M: x86-backend small-enough? ( n -- ? )
+M: x86 small-enough? ( n -- ? )
     HEX: -80000000 HEX: 7fffffff between? ;
 
 : %untag ( reg -- ) tag-mask get bitnot AND ;
@@ -143,34 +141,34 @@ M: x86-backend small-enough? ( n -- ? )
         \ stack-frame get swap -
     ] ?if ;
 
-HOOK: %unbox-struct-1 compiler-backend ( -- )
+HOOK: %unbox-struct-1 cpu ( -- )
 
-HOOK: %unbox-struct-2 compiler-backend ( -- )
+HOOK: %unbox-struct-2 cpu ( -- )
 
-M: x86-backend %unbox-small-struct ( size -- )
+M: x86 %unbox-small-struct ( size -- )
     #! Alien must be in EAX.
     cell align cell /i {
         { 1 [ %unbox-struct-1 ] }
         { 2 [ %unbox-struct-2 ] }
     } case ;
 
-M: x86-backend struct-small-enough? ( size -- ? )
+M: x86 struct-small-enough? ( size -- ? )
     { 1 2 4 8 } member?
-    os { "linux" "netbsd" "solaris" } member? not and ;
+    os { linux netbsd solaris } member? not and ;
 
-M: x86-backend %return ( -- ) 0 %unwind ;
+M: x86 %return ( -- ) 0 %unwind ;
 
 ! Alien intrinsics
-M: x86-backend %unbox-byte-array ( dst src -- )
+M: x86 %unbox-byte-array ( dst src -- )
     [ v>operand ] bi@ byte-array-offset [+] LEA ;
 
-M: x86-backend %unbox-alien ( dst src -- )
+M: x86 %unbox-alien ( dst src -- )
     [ v>operand ] bi@ alien-offset [+] MOV ;
 
-M: x86-backend %unbox-f ( dst src -- )
+M: x86 %unbox-f ( dst src -- )
     drop v>operand 0 MOV ;
 
-M: x86-backend %unbox-any-c-ptr ( dst src -- )
+M: x86 %unbox-any-c-ptr ( dst src -- )
     { "is-byte-array" "end" "start" } [ define-label ] each
     ! Address is computed in ds-reg
     ds-reg PUSH

core/generator/fixup/fixup.factor

@@ -111,7 +111,7 @@ SYMBOL: literal-table
 : add-literal ( obj -- n ) literal-table get push-new* ;
 
 : string>symbol ( str -- alien )
-    [ wince? [ string>u16-alien ] [ string>char-alien ] if ]
+    [ os wince? [ string>u16-alien ] [ string>char-alien ] if ]
     over string? [ call ] [ map ] if ;
 
 : add-dlsym-literals ( symbol dll -- )

core/io/backend/backend-tests.factor

@@ -1,4 +1,4 @@
-IN: io.backend.tests
+IN: io.backend.tests
-USING: tools.test io.backend kernel ;
+USING: tools.test io.backend kernel ;
-
+
-[ ] [ "a" normalize-pathname drop ] unit-test
+[ ] [ "a" normalize-path drop ] unit-test

core/io/backend/backend.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: init kernel system namespaces io io.encodings
-io.encodings.utf8 init assocs ;
+io.encodings.utf8 init assocs splitting ;
 IN: io.backend
 
 SYMBOL: io-backend
@@ -18,9 +18,9 @@ HOOK: io-multiplex io-backend ( ms -- )
 
 HOOK: normalize-directory io-backend ( str -- newstr )
 
-HOOK: normalize-pathname io-backend ( str -- newstr )
+HOOK: normalize-path io-backend ( str -- newstr )
 
-M: object normalize-directory normalize-pathname ;
+M: object normalize-directory normalize-path ;
 
 : set-io-backend ( io-backend -- )
     io-backend set-global init-io init-stdio

core/io/files/files-docs.factor

@@ -252,7 +252,7 @@ HELP: normalize-directory
 { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
 { $description "Called by the " { $link directory } " word to prepare a pathname before passing it to the " { $link (directory) } " primitive." } ;
 
-HELP: normalize-pathname
+HELP: normalize-path
 { $values { "str" "a pathname string" } { "newstr" "a new pathname string" } }
 { $description "Called by words such as " { $link <file-reader> } " and " { $link <file-writer> } " to prepare a pathname before passing it to underlying code." } ;
 

core/io/files/files-tests.factor

@@ -220,8 +220,6 @@ io.encodings.utf8 ;
 
 [ "/usr/lib" ] [ "/usr" "lib" append-path ] unit-test
 [ "/usr/lib" ] [ "/usr/" "lib" append-path ] unit-test
-[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
-[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
 [ "/usr/lib" ] [ "/usr" "./lib" append-path ] unit-test
 [ "/usr/lib/" ] [ "/usr" "./lib/" append-path ] unit-test
 [ "/lib" ] [ "/usr" "../lib" append-path ] unit-test
@@ -239,9 +237,6 @@ io.encodings.utf8 ;
 [ "lib" ] [ "" "lib" append-path ] unit-test
 [ "lib" ] [ "" "./lib" append-path ] unit-test
 
-[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
-[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
-
 [ "foo/bar/." parent-directory ] must-fail
 [ "foo/bar/./" parent-directory ] must-fail
 [ "foo/bar/baz/.." parent-directory ] must-fail
@@ -263,5 +258,4 @@ io.encodings.utf8 ;
 [ "bar/foo" ] [ "bar/baz" "./../././././././///foo" append-path ] unit-test
 
 [ t ] [ "resource:core" absolute-path? ] unit-test
-[ t ] [ "/foo" absolute-path? ] unit-test
 [ f ] [ "" absolute-path? ] unit-test

core/io/files/files.factor

@@ -13,13 +13,13 @@ HOOK: (file-writer) io-backend ( path -- stream )
 HOOK: (file-appender) io-backend ( path -- stream )
 
 : <file-reader> ( path encoding -- stream )
-    swap normalize-pathname (file-reader) swap <decoder> ;
+    swap normalize-path (file-reader) swap <decoder> ;
 
 : <file-writer> ( path encoding -- stream )
-    swap normalize-pathname (file-writer) swap <encoder> ;
+    swap normalize-path (file-writer) swap <encoder> ;
 
 : <file-appender> ( path encoding -- stream )
-    swap normalize-pathname (file-appender) swap <encoder> ;
+    swap normalize-path (file-appender) swap <encoder> ;
 
 : file-lines ( path encoding -- seq )
     <file-reader> lines ;
@@ -43,9 +43,9 @@ HOOK: (file-appender) io-backend ( path -- stream )
     >r <file-appender> r> with-stream ; inline
 
 ! Pathnames
-: path-separator? ( ch -- ? ) windows? "/\\" "/" ? member? ;
+: path-separator? ( ch -- ? ) os windows? "/\\" "/" ? member? ;
 
-: path-separator ( -- string ) windows? "\\" "/" ? ;
+: path-separator ( -- string ) os windows? "\\" "/" ? ;
 
 : right-trim-separators ( str -- newstr )
     [ path-separator? ] right-trim ;
@@ -102,6 +102,7 @@ PRIVATE>
 
 : windows-absolute-path? ( path -- path ? )
     {
+        { [ dup "\\\\?\\" head? ] [ t ] }
         { [ dup length 2 < ] [ f ] }
         { [ dup second CHAR: : = ] [ t ] }
         { [ t ] [ f ] }
@@ -111,8 +112,8 @@ PRIVATE>
     {
         { [ dup empty? ] [ f ] }
         { [ dup "resource:" head? ] [ t ] }
+        { [ os windows? ] [ windows-absolute-path? ] }
         { [ dup first path-separator? ] [ t ] }
-        { [ windows? ] [ windows-absolute-path? ] }
         { [ t ] [ f ] }
     } cond nip ;
 
@@ -126,6 +127,9 @@ PRIVATE>
             2 tail left-trim-separators
             >r parent-directory r> append-path
         ] }
+        { [ over absolute-path? over first path-separator? and ] [
+            >r 2 head r> append
+        ] }
         { [ t ] [
             >r right-trim-separators "/" r>
             left-trim-separators 3append
@@ -167,7 +171,7 @@ SYMBOL: +unknown+
 
 ! File metadata
 : exists? ( path -- ? )
-    normalize-pathname (exists?) ;
+    normalize-path (exists?) ;
 
 : directory? ( path -- ? )
     file-info file-info-type +directory+ = ;
@@ -183,18 +187,33 @@ M: object cwd ( -- path ) "." ;
 
 [ cwd current-directory set-global ] "io.files" add-init-hook
 
+: resource-path ( path -- newpath )
+    "resource-path" get [ image parent-directory ] unless*
+    prepend-path ;
+
+: (normalize-path) ( path -- path' )
+    "resource:" ?head [
+        left-trim-separators resource-path
+        (normalize-path)
+    ] [
+        current-directory get prepend-path
+    ] if ;
+
+M: object normalize-path ( path -- path' )
+    (normalize-path) ;
+
 : with-directory ( path quot -- )
-    >r normalize-pathname r>
+    >r (normalize-path) r>
     current-directory swap with-variable ; inline
 
 : set-current-directory ( path -- )
-    normalize-pathname current-directory set ;
+    normalize-path current-directory set ;
 
 ! Creating directories
 HOOK: make-directory io-backend ( path -- )
 
 : make-directories ( path -- )
-    normalize-pathname right-trim-separators {
+    normalize-path right-trim-separators {
         { [ dup "." = ] [ ] }
         { [ dup root-directory? ] [ ] }
         { [ dup empty? ] [ ] }
@@ -267,7 +286,7 @@ M: object copy-file
 DEFER: copy-tree-into
 
 : copy-tree ( from to -- )
-    normalize-pathname
+    normalize-path
     over link-info type>>
     {
         { +symbolic-link+ [ copy-link ] }
@@ -286,9 +305,6 @@ DEFER: copy-tree-into
     [ copy-tree-into ] curry each ;
 
 ! Special paths
-: resource-path ( path -- newpath )
-    "resource-path" get [ image parent-directory ] unless*
-    prepend-path ;
 
 : temp-directory ( -- path )
     "temp" resource-path dup make-directories ;
@@ -296,14 +312,6 @@ DEFER: copy-tree-into
 : temp-file ( name -- path )
     temp-directory prepend-path ;
 
-M: object normalize-pathname ( path -- path' )
-    "resource:" ?head [
-        left-trim-separators resource-path
-        normalize-pathname
-    ] [
-        current-directory get prepend-path
-    ] if ;
-
 ! Pathname presentations
 TUPLE: pathname string ;
 
@@ -314,7 +322,7 @@ M: pathname <=> [ pathname-string ] compare ;
 ! Home directory
 : home ( -- dir )
     {
-        { [ winnt? ] [ "USERPROFILE" os-env ] }
+        { [ os winnt? ] [ "USERPROFILE" os-env ] }
-        { [ wince? ] [ "" resource-path ] }
+        { [ os wince? ] [ "" resource-path ] }
-        { [ unix? ] [ "HOME" os-env ] }
+        { [ os unix? ] [ "HOME" os-env ] }
     } cond ;

core/prettyprint/prettyprint.factor

@@ -7,7 +7,7 @@ vectors words prettyprint.backend prettyprint.sections
 prettyprint.config sorting splitting math.parser vocabs
 definitions effects classes.tuple io.files classes continuations
 hashtables classes.mixin classes.union classes.predicate
-combinators quotations ;
+classes.singleton combinators quotations ;
 
 : make-pprint ( obj quot -- block in use )
     [
@@ -254,6 +254,9 @@ M: predicate-class see-class*
     "predicate-definition" word-prop pprint-elements
     pprint-; block> block> ;
 
+M: singleton-class see-class* ( class -- )
+    \ SINGLETON: pprint-word pprint-word ;
+
 M: tuple-class see-class*
     <colon \ TUPLE: pprint-word
     dup pprint-word

core/syntax/syntax.factor

@@ -5,8 +5,8 @@ byte-vectors definitions generic hashtables kernel math
 namespaces parser sequences strings sbufs vectors words
 quotations io assocs splitting classes.tuple generic.standard
 generic.math classes io.files vocabs float-arrays float-vectors
-classes.union classes.mixin classes.predicate compiler.units
+classes.union classes.mixin classes.predicate classes.singleton
-combinators debugger ;
+compiler.units combinators debugger ;
 IN: bootstrap.syntax
 
 ! These words are defined as a top-level form, instead of with
@@ -55,7 +55,7 @@ IN: bootstrap.syntax
     "BIN:" [ 2 parse-base ] define-syntax
 
     "f" [ f parsed ] define-syntax
-    "t" "syntax" lookup define-symbol
+    "t" "syntax" lookup define-singleton-class
 
     "CHAR:" [
         scan {
@@ -154,6 +154,11 @@ IN: bootstrap.syntax
         parse-definition define-predicate-class
     ] define-syntax
 
+    "SINGLETON:" [
+        scan create-class-in
+        dup save-location define-singleton-class
+    ] define-syntax
+
     "TUPLE:" [
         parse-tuple-definition define-tuple-class
     ] define-syntax

core/system/system-docs.factor

@@ -1,20 +1,12 @@
 USING: generic help.markup help.syntax kernel math memory
-namespaces sequences kernel.private strings ;
+namespaces sequences kernel.private strings classes.singleton ;
 IN: system
 
-ARTICLE: "os" "System interface"
+ABOUT: "system"
-"Operating system detection:"
+
-{ $subsection os }
+ARTICLE: "system" "System interface"
-{ $subsection unix? }
+{ $subsection "cpu" }
-{ $subsection macosx? }
+{ $subsection "os" }
-{ $subsection solaris? }
-{ $subsection windows? }
-{ $subsection winnt? }
-{ $subsection win32? }
-{ $subsection win64? }
-{ $subsection wince? }
-"Processor detection:"
-{ $subsection cpu }
 "Reading environment variables:"
 { $subsection os-env }
 { $subsection os-envs }
@@ -27,63 +19,51 @@ ARTICLE: "os" "System interface"
 { $subsection exit }
 { $see-also "io.files" "io.mmap" "io.monitors" "network-streams" "io.launcher" } ;
 
-ABOUT: "os"
+ARTICLE: "cpu" "Processor Detection"
+"Processor detection:"
+{ $subsection cpu }
+"Supported processors:"
+{ $subsection x86.32 }
+{ $subsection x86.64 }
+{ $subsection ppc }
+{ $subsection arm }
+"Processor families:"
+{ $subsection x86 } ;
+
+ARTICLE: "os" "Operating System Detection"
+"Operating system detection:"
+{ $subsection os }
+"Supported operating systems:"
+{ $subsection freebsd }
+{ $subsection linux }
+{ $subsection macosx }
+{ $subsection openbsd }
+{ $subsection netbsd }
+{ $subsection solaris }
+{ $subsection wince }
+{ $subsection winnt }
+"Operating system families:"
+{ $subsection bsd }
+{ $subsection unix }
+{ $subsection windows } ;
+
 
 HELP: cpu
-{ $values { "cpu" string } }
+{ $values { "class" singleton-class } }
 { $description
-    "Outputs a string descriptor of the current CPU architecture. Currently, this set of descriptors is:"
+    "Outputs a singleton class with the name of the current CPU architecture."
-    { $code "x86.32" "x86.64" "ppc" "arm" }
 } ;
 
 HELP: os
-{ $values { "os" string } }
+{ $values { "class" singleton-class } }
 { $description
-    "Outputs a string descriptor of the current operating system family. Currently, this set of descriptors is:"
+    "Outputs a singleton class with the name of the current operating system family."
-    { $code
-        "freebsd"
-        "linux"
-        "macosx"
-        "openbsd"
-        "netbsd"
-        "solaris"
-        "wince"
-        "winnt"
-    }
 } ;
 
 HELP: embedded?
 { $values { "?" "a boolean" } }
 { $description "Tests if this Factor instance is embedded in another application." } ;
 
-HELP: windows?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows." } ;
-
-HELP: winnt?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows XP or Vista." } ;
-
-HELP: wince?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Windows CE." } ;
-
-HELP: macosx?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Mac OS X." } ;
-
-HELP: linux?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Linux." } ;
-
-HELP: solaris?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on Solaris." } ;
-
-HELP: bsd?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on FreeBSD/OpenBSD/NetBSD." } ;
-
 HELP: exit ( n -- )
 { $values { "n" "an integer exit code" } }
 { $description "Exits the Factor process." } ;
@@ -120,14 +100,6 @@ HELP: set-os-envs
 
 { os-env os-envs set-os-envs } related-words
 
-HELP: win32?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on 32-bit Windows." } ;
-
-HELP: win64?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on 64-bit Windows." } ;
-
 HELP: image
 { $values { "path" "a pathname string" } }
 { $description "Outputs the pathname of the currently running Factor image." } ;
@@ -135,7 +107,3 @@ HELP: image
 HELP: vm
 { $values { "path" "a pathname string" } }
 { $description "Outputs the pathname of the currently running Factor VM." } ;
-
-HELP: unix?
-{ $values { "?" "a boolean" } }
-{ $description "Tests if Factor is running on a Unix-like system. While this is a rather vague notion, one can use it to make certain assumptions about system calls and file structure which are not valid on Windows." } ;

core/system/system-tests.factor

@@ -1,11 +1,11 @@
 USING: math tools.test system prettyprint namespaces kernel ;
 IN: system.tests
 
-wince? [
+os wince? [
     [ ] [ os-envs . ] unit-test
 ] unless
 
-unix? [
+os unix? [
     [ ] [ os-envs "envs" set ] unit-test
     [ ] [ { { "A" "B" } } set-os-envs ] unit-test
     [ "B" ] [ "A" os-env ] unit-test

core/system/system.factor

@@ -2,49 +2,70 @@
 ! See http://factorcode.org/license.txt for BSD license.
 IN: system
 USING: kernel kernel.private sequences math namespaces
-splitting assocs system.private layouts ;
+init splitting assocs system.private layouts words ;
 
-: cpu ( -- cpu ) 8 getenv ; foldable
+SINGLETON: x86.32
+SINGLETON: x86.64
+SINGLETON: arm
+SINGLETON: ppc
 
-: os ( -- os ) 9 getenv ; foldable
+UNION: x86 x86.32 x86.64 ;
+
+: cpu ( -- class ) \ cpu get ;
+
+SINGLETON: winnt
+SINGLETON: wince
+
+UNION: windows winnt wince ;
+
+SINGLETON: freebsd
+SINGLETON: netbsd
+SINGLETON: openbsd
+SINGLETON: solaris
+SINGLETON: macosx
+SINGLETON: linux
+
+UNION: bsd freebsd netbsd openbsd macosx ;
+
+UNION: unix bsd solaris linux ;
+
+: os ( -- class ) \ os get ;
+
+<PRIVATE
+
+: string>cpu ( str -- class )
+    H{
+        { "x86.32" x86.32 }
+        { "x86.64" x86.64 }
+        { "arm" arm }
+        { "ppc" ppc }
+    } at ;
+
+: string>os ( str -- class )
+    H{
+        { "winnt" winnt }
+        { "wince" wince }
+        { "freebsd" freebsd }
+        { "netbsd" netbsd }
+        { "openbsd" openbsd }
+        { "solaris" solaris }
+        { "macosx" macosx }
+        { "linux" linux }
+    } at ;
+
+PRIVATE>
+
+[
+    8 getenv string>cpu \ cpu set-global
+    9 getenv string>os \ os set-global
+] "system" add-init-hook
 
 : image ( -- path ) 13 getenv ;
 
 : vm ( -- path ) 14 getenv ;
 
-: wince? ( -- ? )
-    os "wince" = ; foldable
-
-: winnt? ( -- ? )
-    os "winnt" = ; foldable
-
-: windows? ( -- ? )
-    wince? winnt? or ; foldable
-
-: win32? ( -- ? )
-    winnt? cell 4 = and ; foldable
-
-: win64? ( -- ? )
-    winnt? cell 8 = and ; foldable
-
-: macosx? ( -- ? ) os "macosx" = ; foldable
-
 : embedded? ( -- ? ) 15 getenv ;
 
-: unix? ( -- ? )
-    os {
-        "freebsd" "openbsd" "netbsd" "linux" "macosx" "solaris"
-    } member? ;
-
-: bsd? ( -- ? )
-    os { "freebsd" "openbsd" "netbsd" "macosx" } member? ;
-
-: linux? ( -- ? )
-    os "linux" = ;
-
-: solaris? ( -- ? )
-    os "solaris" = ;
-
 : os-envs ( -- assoc )
     (os-envs) [ "=" split1 ] H{ } map>assoc ;
 

extra/bootstrap/io/io.factor

@@ -5,8 +5,8 @@ IN: bootstrap.io
 "bootstrap.compiler" vocab [
     "io." {
         { [ "io-backend" get ] [ "io-backend" get ] }
-        { [ unix? ] [ "unix" ] }
+        { [ os unix? ] [ "unix" ] }
-        { [ winnt? ] [ "windows.nt" ] }
+        { [ os winnt? ] [ "windows.nt" ] }
-        { [ wince? ] [ "windows.ce" ] }
+        { [ os wince? ] [ "windows.ce" ] }
     } cond append require
 ] when

extra/bootstrap/random/random.factor

@@ -5,8 +5,8 @@ namespaces random ;
 "random.mersenne-twister" require
 
 {
-    { [ windows? ] [ "random.windows" require ] }
+    { [ os windows? ] [ "random.windows" require ] }
-    { [ unix? ] [ "random.unix" require ] }
+    { [ os unix? ] [ "random.unix" require ] }
 } cond
 
 ! [ [ 32 random-bits ] with-secure-random <mersenne-twister> random-generator set-global ]

extra/bootstrap/ui/ui.factor

@@ -4,9 +4,9 @@ vocabs vocabs.loader ;
 "bootstrap.compiler" vocab [
     "ui-backend" get [
         {
-            { [ macosx? ] [ "cocoa" ] }
+            { [ os macosx? ] [ "cocoa" ] }
-            { [ windows? ] [ "windows" ] }
+            { [ os windows? ] [ "windows" ] }
-            { [ unix? ] [ "x11" ] }
+            { [ os unix? ] [ "x11" ] }
         } cond
     ] unless* "ui." prepend require
 

extra/builder/builder.factor

@@ -245,4 +245,4 @@ USE: bootstrap.image.download
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-MAIN: build-loop
+MAIN: build-loop

extra/cairo/ffi/ffi.factor

@@ -7,16 +7,14 @@
 !  - most of the matrix stuff
 !  - most of the query functions
 
-
 USING: alien alien.syntax combinators system ;
-
 IN: cairo.ffi
 
 << "cairo" {
-        { [ win32? ] [ "libcairo-2.dll" ] }
+        { [ os winnt? ] [ "libcairo-2.dll" ] }
-        ! { [ macosx? ] [ "libcairo.dylib" ] }
+        ! { [ os macosx? ] [ "libcairo.dylib" ] }
-        { [ macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
+        { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
-        { [ unix? ] [ "libcairo.so.2" ] }
+        { [ os unix? ] [ "libcairo.so.2" ] }
   } cond "cdecl" add-library >>
 
 LIBRARY: cairo

extra/cairo/png/png.factor

@@ -24,7 +24,7 @@ ERROR: cairo-error string ;
     } cond ;
 
 : <png> ( path -- png )
-    normalize-pathname
+    normalize-path
     cairo_image_surface_create_from_png
     dup cairo_surface_status cairo-png-error
     dup [ cairo_image_surface_get_width check-zero ]

extra/calendar/backend/backend.factor

@@ -1,5 +1,4 @@
-USING: kernel ;
+USING: kernel system ;
 IN: calendar.backend
 
-SYMBOL: calendar-backend
+HOOK: gmt-offset os ( -- hours minutes seconds )
-HOOK: gmt-offset calendar-backend ( -- hours minutes seconds )

extra/calendar/calendar.factor

@@ -377,6 +377,6 @@ M: timestamp sleep-until timestamp>millis sleep-until ;
 M: duration sleep from-now sleep-until ;
 
 {
-    { [ unix? ] [ "calendar.unix" ] }
+    { [ os unix? ] [ "calendar.unix" ] }
-    { [ windows? ] [ "calendar.windows" ] }
+    { [ os windows? ] [ "calendar.windows" ] }
 } cond require

extra/calendar/unix/unix.factor

@@ -1,17 +1,12 @@
 USING: alien alien.c-types arrays calendar.backend
-kernel structs math unix.time namespaces ;
+kernel structs math unix.time namespaces system ;
-
 IN: calendar.unix
 
-TUPLE: unix-calendar ;
-
-T{ unix-calendar } calendar-backend set-global
-
 : get-time ( -- alien )
     f time <uint> localtime ;
 
 : timezone-name ( -- string )
     get-time tm-zone ;
 
-M: unix-calendar gmt-offset ( -- hours minutes seconds )
+M: unix gmt-offset ( -- hours minutes seconds )
     get-time tm-gmtoff 3600 /mod 60 /mod ;

extra/calendar/windows/windows.factor

@@ -1,12 +1,8 @@
-USING: calendar.backend namespaces alien.c-types
+USING: calendar.backend namespaces alien.c-types system
 windows windows.kernel32 kernel math combinators ;
 IN: calendar.windows
 
-TUPLE: windows-calendar ;
+M: windows gmt-offset ( -- hours minutes seconds )
-
-T{ windows-calendar } calendar-backend set-global
-
-M: windows-calendar gmt-offset ( -- hours minutes seconds )
     "TIME_ZONE_INFORMATION" <c-object>
     dup GetTimeZoneInformation {
         { [ dup TIME_ZONE_ID_INVALID = ] [ win32-error-string throw ] }

extra/combinators/cleave/cleave.factor

@@ -1,5 +1,5 @@
 
-USING: kernel sequences macros combinators ;
+USING: kernel arrays sequences macros combinators ;
 
 IN: combinators.cleave
 
@@ -21,6 +21,18 @@ MACRO: <2arr> ( seq -- )
   [ >quots ] [ length ] bi
  '[ , 2cleave , narray ] ;
 
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {1} ( x     -- {x}     ) 1array ; inline
+: {2} ( x y   -- {x,y}   ) 2array ; inline
+: {3} ( x y z -- {x,y,z} ) 3array ; inline
+
+: {n} narray ;
+
+: {bi}  ( x p q   -- {p(x),q(x)}      ) bi  {2} ; inline
+
+: {tri} ( x p q r -- {p(x),q(x),r(x)} ) tri {3} ; inline
+
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! Spread into array
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@@ -28,3 +40,8 @@ MACRO: <2arr> ( seq -- )
 MACRO: <arr*> ( seq -- )
   [ >quots ] [ length ] bi
  '[ , spread , narray ] ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: {bi*}  ( x y p q     -- {p(x),q(y)}      ) bi*  {2} ; inline
+: {tri*} ( x y z p q r -- {p(x),q(y),r(z)} ) tri* {3} ; inline

extra/concurrency/distributed/distributed-tests.factor

@@ -1,33 +1,33 @@
-IN: concurrency.distributed.tests
+IN: concurrency.distributed.tests
-USING: tools.test concurrency.distributed kernel io.files
+USING: tools.test concurrency.distributed kernel io.files
-arrays io.sockets system combinators threads math sequences
+arrays io.sockets system combinators threads math sequences
-concurrency.messaging continuations ;
+concurrency.messaging continuations ;
-
+
-: test-node
+: test-node
-    {
+    {
-        { [ unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
+        { [ os unix? ] [ "distributed-concurrency-test" temp-file <local> ] }
-        { [ windows? ] [ "127.0.0.1" 1238 <inet4> ] }
+        { [ os windows? ] [ "127.0.0.1" 1238 <inet4> ] }
-    } cond ;
+    } cond ;
-
+
-[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
+[ ] [ [ "distributed-concurrency-test" temp-file delete-file ] ignore-errors ] unit-test
-
+
-[ ] [ test-node dup 1array swap (start-node) ] unit-test
+[ ] [ test-node dup 1array swap (start-node) ] unit-test
-
+
-[ ] [ yield ] unit-test
+[ ] [ yield ] unit-test
-
+
-[ ] [
+[ ] [
-    [
+    [
-        receive first2 >r 3 + r> send
+        receive first2 >r 3 + r> send
-        "thread-a" unregister-process
+        "thread-a" unregister-process
-    ] "Thread A" spawn
+    ] "Thread A" spawn
-    "thread-a" swap register-process
+    "thread-a" swap register-process
-] unit-test
+] unit-test
-
+
-[ 8 ] [
+[ 8 ] [
-    5 self 2array
+    5 self 2array
-    "thread-a" test-node <remote-process> send
+    "thread-a" test-node <remote-process> send
-
+
-    receive
+    receive
-] unit-test
+] unit-test
-
+
-[ ] [ test-node stop-node ] unit-test
+[ ] [ test-node stop-node ] unit-test

extra/db/mysql/ffi/ffi.factor

@@ -6,9 +6,9 @@ USING: alien alien.syntax combinators kernel system ;
 IN: db.mysql.ffi
 
 << "mysql" {
-    { [ win32? ] [ "libmySQL.dll" "stdcall" ] }
+    { [ os winnt? ] [ "libmySQL.dll" "stdcall" ] }
-    { [ macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
+    { [ os macosx? ] [ "libmysqlclient.14.dylib" "cdecl" ] }
-    { [ unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
+    { [ os unix? ] [ "libmysqlclient.so.14" "cdecl" ] }
 } cond add-library >>
 
 LIBRARY: mysql

extra/db/postgresql/ffi/ffi.factor

@@ -5,9 +5,9 @@ USING: alien alien.syntax combinators system ;
 IN: db.postgresql.ffi
 
 << "postgresql" {
-    { [ win32? ]  [ "libpq.dll" ] }
+    { [ os winnt? ]  [ "libpq.dll" ] }
-    { [ macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
+    { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] }
-    { [ unix?  ]  [ "libpq.so" ] }
+    { [ os unix?  ]  [ "libpq.so" ] }
 } cond "cdecl" add-library >>
 
 ! ConnSatusType

extra/db/sqlite/ffi/ffi.factor

@@ -7,9 +7,9 @@ USING: alien compiler kernel math namespaces sequences strings alien.syntax
 IN: db.sqlite.ffi
 
 << "sqlite" {
-        { [ winnt? ]  [ "sqlite3.dll" ] }
+        { [ os winnt? ]  [ "sqlite3.dll" ] }
-        { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+        { [ os macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
-        { [ unix? ]  [ "libsqlite3.so" ] }
+        { [ os unix? ]  [ "libsqlite3.so" ] }
     } cond "cdecl" add-library >>
 
 ! Return values from sqlite functions

extra/db/types/types.factor

@@ -4,7 +4,7 @@ USING: arrays assocs db kernel math math.parser
 sequences continuations sequences.deep sequences.lib
 words namespaces tools.walker slots slots.private classes
 mirrors classes.tuple combinators calendar.format symbols
-singleton ;
+classes.singleton ;
 IN: db.types
 
 HOOK: modifier-table db ( -- hash )

extra/editors/editors.factor

@@ -26,7 +26,7 @@ SYMBOL: edit-hook
     require ;
 
 : edit-location ( file line -- )
-    >r normalize-pathname "\\\\?\\" ?head drop r>
+    >r (normalize-path) "\\\\?\\" ?head drop r>
     edit-hook get [ call ] [ no-edit-hook edit-location ] if* ;
 
 : edit ( defspec -- )

extra/editors/gvim/gvim.factor

@@ -13,6 +13,6 @@ t vim-detach set-global ! don't block the ui
 T{ gvim } vim-editor set-global
 
 {
-    { [ unix? ] [ "editors.gvim.unix" ] }
+    { [ os unix? ] [ "editors.gvim.unix" ] }
-    { [ windows? ] [ "editors.gvim.windows" ] }
+    { [ os windows? ] [ "editors.gvim.windows" ] }
 } cond require

extra/editors/gvim/unix/unix.factor

@@ -1,7 +1,8 @@
-USING: io.unix.backend kernel namespaces editors.gvim.backend ;
+USING: io.unix.backend kernel namespaces editors.gvim.backend
+system ;
 IN: editors.gvim.unix
 
-M: unix-io gvim-path
+M: unix gvim-path
     \ gvim-path get-global [
         "gvim"
     ] unless* ;

extra/editors/gvim/windows/windows.factor

@@ -1,8 +1,8 @@
 USING: editors.gvim.backend io.files io.windows kernel namespaces
-sequences windows.shell32 io.paths ;
+sequences windows.shell32 io.paths system ;
 IN: editors.gvim.windows
 
-M: windows-io gvim-path
+M: windows gvim-path
     \ gvim-path get-global [
         program-files "vim" append-path
         t [ "gvim.exe" tail? ] find-file

extra/editors/textwrangler/authors.txt

@@ -0,0 +1 @@
+Ben Schlingelhof

extra/editors/textwrangler/summary.txt

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

extra/editors/textwrangler/textwrangler.factor

@@ -0,0 +1,13 @@
+! Copyright (C) 2008 Ben Schlingelhof.
+! See http://factorcode.org/license.txt for BSD license.
+USING: definitions io.launcher kernel parser words sequences
+math math.parser namespaces editors ;
+IN: editors.textwrangler
+
+: tw ( file line -- )
+    [ "edit +" % # " " % % ] "" make run-process drop ;
+
+: tw-word ( word -- )
+    where first2 tw ;
+
+[ tw ] edit-hook set-global

extra/freetype/freetype.factor

@@ -4,8 +4,8 @@ USING: alien alien.syntax kernel system combinators ;
 IN: freetype
 
 << "freetype" {
-    { [ macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] }
+    { [ os macosx? ] [ "@executable_path/../Frameworks/libfreetype.6.dylib" "cdecl" add-library ] }
-    { [ windows? ] [ "freetype6.dll" "cdecl" add-library ] }
+    { [ os windows? ] [ "freetype6.dll" "cdecl" add-library ] }
     { [ t ] [ drop ] }
 } cond >>
 

extra/hardware-info/hardware-info.factor

@@ -6,11 +6,9 @@ IN: hardware-info
 : megs. ( x -- ) 20 2^ /f . ;
 : gigs. ( x -- ) 30 2^ /f . ;
 
-<<
+<< {
-{
+    { [ os windows? ] [ "hardware-info.windows" ] }
-    { [ windows? ] [ "hardware-info.windows" ] }
+    { [ os linux? ] [ "hardware-info.linux" ] }
-    { [ linux? ] [ "hardware-info.linux" ] }
+    { [ os macosx? ] [ "hardware-info.macosx" ] }
-    { [ macosx? ] [ "hardware-info.macosx" ] }
     { [ t ] [ f ] }
 } cond [ require ] when* >>
-

extra/hardware-info/windows/windows.factor

@@ -65,6 +65,6 @@ IN: hardware-info.windows
 
 <<
 {
-    { [ wince? ] [ "hardware-info.windows.ce" ] }
+    { [ os wince? ] [ "hardware-info.windows.ce" ] }
-    { [ winnt? ] [ "hardware-info.windows.nt" ] }
+    { [ os winnt? ] [ "hardware-info.windows.nt" ] }
 } cond [ require ] when* >>

extra/help/handbook/handbook.factor

@@ -261,7 +261,7 @@ ARTICLE: "handbook" "Factor documentation"
 { $subsection "collections" }
 { $subsection "io" }
 { $subsection "concurrency" }
-{ $subsection "os" }
+{ $subsection "system" }
 { $subsection "alien" }
 { $heading "Environment reference" }
 { $subsection "cli" }

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

@@ -1,42 +1,42 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
+! See http://factorcode.org/license.txt for BSD license.
-USING: db db.tuples db.types accessors
+USING: db db.tuples db.types accessors
-http.server.auth.providers kernel continuations
+http.server.auth.providers kernel continuations
-singleton ;
+classes.singleton ;
-IN: http.server.auth.providers.db
+IN: http.server.auth.providers.db
-
+
-user "USERS"
+user "USERS"
-{
+{
-    { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
+    { "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
-    { "realname" "REALNAME" { VARCHAR 256 } }
+    { "realname" "REALNAME" { VARCHAR 256 } }
-    { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
+    { "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
-    { "email" "EMAIL" { VARCHAR 256 } }
+    { "email" "EMAIL" { VARCHAR 256 } }
-    { "ticket" "TICKET" { VARCHAR 256 } }
+    { "ticket" "TICKET" { VARCHAR 256 } }
-    { "profile" "PROFILE" FACTOR-BLOB }
+    { "profile" "PROFILE" FACTOR-BLOB }
-} define-persistent
+} define-persistent
-
+
-: init-users-table user ensure-table ;
+: init-users-table user ensure-table ;
-
+
-SINGLETON: users-in-db
+SINGLETON: users-in-db
-
+
-: find-user ( username -- user )
+: find-user ( username -- user )
-    <user>
+    <user>
-        swap >>username
+        swap >>username
-    select-tuple ;
+    select-tuple ;
-
+
-M: users-in-db get-user
+M: users-in-db get-user
-    drop
+    drop
-    find-user ;
+    find-user ;
-
+
-M: users-in-db new-user
+M: users-in-db new-user
-    drop
+    drop
-    [
+    [
-        dup username>> find-user [
+        dup username>> find-user [
-            drop f
+            drop f
-        ] [
+        ] [
-            dup insert-tuple
+            dup insert-tuple
-        ] if
+        ] if
-    ] with-transaction ;
+    ] with-transaction ;
-
+
-M: users-in-db update-user
+M: users-in-db update-user
-    drop update-tuple ;
+    drop update-tuple ;

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

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

extra/io/files/unique/unique.factor

@@ -42,6 +42,6 @@ PRIVATE>
     [ with-directory ] curry keep delete-tree ; inline
 
 {
-    { [ unix? ] [ "io.unix.files.unique" ] }
+    { [ os unix? ] [ "io.unix.files.unique" ] }
-    { [ windows? ] [ "io.windows.files.unique" ] }
+    { [ os windows? ] [ "io.windows.files.unique" ] }
 } cond require

extra/io/sockets/impl/impl.factor

@@ -6,8 +6,8 @@ alien.c-types combinators namespaces alien parser ;
 IN: io.sockets.impl
 
 << {
-    { [ windows? ] [ "windows.winsock" ] }
+    { [ os windows? ] [ "windows.winsock" ] }
-    { [ unix? ] [ "unix" ] }
+    { [ os unix? ] [ "unix" ] }
 } cond use+ >>
 
 GENERIC: protocol-family ( addrspec -- af )

extra/io/sockets/sockets.factor

@@ -7,7 +7,7 @@ IN: io.sockets
 TUPLE: local path ;
 
 : <local> ( path -- addrspec )
-    normalize-pathname local construct-boa ;
+    normalize-path local construct-boa ;
 
 TUPLE: inet4 host port ;
 

extra/io/unix/backend/backend.factor

@@ -8,8 +8,6 @@ qualified namespaces io.timeouts io.encodings.utf8 accessors ;
 QUALIFIED: io
 IN: io.unix.backend
 
-MIXIN: unix-io
-
 ! I/O tasks
 TUPLE: io-task port callbacks ;
 
@@ -120,7 +118,7 @@ M: integer close-handle ( fd -- )
     [ dup reads>> handle-timeout ]
     [ dup writes>> handle-timeout ] 2bi ;
 
-M: unix-io cancel-io ( port -- )
+M: unix cancel-io ( port -- )
     mx get-global cancel-io-tasks ;
 
 ! Readers
@@ -180,10 +178,10 @@ M: write-task do-io-task
 M: port port-flush ( port -- )
     dup buffer-empty? [ drop ] [ (wait-to-write) ] if ;
 
-M: unix-io io-multiplex ( ms/f -- )
+M: unix io-multiplex ( ms/f -- )
     mx get-global wait-for-events ;
 
-M: unix-io (init-stdio) ( -- )
+M: unix (init-stdio) ( -- )
     0 <reader>
     1 <writer>
     2 <writer> ;

extra/io/unix/bsd/bsd.factor

@@ -3,7 +3,7 @@
 IN: io.unix.bsd
 USING: io.backend io.unix.backend io.unix.kqueue io.unix.select
 io.launcher io.unix.launcher namespaces kernel assocs
-threads continuations ;
+threads continuations system ;
 
 ! On Mac OS X, we use select() for the top-level
 ! multiplexer, and we hang a kqueue off of it for process exit
@@ -12,16 +12,12 @@ threads continuations ;
 ! kqueue is buggy with files and ptys so we can't use it as the
 ! main multiplexer.
 
-MIXIN: bsd-io
+M: bsd init-io ( -- )
-
-INSTANCE: bsd-io unix-io
-
-M: bsd-io init-io ( -- )
     <select-mx> mx set-global
     <kqueue-mx> kqueue-mx set-global
     kqueue-mx get-global <mx-port> <mx-task> dup io-task-fd
     2dup mx get-global mx-reads set-at
     mx get-global mx-writes set-at ;
 
-M: bsd-io register-process ( process -- )
+M: bsd register-process ( process -- )
     process-handle kqueue-mx get-global add-pid-task ;

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

@@ -21,3 +21,9 @@ IN: io.unix.files.tests
 [ "/lib/" ] [ "/" "../lib/" append-path ] unit-test
 [ "/lib" ] [ "/" "../../lib" append-path ] unit-test
 [ "/lib/" ] [ "/" "../../lib/" append-path ] unit-test
+
+[ "/lib" ] [ "/usr/" "/lib" append-path ] unit-test
+[ "/lib/" ] [ "/usr/" "/lib/" append-path ] unit-test
+[ "/lib/bux" ] [ "/usr" "/lib/bux" append-path ] unit-test
+[ "/lib/bux/" ] [ "/usr" "/lib/bux/" append-path ] unit-test
+[ t ] [ "/foo" absolute-path? ] unit-test

extra/io/unix/files/files.factor

@@ -3,15 +3,15 @@
 USING: io.backend io.nonblocking io.unix.backend io.files io
 unix unix.stat unix.time kernel math continuations
 math.bitfields byte-arrays alien combinators calendar
-io.encodings.binary accessors sequences strings ;
+io.encodings.binary accessors sequences strings system ;
 
 IN: io.unix.files
 
-M: unix-io cwd ( -- path )
+M: unix cwd ( -- path )
     MAXPATHLEN [ <byte-array> ] [ ] bi getcwd
     [ (io-error) ] unless* ;
 
-M: unix-io cd ( path -- )
+M: unix cd ( path -- )
     chdir io-error ;
 
 : read-flags O_RDONLY ; inline
@@ -19,7 +19,7 @@ M: unix-io cd ( path -- )
 : open-read ( path -- fd )
     O_RDONLY file-mode open dup io-error ;
 
-M: unix-io (file-reader) ( path -- stream )
+M: unix (file-reader) ( path -- stream )
     open-read <reader> ;
 
 : write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline
@@ -27,7 +27,7 @@ M: unix-io (file-reader) ( path -- stream )
 : open-write ( path -- fd )
     write-flags file-mode open dup io-error ;
 
-M: unix-io (file-writer) ( path -- stream )
+M: unix (file-writer) ( path -- stream )
     open-write <writer> ;
 
 : append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline
@@ -36,29 +36,29 @@ M: unix-io (file-writer) ( path -- stream )
     append-flags file-mode open dup io-error
     [ dup 0 SEEK_END lseek io-error ] [ ] [ close ] cleanup ;
 
-M: unix-io (file-appender) ( path -- stream )
+M: unix (file-appender) ( path -- stream )
     open-append <writer> ;
 
 : touch-mode ( -- n )
     { O_WRONLY O_APPEND O_CREAT O_EXCL } flags ; foldable
 
-M: unix-io touch-file ( path -- )
+M: unix touch-file ( path -- )
-    normalize-pathname
+    normalize-path
     touch-mode file-mode open
     dup 0 < [ err_no EEXIST = [ err_no io-error ] unless ] when
     close ;
 
-M: unix-io move-file ( from to -- )
+M: unix move-file ( from to -- )
-    [ normalize-pathname ] bi@ rename io-error ;
+    [ normalize-path ] bi@ rename io-error ;
 
-M: unix-io delete-file ( path -- )
+M: unix delete-file ( path -- )
-    normalize-pathname unlink io-error ;
+    normalize-path unlink io-error ;
 
-M: unix-io make-directory ( path -- )
+M: unix make-directory ( path -- )
-    normalize-pathname OCT: 777 mkdir io-error ;
+    normalize-path OCT: 777 mkdir io-error ;
 
-M: unix-io delete-directory ( path -- )
+M: unix delete-directory ( path -- )
-    normalize-pathname rmdir io-error ;
+    normalize-path rmdir io-error ;
 
 : (copy-file) ( from to -- )
     dup parent-directory make-directories
@@ -68,8 +68,8 @@ M: unix-io delete-directory ( path -- )
         ] with-disposal
     ] with-disposal ;
 
-M: unix-io copy-file ( from to -- )
+M: unix copy-file ( from to -- )
-    [ normalize-pathname ] bi@
+    [ normalize-path ] bi@
     [ (copy-file) ]
     [ swap file-info file-info-permissions chmod io-error ]
     2bi ;
@@ -95,16 +95,16 @@ M: unix-io copy-file ( from to -- )
     } cleave
     \ file-info construct-boa ;
 
-M: unix-io file-info ( path -- info )
+M: unix file-info ( path -- info )
-    normalize-pathname stat* stat>file-info ;
+    normalize-path stat* stat>file-info ;
 
-M: unix-io link-info ( path -- info )
+M: unix link-info ( path -- info )
-    normalize-pathname lstat* stat>file-info ;
+    normalize-path lstat* stat>file-info ;
 
-M: unix-io make-link ( path1 path2 -- )
+M: unix make-link ( path1 path2 -- )
-    normalize-pathname symlink io-error ;
+    normalize-path symlink io-error ;
 
-M: unix-io read-link ( path -- path' )
+M: unix read-link ( path -- path' )
-    normalize-pathname
+    normalize-path
     PATH_MAX [ <byte-array> tuck ] [ ] bi readlink
     dup io-error head-slice >string ;

extra/io/unix/files/unique/unique.factor

@@ -1,11 +1,11 @@
 USING: kernel io.nonblocking io.unix.backend math.bitfields
-unix io.files.unique.backend ;
+unix io.files.unique.backend system ;
 IN: io.unix.files.unique
 
 : open-unique-flags ( -- flags )
     { O_RDWR O_CREAT O_EXCL } flags ;
 
-M: unix-io (make-unique-file) ( path -- )
+M: unix (make-unique-file) ( path -- )
     open-unique-flags file-mode open dup io-error close ;
 
-M: unix-io temporary-path ( -- path ) "/tmp" ;
+M: unix temporary-path ( -- path ) "/tmp" ;

extra/io/unix/freebsd/freebsd.factor

@@ -1,8 +1,3 @@
-IN: io.unix.freebsd
+USING: io.unix.bsd io.backend system ;
-USING: io.unix.bsd io.backend ;
 
-TUPLE: freebsd-io ;
+freebsd set-io-backend
-
-INSTANCE: freebsd-io bsd-io
-
-T{ freebsd-io } set-io-backend

extra/io/unix/launcher/launcher.factor

@@ -37,7 +37,7 @@ USE: unix
     2nip reset-fd ;
 
 : redirect-file ( obj mode fd -- )
-    >r >r normalize-pathname r> file-mode
+    >r >r normalize-path r> file-mode
     open dup io-error r> redirect-fd ;
 
 : redirect-closed ( obj mode fd -- )
@@ -79,12 +79,12 @@ USE: unix
         (io-error)
     ] [ 255 exit ] recover ;
 
-M: unix-io current-process-handle ( -- handle ) getpid ;
+M: unix current-process-handle ( -- handle ) getpid ;
 
-M: unix-io run-process* ( process -- pid )
+M: unix run-process* ( process -- pid )
     [ spawn-process ] curry [ ] with-fork ;
 
-M: unix-io kill-process* ( pid -- )
+M: unix kill-process* ( pid -- )
     SIGTERM kill io-error ;
 
 : open-pipe ( -- pair )
@@ -95,7 +95,7 @@ M: unix-io kill-process* ( pid -- )
     2dup first close second close
     >r first 0 dup2 drop r> second 1 dup2 drop ;
 
-M: unix-io (process-stream)
+M: unix (process-stream)
     >r open-pipe open-pipe r>
     [ >r setup-stdio-pipe r> spawn-process ] curry
     [ -rot 2dup second close first close ]

extra/io/unix/linux/linux.factor

@@ -4,13 +4,9 @@ USING: kernel io.backend io.monitors io.monitors.private
 io.files io.buffers io.nonblocking io.timeouts io.unix.backend
 io.unix.select io.unix.launcher unix.linux.inotify assocs
 namespaces threads continuations init math alien.c-types alien
-vocabs.loader accessors ;
+vocabs.loader accessors system ;
 IN: io.unix.linux
 
-TUPLE: linux-io ;
-
-INSTANCE: linux-io unix-io
-
 TUPLE: linux-monitor ;
 
 : <linux-monitor> ( wd -- monitor )
@@ -52,7 +48,7 @@ TUPLE: inotify watches ;
         "inotify is not supported by this Linux release" throw
     ] unless ;
 
-M: linux-io <monitor> ( path recursive? -- monitor )
+M: linux <monitor> ( path recursive? -- monitor )
     check-inotify
     drop IN_CHANGE_EVENTS add-watch ;
 
@@ -121,11 +117,11 @@ TUPLE: inotify-task ;
 M: inotify-task do-io-task ( task -- )
     io-task-port read-notifications f ;
 
-M: linux-io init-io ( -- )
+M: linux init-io ( -- )
     <select-mx>
     [ mx set-global ]
     [ init-inotify ] bi ;
 
-T{ linux-io } set-io-backend
+linux set-io-backend
 
 [ start-wait-thread ] "io.unix.linux" add-init-hook

extra/io/unix/macosx/macosx.factor

@@ -1,13 +1,9 @@
-IN: io.unix.macosx
 USING: io.unix.bsd io.backend io.monitors io.monitors.private
 continuations kernel core-foundation.fsevents sequences
-namespaces arrays ;
+namespaces arrays system ;
+IN: io.unix.macosx
 
-TUPLE: macosx-io ;
+macosx set-io-backend
-
-INSTANCE: macosx-io bsd-io
-
-T{ macosx-io } set-io-backend
 
 TUPLE: macosx-monitor ;
 
@@ -16,7 +12,7 @@ TUPLE: macosx-monitor ;
     [ [ first { +modify-file+ } swap changed-file ] each ] bind
     notify-callback ;
 
-M: macosx-io <monitor>
+M: macosx <monitor>
     drop
     f macosx-monitor construct-simple-monitor
     dup [ enqueue-notifications ] curry

extra/io/unix/mmap/mmap.factor

@@ -10,12 +10,12 @@ IN: io.unix.mmap
     >r f -roll r> open-r/w [ 0 mmap ] keep
     over MAP_FAILED = [ close (io-error) ] when ;
 
-M: unix-io <mapped-file> ( path length -- obj )
+M: unix <mapped-file> ( path length -- obj )
     swap >r
     dup PROT_READ PROT_WRITE bitor MAP_FILE MAP_SHARED bitor
     r> mmap-open f mapped-file construct-boa ;
 
-M: unix-io close-mapped-file ( mmap -- )
+M: unix close-mapped-file ( mmap -- )
     [ mapped-file-address ] keep
     [ mapped-file-length munmap ] keep
     mapped-file-handle close

extra/io/unix/netbsd/netbsd.factor

@@ -1,8 +1,3 @@
-IN: io.unix.netbsd
+USING: io.backend system ;
-USING: io.unix.bsd io.backend ;
 
-TUPLE: netbsd-io ;
+netbsd set-io-backend
-
-INSTANCE: netbsd-io bsd-io
-
-T{ netbsd-io } set-io-backend

extra/io/unix/openbsd/openbsd.factor

@@ -1,8 +1,3 @@
-IN: io.unix.openbsd
+USING: io.unix.bsd io.backend core-foundation.fsevents system ;
-USING: io.unix.bsd io.backend core-foundation.fsevents ;
 
-TUPLE: openbsd-io ;
+openbsd set-io-backend
-
-INSTANCE: openbsd-io bsd-io
-
-T{ openbsd-io } set-io-backend

extra/io/unix/sockets/sockets.factor

@@ -7,7 +7,7 @@ USING: alien alien.c-types generic io kernel math namespaces
 io.nonblocking parser threads unix sequences
 byte-arrays io.sockets io.binary io.unix.backend
 io.streams.duplex io.sockets.impl math.parser continuations libc
-combinators io.backend io.files ;
+combinators io.backend io.files system ;
 IN: io.unix.sockets
 
 : pending-init-error ( port -- )
@@ -23,7 +23,7 @@ IN: io.unix.sockets
 : sockopt ( fd level opt -- )
     1 <int> "int" heap-size setsockopt io-error ;
 
-M: unix-io addrinfo-error ( n -- )
+M: unix addrinfo-error ( n -- )
     dup zero? [ drop ] [ gai_strerror throw ] if ;
 
 ! Client sockets - TCP and Unix domain
@@ -42,7 +42,7 @@ M: connect-task do-io-task
 : wait-to-connect ( port -- )
     [ <connect-task> add-io-task ] with-port-continuation drop ;
 
-M: unix-io (client) ( addrspec -- client-in client-out )
+M: unix (client) ( addrspec -- client-in client-out )
     dup make-sockaddr/size >r >r
     protocol-family SOCK_STREAM socket-fd
     dup r> r> connect
@@ -91,11 +91,11 @@ USE: io.sockets
     dup rot make-sockaddr/size bind
     zero? [ dup close (io-error) ] unless ;
 
-M: unix-io (server) ( addrspec -- handle )
+M: unix (server) ( addrspec -- handle )
     SOCK_STREAM server-fd
     dup 10 listen zero? [ dup close (io-error) ] unless ;
 
-M: unix-io (accept) ( server -- addrspec handle )
+M: unix (accept) ( server -- addrspec handle )
     #! Wait for a client connection.
     dup check-server-port
     dup wait-to-accept
@@ -104,7 +104,7 @@ M: unix-io (accept) ( server -- addrspec handle )
     swap server-port-client ;
 
 ! Datagram sockets - UDP and Unix domain
-M: unix-io <datagram>
+M: unix <datagram>
     [ SOCK_DGRAM server-fd ] keep <datagram-port> ;
 
 SYMBOL: receive-buffer
@@ -147,7 +147,7 @@ M: receive-task do-io-task
 : wait-receive ( stream -- )
     [ <receive-task> add-io-task ] with-port-continuation drop ;
 
-M: unix-io receive ( datagram -- packet addrspec )
+M: unix receive ( datagram -- packet addrspec )
     dup check-datagram-port
     dup wait-receive
     dup pending-error
@@ -179,7 +179,7 @@ M: send-task do-io-task
     [ <send-task> add-io-task ] with-port-continuation
     2drop 2drop ;
 
-M: unix-io send ( packet addrspec datagram -- )
+M: unix send ( packet addrspec datagram -- )
     3dup check-datagram-send
     [ >r make-sockaddr/size r> wait-send ] keep
     pending-error ;

extra/io/unix/unix.factor

@@ -1,5 +1,5 @@
 USING: io.unix.backend io.unix.files io.unix.sockets io.timeouts
 io.unix.launcher io.unix.mmap io.backend combinators namespaces
-system vocabs.loader sequences ;
+system vocabs.loader sequences words ;
 
-"io.unix." os append require
+"io.unix." os word-name append require

extra/io/windows/ce/backend/backend.factor

@@ -7,10 +7,10 @@ IN: io.windows.ce.backend
 : port-errored ( port -- )
     win32-error-string swap set-port-error ;
 
-M: windows-ce-io io-multiplex ( ms -- )
+M: wince io-multiplex ( ms -- )
     60 60 * 1000 * or (sleep) ;
 
-M: windows-ce-io add-completion ( handle -- ) drop ;
+M: wince add-completion ( handle -- ) drop ;
 
 GENERIC: wince-read ( port port-handle -- )
 
@@ -26,18 +26,18 @@ M: port port-flush
         dup dup port-handle wince-write port-flush
     ] if ;
 
-M: windows-ce-io init-io ( -- )
+M: wince init-io ( -- )
     init-winsock ;
 
 LIBRARY: libc
 FUNCTION: void* _getstdfilex int fd ;
 FUNCTION: void* _fileno void* file ;
 
-M: windows-ce-io (init-stdio) ( -- )
+M: wince (init-stdio) ( -- )
     #! We support Windows NT too, to make this I/O backend
     #! easier to debug.
     512 default-buffer-size [
-        winnt? [
+        os winnt? [
             STD_INPUT_HANDLE GetStdHandle
             STD_OUTPUT_HANDLE GetStdHandle
             STD_ERROR_HANDLE GetStdHandle

extra/io/windows/ce/ce.factor

@@ -1,7 +1,11 @@
-USING: io.backend io.windows io.windows.ce.backend
+USE: io.backend
-io.windows.ce.files io.windows.ce.sockets io.windows.ce.launcher
+USE: io.windows
-namespaces io.windows.mmap ;
+USE: io.windows.ce.backend
-IN: io.windows.ce
+USE: io.windows.ce.files
-
+USE: io.windows.ce.sockets
+USE: io.windows.ce.launcher
+USE: io.windows.mmap system
 USE: io.windows.files
-T{ windows-ce-io } set-io-backend
+USE: system
+
+wince set-io-backend

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

@@ -1,15 +1,15 @@
 USING: alien alien.c-types combinators io io.backend io.buffers
 io.files io.nonblocking io.windows kernel libc math namespaces
 prettyprint sequences strings threads threads.private
-windows windows.kernel32 io.windows.ce.backend ;
+windows windows.kernel32 io.windows.ce.backend system ;
 IN: windows.ce.files
 
-! M: windows-ce-io normalize-pathname ( string -- string )
+! M: wince normalize-path ( string -- string )
     ! dup 1 tail* CHAR: \\ = [ "*" append ] [ "\\*" append ] if ;
 
-M: windows-ce-io CreateFile-flags ( DWORD -- DWORD )
+M: wince CreateFile-flags ( DWORD -- DWORD )
     FILE_ATTRIBUTE_NORMAL bitor ;
-M: windows-ce-io FileArgs-overlapped ( port -- f ) drop f ;
+M: wince FileArgs-overlapped ( port -- f ) drop f ;
 
 : finish-read ( port status bytes-ret -- )
     swap [ drop port-errored ] [ swap n>buffer ] if ;

extra/io/windows/ce/sockets/sockets.factor

@@ -2,11 +2,11 @@ USING: alien alien.c-types combinators io io.backend io.buffers
 io.nonblocking io.sockets io.sockets.impl io.windows kernel libc
 math namespaces prettyprint qualified sequences strings threads
 threads.private windows windows.kernel32 io.windows.ce.backend
-byte-arrays ;
+byte-arrays system ;
 QUALIFIED: windows.winsock
 IN: io.windows.ce
 
-M: windows-ce-io WSASocket-flags ( -- DWORD ) 0 ;
+M: wince WSASocket-flags ( -- DWORD ) 0 ;
 
 M: win32-socket wince-read ( port port-handle -- )
     win32-file-handle over buffer-end pick buffer-capacity 0
@@ -31,15 +31,15 @@ M: win32-socket wince-write ( port port-handle -- )
     windows.winsock:WSAConnect
     windows.winsock:winsock-error!=0/f ;
 
-M: windows-ce-io (client) ( addrspec -- reader writer )
+M: wince (client) ( addrspec -- reader writer )
     do-connect <win32-socket> dup <reader&writer> ;
 
-M: windows-ce-io (server) ( addrspec -- handle )
+M: wince (server) ( addrspec -- handle )
     windows.winsock:SOCK_STREAM server-fd
     dup listen-on-socket
     <win32-socket> ;
 
-M: windows-ce-io (accept) ( server -- client )
+M: wince (accept) ( server -- client )
     [
         dup check-server-port
         [
@@ -55,7 +55,7 @@ M: windows-ce-io (accept) ( server -- client )
         <win32-socket> <reader&writer>
     ] with-timeout ;
 
-M: windows-ce-io <datagram> ( addrspec -- datagram )
+M: wince <datagram> ( addrspec -- datagram )
     [
         windows.winsock:SOCK_DGRAM server-fd <win32-socket>
     ] keep <datagram-port> ;
@@ -81,7 +81,7 @@ M: windows-ce-io <datagram> ( addrspec -- datagram )
 
 packet-size <byte-array> receive-buffer set-global
 
-M: windows-ce-io receive ( datagram -- packet addrspec )
+M: wince receive ( datagram -- packet addrspec )
     dup check-datagram-port
     [
         port-handle win32-file-handle
@@ -104,7 +104,7 @@ M: windows-ce-io receive ( datagram -- packet addrspec )
     dup length receive-buffer rot pick memcpy
     receive-buffer make-WSABUF ;
 
-M: windows-ce-io send ( packet addrspec datagram -- )
+M: wince send ( packet addrspec datagram -- )
     3dup check-datagram-send
     port-handle win32-file-handle
     rot send-WSABUF

extra/io/windows/files/files.factor

@@ -3,7 +3,7 @@
 USING: alien.c-types io.backend io.files io.windows kernel math
 windows windows.kernel32 windows.time calendar combinators
 math.functions sequences namespaces words symbols
-combinators.lib io.nonblocking destructors ;
+combinators.lib io.nonblocking destructors system ;
 IN: io.windows.files
 
 SYMBOLS: +read-only+ +hidden+ +system+
@@ -88,15 +88,15 @@ SYMBOLS: +read-only+ +hidden+ +system+
         get-file-information BY_HANDLE_FILE_INFORMATION>file-info
     ] if ;
 
-M: windows-nt-io file-info ( path -- info )
+M: winnt file-info ( path -- info )
-    normalize-pathname get-file-information-stat ;
+    normalize-path get-file-information-stat ;
 
-M: windows-nt-io link-info ( path -- info )
+M: winnt link-info ( path -- info )
     file-info ;
 
 : file-times ( path -- timestamp timestamp timestamp )
     [
-        normalize-pathname open-existing dup close-always
+        normalize-path open-existing dup close-always
         "FILETIME" <c-object>
         "FILETIME" <c-object>
         "FILETIME" <c-object>
@@ -112,7 +112,7 @@ M: windows-nt-io link-info ( path -- info )
     #! timestamp order: creation access write
     [
         >r >r >r
-            normalize-pathname open-existing dup close-always
+            normalize-path open-existing dup close-always
         r> r> r> (set-file-times)
     ] with-destructors ;
 
@@ -125,9 +125,9 @@ M: windows-nt-io link-info ( path -- info )
 : set-file-write-time ( path timestamp -- )
     >r f f r> set-file-times ;
 
-M: windows-nt-io touch-file ( path -- )
+M: winnt touch-file ( path -- )
     [
-        normalize-pathname
+        normalize-path
         maybe-create-file over close-always
         [ drop ] [ f now dup (set-file-times) ] if
     ] with-destructors ;

extra/io/windows/files/unique/unique.factor

@@ -2,9 +2,9 @@ USING: kernel system io.files.unique.backend
 windows.kernel32 io.windows io.nonblocking windows ;
 IN: io.windows.files.unique
 
-M: windows-io (make-unique-file) ( path -- )
+M: windows (make-unique-file) ( path -- )
     GENERIC_WRITE CREATE_NEW 0 open-file
     CloseHandle win32-error=0/f ;
 
-M: windows-io temporary-path ( -- path )
+M: windows temporary-path ( -- path )
     "TEMP" os-env ;

extra/io/windows/launcher/launcher.factor

@@ -28,7 +28,7 @@ TUPLE: CreateProcess-args
     "PROCESS_INFORMATION" <c-object> >>lpProcessInformation
     TRUE >>bInheritHandles
     0 >>dwCreateFlags
-    current-directory get normalize-pathname >>lpCurrentDirectory ;
+    current-directory get (normalize-path) >>lpCurrentDirectory ;
 
 : call-CreateProcess ( CreateProcess-args -- )
     {
@@ -82,7 +82,7 @@ TUPLE: CreateProcess-args
 : fill-dwCreateFlags ( process args -- process args )
     0
     pick pass-environment? [ CREATE_UNICODE_ENVIRONMENT bitor ] when
-    pick detached>> winnt? and [ DETACHED_PROCESS bitor ] when
+    pick detached>> os winnt? and [ DETACHED_PROCESS bitor ] when
     pick lookup-priority [ bitor ] when*
     >>dwCreateFlags ;
 
@@ -101,20 +101,20 @@ TUPLE: CreateProcess-args
 
 HOOK: fill-redirection io-backend ( process args -- )
 
-M: windows-ce-io fill-redirection 2drop ;
+M: wince fill-redirection 2drop ;
 
 : make-CreateProcess-args ( process -- args )
     default-CreateProcess-args
-    wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
+    os wince? [ fill-lpApplicationName ] [ fill-lpCommandLine ] if
     fill-dwCreateFlags
     fill-lpEnvironment
     fill-startup-info
     nip ;
 
-M: windows-io current-process-handle ( -- handle )
+M: windows current-process-handle ( -- handle )
     GetCurrentProcessId ;
 
-M: windows-io run-process* ( process -- handle )
+M: windows run-process* ( process -- handle )
     [
         dup make-CreateProcess-args
         tuck fill-redirection
@@ -122,7 +122,7 @@ M: windows-io run-process* ( process -- handle )
         lpProcessInformation>>
     ] with-destructors ;
 
-M: windows-io kill-process* ( handle -- )
+M: windows kill-process* ( handle -- )
     PROCESS_INFORMATION-hProcess
     255 TerminateProcess win32-error=0/f ;
 
@@ -161,7 +161,7 @@ SYMBOL: wait-flag
     <flag> wait-flag set-global
     [ wait-loop t ] "Process wait" spawn-server drop ;
 
-M: windows-io register-process
+M: windows register-process
     drop wait-flag get-global raise-flag ;
 
 [ start-wait-thread ] "io.windows.launcher" add-init-hook

extra/io/windows/mmap/mmap.factor

@@ -1,7 +1,7 @@
 USING: alien alien.c-types alien.syntax arrays continuations
 destructors generic io.mmap io.nonblocking io.windows
 kernel libc math namespaces quotations sequences windows
-windows.advapi32 windows.kernel32 io.backend ;
+windows.advapi32 windows.kernel32 io.backend system ;
 IN: io.windows.mmap
 
 TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
@@ -53,11 +53,11 @@ TYPEDEF: TOKEN_PRIVILEGES* PTOKEN_PRIVILEGES
 
 HOOK: with-privileges io-backend ( seq quot -- ) inline
 
-M: windows-nt-io with-privileges
+M: winnt with-privileges
     over [ [ t set-privilege ] each ] curry compose
     swap [ [ f set-privilege ] each ] curry [ ] cleanup ;
 
-M: windows-ce-io with-privileges
+M: wince with-privileges
     nip call ;
 
 : mmap-open ( path access-mode create-mode flProtect access -- handle handle address )
@@ -70,7 +70,7 @@ M: windows-ce-io with-privileges
         dup close-later
     ] with-privileges ;
     
-M: windows-io <mapped-file> ( path length -- mmap )
+M: windows <mapped-file> ( path length -- mmap )
     [
         swap
         GENERIC_WRITE GENERIC_READ bitor
@@ -81,7 +81,7 @@ M: windows-io <mapped-file> ( path length -- mmap )
         f \ mapped-file construct-boa
     ] with-destructors ;
 
-M: windows-io close-mapped-file ( mapped-file -- )
+M: windows close-mapped-file ( mapped-file -- )
     [
         dup mapped-file-handle [ close-always ] each
         mapped-file-address UnmapViewOfFile win32-error=0/f

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

@@ -3,7 +3,7 @@ continuations destructors io io.backend io.nonblocking
 io.windows libc kernel math namespaces sequences
 threads classes.tuple.lib windows windows.errors
 windows.kernel32 strings splitting io.files qualified ascii
-combinators.lib ;
+combinators.lib system ;
 QUALIFIED: windows.winsock
 IN: io.windows.nt.backend
 
@@ -28,7 +28,7 @@ SYMBOL: master-completion-port
 : <master-completion-port> ( -- handle )
     INVALID_HANDLE_VALUE f <completion-port> ;
 
-M: windows-nt-io add-completion ( handle -- )
+M: winnt add-completion ( handle -- )
     master-completion-port get-global <completion-port> drop ;
 
 : eof? ( error -- ? )
@@ -89,13 +89,13 @@ M: windows-nt-io add-completion ( handle -- )
 : drain-overlapped ( timeout -- )
     handle-overlapped [ 0 drain-overlapped ] unless ;
 
-M: windows-nt-io cancel-io
+M: winnt cancel-io
     port-handle win32-file-handle CancelIo drop ;
 
-M: windows-nt-io io-multiplex ( ms -- )
+M: winnt io-multiplex ( ms -- )
     drain-overlapped ;
 
-M: windows-nt-io init-io ( -- )
+M: winnt init-io ( -- )
     <master-completion-port> master-completion-port set-global
     H{ } clone io-hash set-global
     windows.winsock:init-winsock ;

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

@@ -1,9 +1,9 @@
 USING: io.files kernel tools.test io.backend
-io.windows.nt.files splitting ;
+io.windows.nt.files splitting sequences ;
 IN: io.windows.nt.files.tests
 
-[ t ] [ "\\foo" absolute-path? ] unit-test
+[ f ] [ "\\foo" absolute-path? ] unit-test
-[ t ] [ "\\\\?\\foo" absolute-path? ] unit-test
+[ t ] [ "\\\\?\\c:\\foo" absolute-path? ] unit-test
 [ t ] [ "c:\\foo" absolute-path? ] unit-test
 [ t ] [ "c:" absolute-path? ] unit-test
 
@@ -29,19 +29,22 @@ IN: io.windows.nt.files.tests
 
 [ ] [ "" resource-path cd ] unit-test
 
-[ "\\foo\\bar" ] [ "/foo/bar" normalize-pathname ":" split1 nip ] unit-test
+[ "\\foo\\bar" ] [ "/foo/bar" normalize-path ":" split1 nip ] unit-test
 
 [ "\\\\?\\C:\\builds\\factor\\log.txt" ] [
     "C:\\builds\\factor\\12345\\"
-    "..\\log.txt" append-path normalize-pathname
+    "..\\log.txt" append-path normalize-path
 ] unit-test
 
 [ "\\\\?\\C:\\builds\\" ] [
     "C:\\builds\\factor\\12345\\"
-    "..\\.." append-path normalize-pathname
+    "..\\.." append-path normalize-path
 ] unit-test
 
 [ "\\\\?\\C:\\builds\\" ] [
     "C:\\builds\\factor\\12345\\"
-    "..\\.." append-path normalize-pathname
+    "..\\.." append-path normalize-path
 ] unit-test
+
+[ "c:\\blah" ] [ "c:\\foo\\bar" "\\blah" append-path ] unit-test
+[ t ] [ "" resource-path 2 tail exists? ] unit-test

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

@@ -1,22 +1,22 @@
 USING: continuations destructors io.buffers io.files io.backend
 io.timeouts io.nonblocking io.windows io.windows.nt.backend
-kernel libc math threads windows windows.kernel32
+kernel libc math threads windows windows.kernel32 system
 alien.c-types alien.arrays sequences combinators combinators.lib
 sequences.lib ascii splitting alien strings assocs namespaces ;
 IN: io.windows.nt.files
 
-M: windows-nt-io cwd
+M: winnt cwd
     MAX_UNICODE_PATH dup "ushort" <c-array>
     [ GetCurrentDirectory win32-error=0/f ] keep
     alien>u16-string ;
 
-M: windows-nt-io cd
+M: winnt cd
     SetCurrentDirectory win32-error=0/f ;
 
 : unicode-prefix ( -- seq )
     "\\\\?\\" ; inline
 
-M: windows-nt-io root-directory? ( path -- ? )
+M: winnt root-directory? ( path -- ? )
     {
         { [ dup empty? ] [ f ] }
         { [ dup [ path-separator? ] all? ] [ t ] }
@@ -36,33 +36,19 @@ ERROR: not-absolute-path ;
     } && [ 2 head ] [ not-absolute-path ] if ;
 
 : prepend-prefix ( string -- string' )
-    unicode-prefix prepend ;
+    dup unicode-prefix head? [
+        unicode-prefix prepend
+    ] unless ;
 
-ERROR: nonstring-pathname ;
+M: winnt normalize-path ( string -- string' )
-ERROR: empty-pathname ;
+    (normalize-path)
+    { { CHAR: / CHAR: \\ } } substitute
+    prepend-prefix ;
 
-M: windows-nt-io normalize-pathname ( string -- string )
+M: winnt CreateFile-flags ( DWORD -- DWORD )
-    "resource:" ?head [
-        left-trim-separators resource-path
-        normalize-pathname
-    ] [
-        dup empty? [ empty-pathname ] when
-        current-directory get prepend-path
-        dup unicode-prefix head? [
-            dup first path-separator? [
-                left-trim-separators
-                current-directory get 2 head
-                prepend-path
-            ] when
-            unicode-prefix prepend
-        ] unless
-        { { CHAR: / CHAR: \\ } } substitute ! necessary
-    ] if ;
-
-M: windows-nt-io CreateFile-flags ( DWORD -- DWORD )
     FILE_FLAG_OVERLAPPED bitor ;
 
-M: windows-nt-io FileArgs-overlapped ( port -- overlapped )
+M: winnt FileArgs-overlapped ( port -- overlapped )
     make-overlapped ;
 
 : update-file-ptr ( n port -- )

extra/io/windows/nt/launcher/launcher.factor

@@ -32,7 +32,7 @@ IN: io.windows.nt.launcher
     drop 2nip null-pipe ;
 
 :: redirect-file ( default path access-mode create-mode -- handle )
-    path normalize-pathname
+    path normalize-path
     access-mode
     share-mode
     security-attributes-inherit
@@ -112,13 +112,13 @@ IN: io.windows.nt.launcher
     dup pipe-out f set-inherit
     >>stdin-pipe ;
 
-M: windows-nt-io fill-redirection ( process args -- )
+M: winnt fill-redirection ( process args -- )
     [ 2dup redirect-stdout ] keep lpStartupInfo>> set-STARTUPINFO-hStdOutput
     [ 2dup redirect-stderr ] keep lpStartupInfo>> set-STARTUPINFO-hStdError
     [ 2dup redirect-stdin  ] keep lpStartupInfo>> set-STARTUPINFO-hStdInput
     2drop ;
 
-M: windows-nt-io (process-stream)
+M: winnt (process-stream)
     [
         dup make-CreateProcess-args
 

extra/io/windows/nt/monitors/monitors.factor

@@ -5,7 +5,7 @@ io.windows.nt.backend kernel math windows windows.kernel32
 windows.types libc assocs alien namespaces continuations
 io.monitors io.monitors.private io.nonblocking io.buffers
 io.files io.timeouts io sequences hashtables sorting arrays
-combinators math.bitfields strings ;
+combinators math.bitfields strings system ;
 IN: io.windows.nt.monitors
 
 : open-directory ( path -- handle )
@@ -30,7 +30,7 @@ TUPLE: win32-monitor path recursive? ;
         set-delegate
     } win32-monitor construct ;
 
-M: windows-nt-io <monitor> ( path recursive? -- monitor )
+M: winnt <monitor> ( path recursive? -- monitor )
     [
         over open-directory win32-monitor <buffered-port>
         <win32-monitor>

extra/io/windows/nt/nt.factor

@@ -11,5 +11,6 @@ USE: io.windows.nt.sockets
 USE: io.windows.mmap
 USE: io.windows.files
 USE: io.backend
+USE: system
 
-T{ windows-nt-io } set-io-backend
+winnt set-io-backend

extra/io/windows/nt/sockets/sockets.factor

@@ -2,13 +2,13 @@ USING: alien alien.accessors alien.c-types byte-arrays
 continuations destructors io.nonblocking io.timeouts io.sockets
 io.sockets.impl io namespaces io.streams.duplex io.windows
 io.windows.nt.backend windows.winsock kernel libc math sequences
-threads classes.tuple.lib ;
+threads classes.tuple.lib system ;
 IN: io.windows.nt.sockets
 
 : malloc-int ( object -- object )
     "int" heap-size malloc tuck 0 set-alien-signed-4 ; inline
 
-M: windows-nt-io WSASocket-flags ( -- DWORD )
+M: winnt WSASocket-flags ( -- DWORD )
     WSA_FLAG_OVERLAPPED ;
 
 : get-ConnectEx-ptr ( socket -- void* )
@@ -50,7 +50,7 @@ TUPLE: ConnectEx-args port
     2dup save-callback
     get-overlapped-result drop ;
 
-M: windows-nt-io (client) ( addrspec -- client-in client-out )
+M: winnt (client) ( addrspec -- client-in client-out )
     [
         \ ConnectEx-args construct-empty
         over make-sockaddr/size pick init-connect
@@ -119,7 +119,7 @@ TUPLE: AcceptEx-args port
     [ AcceptEx-args-sAcceptSocket* add-completion ] keep
     AcceptEx-args-sAcceptSocket* <win32-socket> ;
 
-M: windows-nt-io (accept) ( server -- addrspec handle )
+M: winnt (accept) ( server -- addrspec handle )
     [
         [
             dup check-server-port
@@ -131,14 +131,14 @@ M: windows-nt-io (accept) ( server -- addrspec handle )
         ] with-timeout
     ] with-destructors ;
 
-M: windows-nt-io (server) ( addrspec -- handle )
+M: winnt (server) ( addrspec -- handle )
     [
         SOCK_STREAM server-fd dup listen-on-socket
         dup add-completion
         <win32-socket>
     ] with-destructors ;
 
-M: windows-nt-io <datagram> ( addrspec -- datagram )
+M: winnt <datagram> ( addrspec -- datagram )
     [
         [
             SOCK_DGRAM server-fd
@@ -190,7 +190,7 @@ TUPLE: WSARecvFrom-args port
     [ WSARecvFrom-args-lpFrom* ] keep
     WSARecvFrom-args-port datagram-port-addr parse-sockaddr ;
 
-M: windows-nt-io receive ( datagram -- packet addrspec )
+M: winnt receive ( datagram -- packet addrspec )
     [
         dup check-datagram-port
         \ WSARecvFrom-args construct-empty
@@ -242,7 +242,7 @@ TUPLE: WSASendTo-args port
 
 USE: io.sockets
 
-M: windows-nt-io send ( packet addrspec datagram -- )
+M: winnt send ( packet addrspec datagram -- )
     [
         3dup check-datagram-send
         \ WSASendTo-args construct-empty

extra/io/windows/windows.factor

@@ -5,16 +5,12 @@ io.buffers io.files io.nonblocking io.sockets io.binary
 io.sockets.impl windows.errors strings io.streams.duplex
 kernel math namespaces sequences windows windows.kernel32
 windows.shell32 windows.types windows.winsock splitting
-continuations math.bitfields ;
+continuations math.bitfields system ;
 IN: io.windows
 
-TUPLE: windows-nt-io ;
+M: windows destruct-handle CloseHandle drop ;
-TUPLE: windows-ce-io ;
-UNION: windows-io windows-nt-io windows-ce-io ;
 
-M: windows-io destruct-handle CloseHandle drop ;
+M: windows destruct-socket closesocket drop ;
-
-M: windows-io destruct-socket closesocket drop ;
 
 TUPLE: win32-file handle ptr ;
 
@@ -24,8 +20,8 @@ HOOK: CreateFile-flags io-backend ( DWORD -- DWORD )
 HOOK: FileArgs-overlapped io-backend ( port -- overlapped/f )
 HOOK: add-completion io-backend ( port -- )
 
-M: windows-io normalize-directory ( string -- string )
+M: windows normalize-directory ( string -- string )
-    normalize-pathname "\\" ?tail drop "\\*" append ;
+    normalize-path "\\" ?tail drop "\\*" append ;
 
 : share-mode ( -- fixnum )
     {
@@ -125,31 +121,31 @@ C: <FileArgs> FileArgs
     [ FileArgs-lpNumberOfBytesRet ] keep
     FileArgs-lpOverlapped ;
 
-M: windows-io (file-reader) ( path -- stream )
+M: windows (file-reader) ( path -- stream )
     open-read <win32-file> <reader> ;
 
-M: windows-io (file-writer) ( path -- stream )
+M: windows (file-writer) ( path -- stream )
     open-write <win32-file> <writer> ;
 
-M: windows-io (file-appender) ( path -- stream )
+M: windows (file-appender) ( path -- stream )
     open-append <win32-file> <writer> ;
 
-M: windows-io move-file ( from to -- )
+M: windows move-file ( from to -- )
-    [ normalize-pathname ] bi@ MoveFile win32-error=0/f ;
+    [ normalize-path ] bi@ MoveFile win32-error=0/f ;
 
-M: windows-io delete-file ( path -- )
+M: windows delete-file ( path -- )
-    normalize-pathname DeleteFile win32-error=0/f ;
+    normalize-path DeleteFile win32-error=0/f ;
 
-M: windows-io copy-file ( from to -- )
+M: windows copy-file ( from to -- )
     dup parent-directory make-directories
-    [ normalize-pathname ] bi@ 0 CopyFile win32-error=0/f ;
+    [ normalize-path ] bi@ 0 CopyFile win32-error=0/f ;
 
-M: windows-io make-directory ( path -- )
+M: windows make-directory ( path -- )
-    normalize-pathname
+    normalize-path
     f CreateDirectory win32-error=0/f ;
 
-M: windows-io delete-directory ( path -- )
+M: windows delete-directory ( path -- )
-    normalize-pathname
+    normalize-path
     RemoveDirectory win32-error=0/f ;
 
 HOOK: WSASocket-flags io-backend ( -- DWORD )
@@ -194,7 +190,7 @@ USE: namespaces
 M: win32-socket dispose ( stream -- )
     win32-file-handle closesocket drop ;
 
-M: windows-io addrinfo-error ( n -- )
+M: windows addrinfo-error ( n -- )
     winsock-return-check ;
 
 : tcp-socket ( addrspec -- socket )

extra/math/polynomials/polynomials.factor

@@ -22,7 +22,7 @@ PRIVATE>
 : p= ( p p -- ? ) pextend = ;
 
 : ptrim ( p -- p )
-    dup singleton? [ [ zero? ] right-trim ] unless ;
+    dup length 1 = [ [ zero? ] right-trim ] unless ;
 
 : 2ptrim ( p p -- p p ) [ ptrim ] bi@ ;
 : p+ ( p p -- p ) pextend v+ ;

extra/math/text/english/english.factor

@@ -79,7 +79,7 @@ SYMBOL: and-needed?
     ] if ;
 
 : recombine ( seq -- str )
-    dup singleton? [
+    dup length 1 = [
         first 3digits>text
     ] [
         dup set-conjunction "" swap

extra/new-effects/new-effects.factor

@@ -1,17 +0,0 @@
-USING: assocs kernel sequences ;
-IN: new-effects
-
-: new-nth ( seq n -- elt )
-    swap nth ; inline
-
-: new-set-nth ( seq obj n -- seq )
-    pick set-nth ; inline
-
-: new-at ( assoc key -- elt )
-    swap at ; inline
-
-: new-at* ( assoc key -- elt ? )
-    swap at* ; inline
-
-: new-set-at ( assoc value key -- assoc )
-    pick set-at ; inline

extra/newfx/newfx.factor

@@ -0,0 +1,68 @@
+
+USING: kernel sequences assocs qualified ;
+
+QUALIFIED: sequences
+
+IN: newfx
+
+! Now, we can see a new world coming into view.
+! A world in which there is the very real prospect of a new world order.
+!
+!    - George Herbert Walker Bush
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nth-at ( seq i -- val ) swap nth ;
+: nth-of ( i seq -- val )      nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: nth-is ( seq   i val -- seq ) swap pick set-nth ;
+: is-nth ( seq val   i -- seq )      pick set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mutate-nth    ( seq i val -- ) swap rot set-nth ;
+: mutate-at-nth ( seq val i -- )      rot set-nth ;
+
+: mutate-nth-of    (   i val seq -- ) swapd set-nth ;
+: mutate-at-nth-of ( val   i seq -- )       set-nth ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: at-key ( tbl key -- val ) swap at ;
+: key-of ( key tbl -- val )      at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: key-is ( tbl key val -- tbl ) swap pick set-at ;
+: is-key ( tbl val key -- tbl )      pick set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: mutate-key    ( tbl key val -- ) swap rot set-at ;
+: mutate-at-key ( tbl val key -- )      rot set-at ;
+
+: mutate-key-of    ( key val tbl -- ) swapd set-at ;
+: mutate-at-key-of ( val key tbl -- )       set-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: push    ( seq obj -- seq ) over sequences:push ;
+: push-on ( obj seq -- seq ) tuck sequences:push ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: member?    ( seq obj -- ? ) swap sequences:member? ;
+: member-of? ( obj seq -- ? )      sequences:member? ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+: delete-at-key ( tbl key -- tbl ) over delete-at ;
+: delete-key-of ( key tbl -- tbl ) tuck delete-at ;
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! A note about the 'mutate' qualifier. Other words also technically mutate
+! their primary object. However, the 'mutate' qualifier is supposed to
+! indicate that this is the main objective of the word, as a side effect.

extra/ogg/ogg.factor

@@ -6,9 +6,9 @@ IN: ogg
 
 <<
 "ogg" {
-    { [ win32? ]  [ "ogg.dll" ] }
+    { [ os winnt? ]  [ "ogg.dll" ] }
-    { [ macosx? ] [ "libogg.0.dylib" ] }
+    { [ os macosx? ] [ "libogg.0.dylib" ] }
-    { [ unix? ]   [ "libogg.so" ] }
+    { [ os unix? ]   [ "libogg.so" ] }
 } cond "cdecl" add-library
 >>
 

extra/ogg/theora/theora.factor

@@ -6,9 +6,9 @@ IN: ogg.theora
 
 <<
 "theora" {
-    { [ win32? ]  [ "theora.dll" ] }
+    { [ os winnt? ]  [ "theora.dll" ] }
-    { [ macosx? ] [ "libtheora.0.dylib" ] }
+    { [ os macosx? ] [ "libtheora.0.dylib" ] }
-    { [ unix? ]   [ "libtheora.so" ] }
+    { [ os unix? ]   [ "libtheora.so" ] }
 } cond "cdecl" add-library
 >>