get things to a point where they bootstrap again

basis/alien/c-types/c-types.factor

@@ -5,7 +5,7 @@ namespaces make parser sequences strings words splitting math.parser
 cpu.architecture alien alien.accessors alien.strings quotations
 layouts system compiler.units io io.files io.encodings.binary
 io.streams.memory accessors combinators effects continuations fry
-classes vocabs vocabs.loader vocabs.parser words.symbol ;
+classes vocabs vocabs.loader words.symbol ;
 QUALIFIED: math
 IN: alien.c-types
 
@@ -16,7 +16,8 @@ SYMBOLS:
     long ulong
     longlong ulonglong
     float double
-    void* bool ;
+    void* bool
+    void ;
 
 DEFER: <int>
 DEFER: *char
@@ -55,56 +56,48 @@ PREDICATE: c-type-word < word
 
 UNION: c-type-name string c-type-word ;
 
-: (c-type) ( name -- type/f )
-    c-types get-global at dup [
-        dup string? [ (c-type) ] when
-    ] when ;
-
 ! C type protocol
 GENERIC: c-type ( name -- type ) foldable
 
-: parse-c-type-name ( name -- word/string )
-    [ search ] keep or ;
-
 GENERIC: resolve-pointer-type ( name -- c-type )
 
 M: word resolve-pointer-type
     dup "pointer-c-type" word-prop
-    [ ] [ drop void* ] ?if c-type ;
+    [ ] [ drop void* ] ?if ;
 M: string resolve-pointer-type
     c-types get at dup string?
-    [ "*" append ] [ drop void* ] if
-    c-type ;
+    [ "*" append ] [ drop void* ] if ;
 
 : resolve-typedef ( name -- type )
     dup c-type-name? [ c-type ] when ;
 
-: parse-array-type ( name -- array )
+: parse-array-type ( name -- dims type )
     "[" split unclip
-    [ [ "]" ?tail drop string>number ] map ] dip
-    parse-c-type-name prefix ;
-
-: parse-c-type ( string -- array )
-    {
-        { [ CHAR: ] over member?    ] [ parse-array-type ] }
-        { [ dup search c-type-word? ] [ parse-c-type-name resolve-typedef ] }
-        { [ dup c-types get at      ] [ c-types get at resolve-typedef ] }
-        { [ "*" ?tail               ] [ parse-c-type-name resolve-pointer-type ] }
-        [ no-c-type ]
-    } cond ;
+    [ [ "]" ?tail drop string>number ] map ] dip ;
 
 M: string c-type ( name -- type )
-    parse-c-type ;
+    CHAR: ] over member? [
+        parse-array-type prefix
+    ] [
+        dup c-types get at [
+            resolve-typedef
+        ] [
+            "*" ?tail [ resolve-pointer-type ] [ no-c-type ] if
+        ] ?if
+    ] if ;
 
 M: word c-type
     "c-type" word-prop resolve-typedef ;
 
+: void? ( c-type -- ? )
+    { void "void" } member? ;
+
 GENERIC: c-struct? ( type -- ? )
 
 M: object c-struct?
     drop f ;
 M: string c-struct?
-    dup "void" = [ drop f ] [ c-type c-struct? ] if ;
+    dup void? [ drop f ] [ c-type c-struct? ] if ;
 
 ! These words being foldable means that words need to be
 ! recompiled if a C type is redefined. Even so, folding the
@@ -366,7 +359,7 @@ M: long-long-type box-return ( type -- )
     binary file-contents [ malloc-byte-array ] [ length ] bi ;
 
 : if-void ( type true false -- )
-    pick "void" = [ drop nip call ] [ nip call ] if ; inline
+    pick void? [ drop nip call ] [ nip call ] if ; inline
 
 CONSTANT: primitive-types
     {

basis/alien/parser/parser.factor

@@ -1,10 +1,23 @@
 ! Copyright (C) 2008, 2009 Slava Pestov, Doug Coleman.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types arrays assocs effects grouping kernel
-parser sequences splitting words fry locals lexer namespaces
-summary math ;
+USING: alien alien.c-types arrays assocs combinators effects
+grouping kernel parser sequences splitting words fry locals
+lexer namespaces summary math vocabs.parser ;
 IN: alien.parser
 
+: parse-c-type-name ( name -- word/string )
+    [ search ] keep or ;
+
+: parse-c-type ( string -- array )
+    {
+        { [ dup "void" =            ] [ drop void ] }
+        { [ CHAR: ] over member?    ] [ parse-array-type parse-c-type-name prefix ] }
+        { [ dup search c-type-word? ] [ parse-c-type-name ] }
+        { [ dup c-types get at      ] [ ] }
+        { [ "*" ?tail               ] [ parse-c-type-name resolve-pointer-type ] }
+        [ no-c-type ]
+    } cond ;
+
 : scan-c-type ( -- c-type )
     scan dup "{" =
     [ drop \ } parse-until >array ]

basis/alien/syntax/syntax.factor

@@ -22,10 +22,10 @@ SYNTAX: TYPEDEF:
     scan-c-type CREATE typedef ;
 
 SYNTAX: C-STRUCT:
-    CREATE current-vocab parse-definition define-struct ; deprecated
+    scan current-vocab parse-definition define-struct ; deprecated
 
 SYNTAX: C-UNION:
-    CREATE parse-definition define-union ; deprecated
+    scan parse-definition define-union ; deprecated
 
 SYNTAX: C-ENUM:
     ";" parse-tokens

basis/classes/struct/struct-tests.factor

@@ -6,6 +6,8 @@ io.encodings.utf8 io.pathnames io.streams.string kernel libc
 literals math mirrors multiline namespaces prettyprint
 prettyprint.config see sequences specialized-arrays system
 tools.test parser lexer eval layouts ;
+FROM: math => float
+QUALIFIED-WITH: alien.c-types c
 SPECIALIZED-ARRAY: char
 SPECIALIZED-ARRAY: int
 SPECIALIZED-ARRAY: ushort
@@ -128,7 +130,7 @@ STRUCT: struct-test-bar
 ] unit-test
 
 UNION-STRUCT: struct-test-float-and-bits
-    { f float }
+    { f c:float }
     { bits uint } ;
 
 [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
@@ -181,14 +183,14 @@ STRUCT: struct-test-string-ptr
     ] with-scope
 ] unit-test
 
-[ <" USING: classes.struct ;
+[ <" USING: alien.c-types classes.struct ;
 IN: classes.struct.tests
 STRUCT: struct-test-foo
     { x char initial: 0 } { y int initial: 123 } { z bool } ;
 "> ]
 [ [ struct-test-foo see ] with-string-writer ] unit-test
 
-[ <" USING: classes.struct ;
+[ <" USING: alien.c-types classes.struct ;
 IN: classes.struct.tests
 UNION-STRUCT: struct-test-float-and-bits
     { f float initial: 0.0 } { bits uint initial: 0 } ;
@@ -201,20 +203,20 @@ UNION-STRUCT: struct-test-float-and-bits
         { offset 0 }
         { initial 0 }
         { class fixnum }
-        { type "char" }
+        { type char }
     }
     T{ struct-slot-spec
         { name "y" }
         { offset 4 }
         { initial 123 }
         { class integer }
-        { type "int" }
+        { type int }
     }
     T{ struct-slot-spec
         { name "z" }
         { offset 8 }
         { initial f }
-        { type "bool" }
+        { type bool }
         { class object }
     }
 } ] [ "struct-test-foo" c-type fields>> ] unit-test
@@ -223,14 +225,14 @@ UNION-STRUCT: struct-test-float-and-bits
     T{ struct-slot-spec
         { name "f" }
         { offset 0 }
-        { type "float" }
+        { type c:float }
         { class float }
         { initial 0.0 }
     }
     T{ struct-slot-spec
         { name "bits" }
         { offset 0 }
-        { type "uint" }
+        { type uint }
         { class integer }
         { initial 0 }
     }
@@ -277,7 +279,7 @@ STRUCT: struct-test-array-slots
 ] unit-test
 
 STRUCT: struct-test-optimization
-    { x { "int" 3 } } { y int } ;
+    { x { int 3 } } { y int } ;
 
 SPECIALIZED-ARRAY: struct-test-optimization
 

basis/classes/struct/struct.factor

@@ -1,12 +1,12 @@
 ! (c)Joe Groff bsd license
-USING: accessors alien alien.c-types arrays byte-arrays classes
-classes.parser classes.tuple classes.tuple.parser
+USING: accessors alien alien.c-types alien.parser arrays
+byte-arrays classes classes.parser classes.tuple classes.tuple.parser
 classes.tuple.private combinators combinators.short-circuit
 combinators.smart cpu.architecture definitions functors.backend
 fry generalizations generic.parser kernel kernel.private lexer
 libc locals macros make math math.order parser quotations
 sequences slots slots.private specialized-arrays vectors words
-summary namespaces assocs ;
+summary namespaces assocs vocabs.parser ;
 IN: classes.struct
 
 SPECIALIZED-ARRAY: uchar
@@ -197,20 +197,6 @@ M: struct-c-type c-struct? drop t ;
     [ type>> c-type-align ] [ max ] map-reduce ;
 PRIVATE>
 
-M: struct-class c-type name>> c-type ;
-
-M: struct-class c-type-align c-type c-type-align ;
-
-M: struct-class c-type-getter c-type c-type-getter ;
-
-M: struct-class c-type-setter c-type c-type-setter ;
-
-M: struct-class c-type-boxer-quot c-type c-type-boxer-quot ;
-
-M: struct-class c-type-unboxer-quot c-type c-type-boxer-quot ;
-
-M: struct-class heap-size c-type heap-size ;
-
 M: struct byte-length class "struct-size" word-prop ; foldable
 
 ! class definition
@@ -259,7 +245,7 @@ M: struct byte-length class "struct-size" word-prop ; foldable
         [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
         (struct-word-props)
     ]
-    [ drop [ c-type-for-class ] [ name>> ] bi typedef ] 2tri ; inline
+    [ drop [ c-type-for-class ] keep typedef ] 2tri ; inline
 PRIVATE>
 
 : define-struct-class ( class slots -- )
@@ -284,9 +270,6 @@ ERROR: invalid-struct-slot token ;
     [ [ dup empty? ] [ peel-off-attributes ] until drop ] tri* ;
 
 <PRIVATE
-: scan-c-type ( -- c-type )
-    scan dup "{" = [ drop \ } parse-until >array ] when ;
-
 : parse-struct-slot ( -- slot )
     scan scan-c-type \ } parse-until <struct-slot-spec> ;
     
@@ -317,7 +300,7 @@ SYNTAX: S@
 
 <PRIVATE
 : scan-c-type` ( -- c-type/param )
-    scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
+    scan dup "{" = [ drop \ } parse-until >array ] [ search ] if ;
 
 : parse-struct-slot` ( accum -- accum )
     scan-string-param scan-c-type` \ } parse-until

basis/compiler/codegen/codegen.factor

@@ -456,7 +456,7 @@ TUPLE: callback-context ;
 
 : callback-return-quot ( ctype -- quot )
     return>> {
-        { [ dup "void" = ] [ drop [ ] ] }
+        { [ dup void? ] [ drop [ ] ] }
         { [ dup large-struct? ] [ heap-size '[ _ memcpy ] ] }
         [ c-type c-type-unboxer-quot ]
     } cond ;

basis/core-foundation/numbers/numbers.factor

@@ -1,6 +1,7 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.syntax kernel math core-foundation ;
+FROM: math => float ;
 IN: core-foundation.numbers
 
 TYPEDEF: void* CFNumberRef

basis/cpu/x86/features/features.factor

@@ -1,8 +1,8 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: system kernel math math.order math.parser namespaces
-alien.syntax combinators locals init io cpu.x86 compiler
-compiler.units accessors ;
+alien.c-types alien.syntax combinators locals init io cpu.x86
+compiler compiler.units accessors ;
 IN: cpu.x86.features
 
 <PRIVATE

basis/functors/functors-tests.factor

@@ -1,5 +1,6 @@
 USING: classes.struct functors tools.test math words kernel
 multiline parser io.streams.string generic ;
+QUALIFIED-WITH: alien.c-types c
 IN: functors.tests
 
 <<
@@ -162,9 +163,9 @@ WHERE
 STRUCT: T-class
     { NAME int }
     { x { TYPE 4 } }
-    { y { "short" N } }
+    { y { short N } }
     { z TYPE initial: 5 }
-    { float { "float" 2 } } ;
+    { float { c:float 2 } } ;
 
 ;FUNCTOR
 
@@ -179,35 +180,35 @@ STRUCT: T-class
             { offset 0 }
             { class integer }
             { initial 0 } 
-            { c-type "int" }
+            { c-type int }
         }
         T{ struct-slot-spec
             { name "x" }
             { offset 4 }
             { class object }
             { initial f } 
-            { c-type { "char" 4 } }
+            { c-type { char 4 } }
         }
         T{ struct-slot-spec
             { name "y" }
             { offset 8 }
             { class object }
             { initial f } 
-            { c-type { "short" 2 } }
+            { c-type { short 2 } }
         }
         T{ struct-slot-spec
             { name "z" }
             { offset 12 }
             { class fixnum }
             { initial 5 } 
-            { c-type "char" }
+            { c-type char }
         }
         T{ struct-slot-spec
             { name "float" }
             { offset 16 }
             { class object }
             { initial f } 
-            { c-type { "float" 2 } }
+            { c-type { c:float 2 } }
         }
     }
 ] [ a-struct struct-slots ] unit-test

basis/math/libm/libm.factor

@@ -1,62 +1,62 @@
 ! Copyright (C) 2006 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien ;
+USING: alien alien.c-types ;
 IN: math.libm
 
 : facos ( x -- y )
-    "double" "libm" "acos" { "double" } alien-invoke ;
+    double "libm" "acos" { double } alien-invoke ;
 
 : fasin ( x -- y )
-    "double" "libm" "asin" { "double" } alien-invoke ;
+    double "libm" "asin" { double } alien-invoke ;
 
 : fatan ( x -- y )
-    "double" "libm" "atan" { "double" } alien-invoke ;
+    double "libm" "atan" { double } alien-invoke ;
 
 : fatan2 ( x y -- z )
-    "double" "libm" "atan2" { "double" "double" } alien-invoke ;
+    double "libm" "atan2" { double double } alien-invoke ;
 
 : fcos ( x -- y )
-    "double" "libm" "cos" { "double" } alien-invoke ;
+    double "libm" "cos" { double } alien-invoke ;
 
 : fsin ( x -- y )
-    "double" "libm" "sin" { "double" } alien-invoke ;
+    double "libm" "sin" { double } alien-invoke ;
 
 : ftan ( x -- y )
-    "double" "libm" "tan" { "double" } alien-invoke ;
+    double "libm" "tan" { double } alien-invoke ;
 
 : fcosh ( x -- y )
-    "double" "libm" "cosh" { "double" } alien-invoke ;
+    double "libm" "cosh" { double } alien-invoke ;
 
 : fsinh ( x -- y )
-    "double" "libm" "sinh" { "double" } alien-invoke ;
+    double "libm" "sinh" { double } alien-invoke ;
 
 : ftanh ( x -- y )
-    "double" "libm" "tanh" { "double" } alien-invoke ;
+    double "libm" "tanh" { double } alien-invoke ;
 
 : fexp ( x -- y )
-    "double" "libm" "exp" { "double" } alien-invoke ;
+    double "libm" "exp" { double } alien-invoke ;
 
 : flog ( x -- y )
-    "double" "libm" "log" { "double" } alien-invoke ;
+    double "libm" "log" { double } alien-invoke ;
 
 : flog10 ( x -- y )
-    "double" "libm" "log10" { "double" } alien-invoke ;
+    double "libm" "log10" { double } alien-invoke ;
 
 : fpow ( x y -- z )
-    "double" "libm" "pow" { "double" "double" } alien-invoke ;
+    double "libm" "pow" { double double } alien-invoke ;
 
 : fsqrt ( x -- y )
-    "double" "libm" "sqrt" { "double" } alien-invoke ;
+    double "libm" "sqrt" { double } alien-invoke ;
     
 ! Windows doesn't have these...
 : flog1+ ( x -- y )
-    "double" "libm" "log1p" { "double" } alien-invoke ;
+    double "libm" "log1p" { double } alien-invoke ;
 
 : facosh ( x -- y )
-    "double" "libm" "acosh" { "double" } alien-invoke ;
+    double "libm" "acosh" { double } alien-invoke ;
 
 : fasinh ( x -- y )
-    "double" "libm" "asinh" { "double" } alien-invoke ;
+    double "libm" "asinh" { double } alien-invoke ;
 
 : fatanh ( x -- y )
-    "double" "libm" "atanh" { "double" } alien-invoke ;
+    double "libm" "atanh" { double } alien-invoke ;

basis/specialized-arrays/specialized-arrays.factor

@@ -103,13 +103,21 @@ A T c-type-boxed-class f specialize-vector-words
 
 ;FUNCTOR
 
+GENERIC: (underlying-type) ( c-type -- c-type' )
+
+M: string (underlying-type) c-types get at ;
+M: word (underlying-type) "c-type" word-prop ;
+
 : underlying-type ( c-type -- c-type' )
-    dup c-types get at {
+    dup (underlying-type) {
         { [ dup not ] [ drop no-c-type ] }
-        { [ dup string? ] [ nip underlying-type ] }
+        { [ dup c-type-name? ] [ nip underlying-type ] }
         [ drop ]
     } cond ;
 
+: underlying-type-name ( c-type -- name )
+    underlying-type dup word? [ name>> ] when ;
+
 : specialized-array-vocab ( c-type -- vocab )
     "specialized-arrays.instances." prepend ;
 
@@ -125,26 +133,26 @@ PRIVATE>
     ] ?if ; inline
 
 : define-array-vocab ( type -- vocab )
-    underlying-type
+    underlying-type-name
     [ specialized-array-vocab ] [ '[ _ define-array ] ] bi
     generate-vocab ;
 
-M: string require-c-array define-array-vocab drop ;
+M: c-type-name require-c-array define-array-vocab drop ;
 
 ERROR: specialized-array-vocab-not-loaded c-type ;
 
-M: string c-array-constructor
-    underlying-type
+M: c-type-name c-array-constructor
+    underlying-type-name
     dup [ "<" "-array>" surround ] [ specialized-array-vocab ] bi lookup
     [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
 
-M: string c-(array)-constructor
-    underlying-type
+M: c-type-name c-(array)-constructor
+    underlying-type-name
     dup [ "(" "-array)" surround ] [ specialized-array-vocab ] bi lookup
     [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
 
-M: string c-direct-array-constructor
-    underlying-type
+M: c-type-name c-direct-array-constructor
+    underlying-type-name
     dup [ "<direct-" "-array>" surround ] [ specialized-array-vocab ] bi lookup
     [ ] [ specialized-array-vocab-not-loaded ] ?if ; foldable
 

basis/stack-checker/alien/alien.factor

@@ -19,7 +19,7 @@ TUPLE: alien-callback-params < alien-node-params quot xt ;
 
 : alien-stack ( params extra -- )
     over parameters>> length + consume-d >>in-d
-    dup return>> "void" = 0 1 ? produce-d >>out-d
+    dup return>> void? 0 1 ? produce-d >>out-d
     drop ;
 
 : return-prep-quot ( node -- quot )

basis/windows/com/syntax/syntax.factor

@@ -67,7 +67,7 @@ unless
 : (stack-effect-from-return-and-parameters) ( return parameters -- stack-effect )
     swap
     [ [ second ] map ]
-    [ dup "void" = [ drop { } ] [ 1array ] if ] bi*
+    [ dup void? [ drop { } ] [ 1array ] if ] bi*
     <effect> ;
 
 : (define-word-for-function) ( function interface n -- )