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

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

@@ -49,12 +49,11 @@ HELP: c-setter
 { $errors "Throws an error if the type does not exist." } ;
 
 HELP: <c-array>
+{ $deprecated "New code should use " { $link <c-type-array> } " or the " { $vocab-link "specialized-arrays" } " vocabularies." }
 { $values { "n" "a non-negative integer" } { "type" "a C type" } { "array" byte-array } }
 { $description "Creates a byte array large enough to hold " { $snippet "n" } " values of a C type." }
 { $errors "Throws an error if the type does not exist or the requested size is negative." } ;
 
-{ <c-array> malloc-array } related-words
-
 HELP: <c-object>
 { $values { "type" "a C type" } { "array" byte-array } }
 { $description "Creates a byte array suitable for holding a value with the given C type." }
@@ -73,9 +72,10 @@ HELP: byte-array>memory
 
 HELP: malloc-array
 { $values { "n" "a non-negative integer" } { "type" "a C type" } { "alien" alien } }
-{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type." }
+{ $description "Allocates an unmanaged memory block large enough to hold " { $snippet "n" } " values of a C type, then wraps the memory in a sequence object using " { $link <c-type-direct-array> } "." }
+{ $notes "The appropriate direct specialized array vocabulary must be loaded; otherwise, a " { $link specialized-array-vocab-not-loaded } " error will be thrown. The vocabulary can be loaded with a " { $link POSTPONE: USING: } " form as usual, or with the " { $link require-c-type-arrays } " word. See the " { $vocab-link "specialized-arrays.direct" } " vocabulary set for details on the underlying sequence type constructed." }
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
-{ $errors "Throws an error if the type does not exist, if the requested size is negative, or if memory allocation fails." } ;
+{ $errors "Throws an error if the type does not exist, if the requested size is negative, if a direct specialized array class appropriate to the type is not loaded, or if memory allocation fails." } ;
 
 HELP: malloc-object
 { $values { "type" "a C type" } { "alien" alien } }
@@ -89,6 +89,8 @@ HELP: malloc-byte-array
 { $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
 { $errors "Throws an error if memory allocation fails." } ;
 
+{ <c-type-array> <c-type-direct-array> malloc-array } related-words
+
 HELP: box-parameter
 { $values { "n" integer } { "ctype" string } }
 { $description "Generates code for converting a C value stored at  offset " { $snippet "n" } " from the top of the stack into a Factor object to be pushed on the data stack." }

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

@@ -254,16 +254,19 @@ M: f byte-length drop 0 ; inline
     ] unless* ;
 
 : <c-array> ( n type -- array )
-    heap-size * <byte-array> ; inline
+    heap-size * <byte-array> ; inline deprecated
 
 : <c-object> ( type -- array )
-    1 swap <c-array> ; inline
+    heap-size <byte-array> ; inline
+
+: (c-object) ( type -- array )
+    heap-size (byte-array) ; inline
 
 : malloc-array ( n type -- alien )
-    heap-size calloc ; inline
+    [ heap-size calloc ] [ <c-type-direct-array> ] 2bi ; inline
 
 : malloc-object ( type -- alien )
-    1 swap malloc-array ; inline
+    1 swap heap-size calloc ; inline
 
 : malloc-byte-array ( byte-array -- alien )
     dup byte-length [ nip malloc dup ] 2keep memcpy ;

basis/alien/complex/complex-tests.factor

@@ -1,21 +1,20 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: tools.test alien.complex kernel alien.c-types alien.syntax
+USING: accessors tools.test alien.complex classes.struct kernel
-namespaces math ;
+alien.c-types alien.syntax namespaces math ;
 IN: alien.complex.tests
 
-C-STRUCT: complex-holder
+STRUCT: complex-holder
-    { "complex-float" "z" } ;
+    { z complex-float } ;
 
 : <complex-holder> ( z -- alien )
-    "complex-holder" <c-object>
+    complex-holder <struct-boa> ;
-    [ set-complex-holder-z ] keep ;
 
 [ ] [
     C{ 1.0 2.0 } <complex-holder> "h" set
 ] unit-test
 
-[ C{ 1.0 2.0 } ] [ "h" get complex-holder-z ] unit-test
+[ C{ 1.0 2.0 } ] [ "h" get z>> ] unit-test
 
 [ number ] [ "complex-float" c-type-boxed-class ] unit-test
 

basis/alien/complex/functor/functor.factor

@@ -1,33 +1,28 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.structs alien.c-types math math.functions sequences
+USING: accessors alien.structs alien.c-types classes.struct math
-arrays kernel functors vocabs.parser namespaces accessors
+math.functions sequences arrays kernel functors vocabs.parser
-quotations ;
+namespaces quotations ;
 IN: alien.complex.functor
 
 FUNCTOR: define-complex-type ( N T -- )
 
-T-real DEFINES ${T}-real
+T-class DEFINES-CLASS ${T}
-T-imaginary DEFINES ${T}-imaginary
-set-T-real DEFINES set-${T}-real
-set-T-imaginary DEFINES set-${T}-imaginary
 
 <T> DEFINES <${T}>
 *T DEFINES *${T}
 
 WHERE
 
+STRUCT: T-class { real N } { imaginary N } ;
+
 : <T> ( z -- alien )
-    >rect T <c-object> [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline
+    >rect T-class <struct-boa> ;
 
 : *T ( alien -- z )
-    [ T-real ] [ T-imaginary ] bi rect> ; inline
+    T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline
 
-T current-vocab
+T-class c-type
-{ { N "real" } { N "imaginary" } }
-define-struct
-
-T c-type
 <T> 1quotation >>unboxer-quot
 *T 1quotation >>boxer-quot
 number >>boxed-class

basis/classes/struct/struct-docs.factor

@@ -40,13 +40,13 @@ HELP: UNION-STRUCT:
 
 HELP: define-struct-class
 { $values
-    { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+    { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
 }
 { $description "Defines a new " { $link struct } " class. This is the runtime equivalent of the " { $link POSTPONE: STRUCT: } " syntax." } ;
 
 HELP: define-union-struct-class
 { $values
-    { "class" class } { "slots" "a sequence of " { $link slot-spec } "s" }
+    { "class" class } { "slots" "a sequence of " { $link struct-slot-spec } "s" }
 }
 { $description "Defines a new " { $link struct } " class where all of the slots share the same storage. This is the runtime equivalent of the " { $link POSTPONE: UNION-STRUCT: } " syntax." } ;
 
@@ -55,7 +55,7 @@ HELP: malloc-struct
     { "class" class }
     { "struct" struct }
 }
-{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are left uninitialized. The struct should be " { $link free } "d when it is no longer needed." } ;
+{ $description "Allocates unmanaged C heap memory for a new " { $link struct } " of the specified " { $snippet "class" } ". The new struct's slots are zeroed out. The struct should be " { $link free } "d when it is no longer needed." } ;
 
 HELP: memory>struct
 { $values

basis/classes/struct/struct.factor

@@ -2,11 +2,11 @@
 USING: accessors alien alien.c-types alien.structs
 alien.structs.fields arrays byte-arrays classes classes.parser
 classes.tuple classes.tuple.parser classes.tuple.private
-combinators combinators.short-circuit combinators.smart fry
+combinators combinators.short-circuit combinators.smart
-generalizations generic.parser kernel kernel.private lexer
+functors.backend fry generalizations generic.parser kernel
-libc macros make math math.order parser quotations sequences
+kernel.private lexer libc locals macros make math math.order parser
-slots slots.private struct-arrays vectors words
+quotations sequences slots slots.private struct-arrays vectors
-compiler.tree.propagation.transforms ;
+words compiler.tree.propagation.transforms ;
 FROM: slots => reader-word writer-word ;
 IN: classes.struct
 
@@ -45,7 +45,7 @@ M: struct equal?
 ] 1 define-partial-eval
 
 : malloc-struct ( class -- struct )
-    [ heap-size malloc ] keep memory>struct ; inline
+    [ 1 swap heap-size calloc ] keep memory>struct ; inline
 
 : (struct) ( class -- struct )
     [ heap-size <byte-array> ] keep memory>struct ; inline
@@ -259,6 +259,34 @@ SYNTAX: UNION-STRUCT:
 SYNTAX: S{
     scan-word dup struct-slots parse-tuple-literal-slots parsed ;
 
+: scan-c-type` ( -- c-type/param )
+    scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
+
+:: parse-struct-slot` ( accum -- accum )
+    scan-string-param :> name
+    scan-c-type` :> c-type
+    \ } parse-until :> attributes
+    accum {
+        \ struct-slot-spec new 
+            name >>name
+            c-type [ >>c-type ] [ struct-slot-class >>class ] bi
+            attributes [ dup empty? ] [ peel-off-attributes ] until drop
+        over push
+    } over push-all ;
+
+: parse-struct-slots` ( accum -- accum more? )
+    scan {
+        { ";" [ f ] }
+        { "{" [ parse-struct-slot` t ] }
+        [ invalid-struct-slot ]
+    } case ;
+
+FUNCTOR-SYNTAX: STRUCT:
+    scan-param parsed
+    [ 8 <vector> ] over push-all
+    [ parse-struct-slots` ] [ ] while
+    [ >array define-struct-class ] over push-all ;
+
 USING: vocabs vocabs.loader ;
 
 "prettyprint" vocab [ "classes.struct.prettyprint" require ] when

basis/cocoa/enumeration/enumeration.factor

@@ -1,27 +1,28 @@
 ! Copyright (C) 2008 Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: kernel cocoa cocoa.types alien.c-types locals math
+USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types
-sequences vectors fry libc destructors
+locals math sequences vectors fry libc destructors ;
-specialized-arrays.direct.alien ;
 IN: cocoa.enumeration
 
+<< "id" require-c-type-arrays >>
+
 CONSTANT: NS-EACH-BUFFER-SIZE 16
 
 : with-enumeration-buffers ( quot -- )
     '[
-        "NSFastEnumerationState" malloc-object &free
+        NSFastEnumerationState malloc-struct &free
         NS-EACH-BUFFER-SIZE "id" malloc-array &free
         NS-EACH-BUFFER-SIZE
         @
     ] with-destructors ; inline
 
 :: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
-    object state stackbuf count -> countByEnumeratingWithState:objects:count:
+    object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count
-    dup 0 = [ drop ] [
+    items-count 0 = [
-        state NSFastEnumerationState-itemsPtr [ stackbuf ] unless*
+        state itemsPtr>> [ items-count "id" <c-type-direct-array> ] [ stackbuf ] if* :> items
-        swap <direct-void*-array> quot each
+        items-count iota [ items nth quot call ] each
         object quot state stackbuf count (NSFastEnumeration-each)
-    ] if ; inline recursive
+    ] unless ; inline recursive
 
 : NSFastEnumeration-each ( object quot -- )
     [ (NSFastEnumeration-each) ] with-enumeration-buffers ; inline

basis/cocoa/messages/messages.factor

@@ -1,11 +1,11 @@
 ! Copyright (C) 2006, 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors alien alien.c-types alien.strings arrays assocs
-continuations combinators compiler compiler.alien stack-checker kernel
+classes.struct continuations combinators compiler compiler.alien
-math namespaces make quotations sequences strings words
+stack-checker kernel math namespaces make quotations sequences
-cocoa.runtime io macros memoize io.encodings.utf8 effects libc
+strings words cocoa.runtime io macros memoize io.encodings.utf8
-libc.private lexer init core-foundation fry generalizations
+effects libc libc.private lexer init core-foundation fry
-specialized-arrays.direct.alien ;
+generalizations specialized-arrays.direct.alien ;
 IN: cocoa.messages
 
 : make-sender ( method function -- quot )
@@ -31,11 +31,8 @@ super-message-senders [ H{ } clone ] initialize
     bi ;
 
 : <super> ( receiver -- super )
-    "objc-super" <c-object> [
+    [ ] [ object_getClass class_getSuperclass ] bi
-        [ dup object_getClass class_getSuperclass ] dip
+    objc-super <struct-boa> ;
-        set-objc-super-class
-    ] keep
-    [ set-objc-super-receiver ] keep ;
 
 TUPLE: selector name object ;
 

basis/cocoa/runtime/runtime.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2007 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax ;
+USING: alien.syntax classes.struct ;
 IN: cocoa.runtime
 
 TYPEDEF: void* SEL
@@ -17,9 +17,9 @@ TYPEDEF: void* Class
 TYPEDEF: void* Method
 TYPEDEF: void* Protocol
 
-C-STRUCT: objc-super
+STRUCT: objc-super
-    { "id" "receiver" }
+    { receiver id }
-    { "Class" "class" } ;
+    { class Class } ;
 
 CONSTANT: CLS_CLASS        HEX: 1
 CONSTANT: CLS_META         HEX: 2

basis/cocoa/types/types.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2006, 2009 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
 USING: alien.c-types alien.syntax combinators kernel layouts
-core-graphics.types ;
+classes.struct core-graphics.types ;
 IN: cocoa.types
 
 TYPEDEF: long NSInteger
@@ -16,9 +16,9 @@ TYPEDEF: NSSize _NSSize
 TYPEDEF: CGRect NSRect
 TYPEDEF: NSRect _NSRect
 
-C-STRUCT: NSRange
+STRUCT: NSRange
-    { "NSUInteger" "location" }
+    { location NSUInteger }
-    { "NSUInteger" "length" } ;
+    { length NSUInteger } ;
 
 TYPEDEF: NSRange _NSRange
 
@@ -27,13 +27,11 @@ TYPEDEF: int long32
 TYPEDEF: uint ulong32
 TYPEDEF: void* unknown_type
 
-: <NSRange> ( length location -- size )
+: <NSRange> ( location length -- size )
-    "NSRange" <c-object>
+    NSRange <struct-boa> ;
-    [ set-NSRange-length ] keep
-    [ set-NSRange-location ] keep ;
 
-C-STRUCT: NSFastEnumerationState
+STRUCT: NSFastEnumerationState
-    { "ulong" "state" }
+    { state ulong }
-    { "id*" "itemsPtr" }
+    { itemsPtr id* }
-    { "ulong*" "mutationsPtr" }
+    { mutationsPtr ulong* }
-    { "ulong[5]" "extra" } ;
+    { extra ulong[5] } ;

basis/cocoa/views/views.factor

@@ -58,6 +58,6 @@ CONSTANT: NSOpenGLCPSwapInterval 222
 : mouse-location ( view event -- loc )
     [
         -> locationInWindow f -> convertPoint:fromView:
-        [ CGPoint-x ] [ CGPoint-y ] bi
+        [ x>> ] [ y>> ] bi
     ] [ drop -> frame CGRect-h ] 2bi
     swap - [ >integer ] bi@ 2array ;

basis/core-foundation/core-foundation.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2006, 2008 Slava Pestov
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.c-types alien.destructors accessors kernel ;
+USING: alien.syntax alien.c-types alien.destructors accessors classes.struct kernel ;
 IN: core-foundation
 
 TYPEDEF: void* CFTypeRef
@@ -20,14 +20,12 @@ TYPEDEF: void* CFUUIDRef
 ALIAS: <CFIndex> <long>
 ALIAS: *CFIndex *long
 
-C-STRUCT: CFRange
+STRUCT: CFRange
-{ "CFIndex" "location" }
+    { location CFIndex }
-{ "CFIndex" "length" } ;
+    { length CFIndex } ;
 
 : <CFRange> ( location length -- range )
-    "CFRange" <c-object>
+    CFRange <struct-boa> ;
-    [ set-CFRange-length ] keep
-    [ set-CFRange-location ] keep ;
 
 FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
 

basis/core-foundation/fsevents/fsevents.factor

@@ -3,7 +3,7 @@
 USING: alien alien.c-types alien.strings alien.syntax kernel
 math sequences namespaces make assocs init accessors
 continuations combinators io.encodings.utf8 destructors locals
-arrays specialized-arrays.direct.alien
+arrays specialized-arrays.direct.alien classes.struct
 specialized-arrays.direct.int specialized-arrays.direct.longlong
 core-foundation core-foundation.run-loop core-foundation.strings
 core-foundation.time ;
@@ -26,12 +26,12 @@ TYPEDEF: int FSEventStreamEventFlags
 TYPEDEF: longlong FSEventStreamEventId
 TYPEDEF: void* FSEventStreamRef
 
-C-STRUCT: FSEventStreamContext
+STRUCT: FSEventStreamContext
-    { "CFIndex" "version" }
+    { version CFIndex }
-    { "void*" "info" }
+    { info void* }
-    { "void*" "retain" }
+    { retain void* }
-    { "void*" "release" }
+    { release void* }
-    { "void*" "copyDescription" } ;
+    { copyDescription void* } ;
 
 ! callback(FSEventStreamRef streamRef, void *clientCallBackInfo, size_t numEvents, void *eventPaths, const FSEventStreamEventFlags eventFlags[], const FSEventStreamEventId eventIds[]);
 TYPEDEF: void* FSEventStreamCallback
@@ -104,8 +104,8 @@ FUNCTION: void FSEventStreamShow ( FSEventStreamRef streamRef ) ;
 FUNCTION: CFStringRef FSEventStreamCopyDescription ( FSEventStreamRef streamRef ) ;
 
 : make-FSEventStreamContext ( info -- alien )
-    "FSEventStreamContext" <c-object>
+    FSEventStreamContext <struct>
-    [ set-FSEventStreamContext-info ] keep ;
+        swap >>info ;
 
 :: <FSEventStream> ( callback info paths latency flags -- event-stream )
     f ! allocator

basis/core-graphics/types/types.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2009 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax kernel layouts
+USING: accessors alien.c-types alien.syntax classes.struct kernel layouts
 math math.rectangles arrays ;
 IN: core-graphics.types
 
@@ -12,63 +12,56 @@ IN: core-graphics.types
 : *CGFloat ( alien -- x )
     cell 4 = [ *float ] [ *double ] if ; inline
 
-C-STRUCT: CGPoint
+STRUCT: CGPoint
-    { "CGFloat" "x" }
+    { x CGFloat }
-    { "CGFloat" "y" } ;
+    { y CGFloat } ;
 
 : <CGPoint> ( x y -- point )
-    "CGPoint" <c-object>
+    CGPoint <struct-boa> ;
-    [ set-CGPoint-y ] keep
-    [ set-CGPoint-x ] keep ;
 
-C-STRUCT: CGSize
+STRUCT: CGSize
-    { "CGFloat" "w" }
+    { w CGFloat }
-    { "CGFloat" "h" } ;
+    { h CGFloat } ;
 
 : <CGSize> ( w h -- size )
-    "CGSize" <c-object>
+    CGSize <struct-boa> ;
-    [ set-CGSize-h ] keep
-    [ set-CGSize-w ] keep ;
 
-C-STRUCT: CGRect
+STRUCT: CGRect
-    { "CGPoint" "origin" }
+    { origin CGPoint }
-    { "CGSize"  "size"   } ;
+    { size   CGSize  } ;
 
 : CGPoint>loc ( CGPoint -- loc )
-    [ CGPoint-x ] [ CGPoint-y ] bi 2array ;
+    [ x>> ] [ y>> ] bi 2array ;
 
 : CGSize>dim ( CGSize -- dim )
-    [ CGSize-w ] [ CGSize-h ] bi 2array ;
+    [ w>> ] [ h>> ] bi 2array ;
 
 : CGRect>rect ( CGRect -- rect )
-    [ CGRect-origin CGPoint>loc ]
+    [ origin>> CGPoint>loc ]
-    [ CGRect-size CGSize>dim ]
+    [ size>>   CGSize>dim ]
     bi <rect> ; inline
 
 : CGRect-x ( CGRect -- x )
-    CGRect-origin CGPoint-x ; inline
+    origin>> x>> ; inline
 : CGRect-y ( CGRect -- y )
-    CGRect-origin CGPoint-y ; inline
+    origin>> y>> ; inline
 : CGRect-w ( CGRect -- w )
-    CGRect-size CGSize-w ; inline
+    size>> w>> ; inline
 : CGRect-h ( CGRect -- h )
-    CGRect-size CGSize-h ; inline
+    size>> h>> ; inline
 
 : set-CGRect-x ( x CGRect -- )
-    CGRect-origin set-CGPoint-x ; inline
+    origin>> (>>x) ; inline
 : set-CGRect-y ( y CGRect -- )
-    CGRect-origin set-CGPoint-y ; inline
+    origin>> (>>y) ; inline
 : set-CGRect-w ( w CGRect -- )
-    CGRect-size set-CGSize-w ; inline
+    size>> (>>w) ; inline
 : set-CGRect-h ( h CGRect -- )
-    CGRect-size set-CGSize-h ; inline
+    size>> (>>h) ; inline
 
 : <CGRect> ( x y w h -- rect )
-    "CGRect" <c-object>
+    [ CGPoint <struct-boa> ] [ CGSize <struct-boa> ] 2bi*
-    [ set-CGRect-h ] keep
+    CGRect <struct-boa> ;
-    [ set-CGRect-w ] keep
-    [ set-CGRect-y ] keep
-    [ set-CGRect-x ] keep ;
 
 : CGRect-x-y ( alien -- origin-x origin-y )
     [ CGRect-x ] [ CGRect-y ] bi ;
@@ -76,13 +69,13 @@ C-STRUCT: CGRect
 : CGRect-top-left ( alien -- x y )
     [ CGRect-x ] [ [ CGRect-y ] [ CGRect-h ] bi + ] bi ;
 
-C-STRUCT: CGAffineTransform
+STRUCT: CGAffineTransform
-    { "CGFloat" "a" }
+    { a CGFloat }
-    { "CGFloat" "b" }
+    { b CGFloat }
-    { "CGFloat" "c" }
+    { c CGFloat }
-    { "CGFloat" "d" }
+    { d CGFloat }
-    { "CGFloat" "tx" }
+    { tx CGFloat }
-    { "CGFloat" "ty" } ;
+    { ty CGFloat } ;
 
 TYPEDEF: void* CGColorRef
 TYPEDEF: void* CGColorSpaceRef

basis/core-text/core-text.factor

@@ -116,8 +116,8 @@ TUPLE: line < disposable line metrics image loc dim ;
                 line [ string open-font font foreground>> <CTLine> |CFRelease ]
 
                 rect [ line line-rect ]
-                (loc) [ rect CGRect-origin CGPoint>loc ]
+                (loc) [ rect origin>> CGPoint>loc ]
-                (dim) [ rect CGRect-size CGSize>dim ]
+                (dim) [ rect size>> CGSize>dim ]
                 (ext) [ (loc) (dim) v+ ]
                 loc [ (loc) [ floor ] map ]
                 ext [ (loc) (dim) [ + ceiling ] 2map ]

basis/functors/backend/backend.factor

@@ -0,0 +1,33 @@
+USING: accessors arrays assocs generic.standard kernel
+lexer locals.types namespaces parser quotations vocabs.parser
+words ;
+IN: functors.backend
+
+DEFER: functor-words
+\ functor-words [ H{ } clone ] initialize
+
+SYNTAX: FUNCTOR-SYNTAX:
+    scan-word
+    gensym [ parse-definition define-syntax ] keep
+    swap name>> \ functor-words get-global set-at ;
+
+: functor-words ( -- assoc )
+    \ functor-words get-global ;
+
+: scan-param ( -- obj ) scan-object literalize ;
+
+: >string-param ( string -- string/param )
+    dup search dup lexical? [ nip ] [ drop ] if ;
+
+: scan-string-param ( -- name/param )
+    scan >string-param ;
+
+: scan-c-type-param ( -- c-type/param )
+    scan dup "{" = [ drop \ } parse-until >array ] [ >string-param ] if ;
+
+: define* ( word def -- ) over set-word define ;
+
+: define-declared* ( word def effect -- ) pick set-word define-declared ;
+
+: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
+

basis/functors/functors-tests.factor

@@ -1,5 +1,5 @@
-USING: functors tools.test math words kernel multiline parser
+USING: classes.struct functors tools.test math words kernel
-io.streams.string generic ;
+multiline parser io.streams.string generic ;
 IN: functors.tests
 
 <<
@@ -151,3 +151,64 @@ SYMBOL: W-symbol
 
 test-redefinition
 
+<<
+
+FUNCTOR: define-a-struct ( T NAME TYPE N -- )
+
+T-class DEFINES-CLASS ${T}
+
+WHERE
+
+STRUCT: T-class
+    { NAME int }
+    { x { TYPE 4 } }
+    { y { "short" N } }
+    { z TYPE initial: 5 }
+    { float { "float" 2 } } ;
+
+;FUNCTOR
+
+"a-struct" "nemo" "char" 2 define-a-struct
+
+>>
+
+[
+    {
+        T{ struct-slot-spec
+            { name "nemo" }
+            { offset 0 }
+            { class integer }
+            { initial 0 } 
+            { c-type "int" }
+        }
+        T{ struct-slot-spec
+            { name "x" }
+            { offset 4 }
+            { class object }
+            { initial f } 
+            { c-type { "char" 4 } }
+        }
+        T{ struct-slot-spec
+            { name "y" }
+            { offset 8 }
+            { class object }
+            { initial f } 
+            { c-type { "short" 2 } }
+        }
+        T{ struct-slot-spec
+            { name "z" }
+            { offset 12 }
+            { class fixnum }
+            { initial 5 } 
+            { c-type "char" }
+        }
+        T{ struct-slot-spec
+            { name "float" }
+            { offset 16 }
+            { class object }
+            { initial f } 
+            { c-type { "float" 2 } }
+        }
+    }
+] [ a-struct struct-slots ] unit-test
+

basis/functors/functors.factor

@@ -2,8 +2,8 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays classes.mixin classes.parser
 classes.singleton classes.tuple classes.tuple.parser
-combinators effects.parser fry generic generic.parser
+combinators effects.parser fry functors.backend generic
-generic.standard interpolate io.streams.string kernel lexer
+generic.parser interpolate io.streams.string kernel lexer
 locals.parser locals.types macros make namespaces parser
 quotations sequences vocabs.parser words words.symbol ;
 IN: functors
@@ -12,14 +12,6 @@ IN: functors
 
 <PRIVATE
 
-: scan-param ( -- obj ) scan-object literalize ;
-
-: define* ( word def -- ) over set-word define ;
-
-: define-declared* ( word def effect -- ) pick set-word define-declared ;
-
-: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
-
 TUPLE: fake-call-next-method ;
 
 TUPLE: fake-quotation seq ;
@@ -58,7 +50,7 @@ M: object (fake-quotations>) , ;
     [ parse-definition* ] dip
     parsed ;
 
-SYNTAX: `TUPLE:
+FUNCTOR-SYNTAX: TUPLE:
     scan-param parsed
     scan {
         { ";" [ tuple parsed f parsed ] }
@@ -71,60 +63,60 @@ SYNTAX: `TUPLE:
     } case
     \ define-tuple-class parsed ;
 
-SYNTAX: `SINGLETON:
+FUNCTOR-SYNTAX: SINGLETON:
     scan-param parsed
     \ define-singleton-class parsed ;
 
-SYNTAX: `MIXIN:
+FUNCTOR-SYNTAX: MIXIN:
     scan-param parsed
     \ define-mixin-class parsed ;
 
-SYNTAX: `M:
+FUNCTOR-SYNTAX: M:
     scan-param parsed
     scan-param parsed
     [ create-method-in dup method-body set ] over push-all
     parse-definition*
     \ define* parsed ;
 
-SYNTAX: `C:
+FUNCTOR-SYNTAX: C:
     scan-param parsed
     scan-param parsed
     complete-effect
     [ [ [ boa ] curry ] over push-all ] dip parsed
     \ define-declared* parsed ;
 
-SYNTAX: `:
+FUNCTOR-SYNTAX: :
     scan-param parsed
     parse-declared*
     \ define-declared* parsed ;
 
-SYNTAX: `SYMBOL:
+FUNCTOR-SYNTAX: SYMBOL:
     scan-param parsed
     \ define-symbol parsed ;
 
-SYNTAX: `SYNTAX:
+FUNCTOR-SYNTAX: SYNTAX:
     scan-param parsed
     parse-definition*
     \ define-syntax parsed ;
 
-SYNTAX: `INSTANCE:
+FUNCTOR-SYNTAX: INSTANCE:
     scan-param parsed
     scan-param parsed
     \ add-mixin-instance parsed ;
 
-SYNTAX: `GENERIC:
+FUNCTOR-SYNTAX: GENERIC:
     scan-param parsed
     complete-effect parsed
     \ define-simple-generic* parsed ;
 
-SYNTAX: `MACRO:
+FUNCTOR-SYNTAX: MACRO:
     scan-param parsed
     parse-declared*
     \ define-macro parsed ;
 
-SYNTAX: `inline [ word make-inline ] over push-all ;
+FUNCTOR-SYNTAX: inline [ word make-inline ] over push-all ;
 
-SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
+FUNCTOR-SYNTAX: call-next-method T{ fake-call-next-method } parsed ;
 
 : (INTERPOLATE) ( accum quot -- accum )
     [ scan interpolate-locals ] dip
@@ -144,23 +136,6 @@ DEFER: ;FUNCTOR delimiter
 
 <PRIVATE
 
-: functor-words ( -- assoc )
-    H{
-        { "TUPLE:" POSTPONE: `TUPLE: }
-        { "SINGLETON:" POSTPONE: `SINGLETON: }
-        { "MIXIN:" POSTPONE: `MIXIN: }
-        { "M:" POSTPONE: `M: }
-        { "C:" POSTPONE: `C: }
-        { ":" POSTPONE: `: }
-        { "GENERIC:" POSTPONE: `GENERIC: }
-        { "INSTANCE:" POSTPONE: `INSTANCE: }
-        { "SYNTAX:" POSTPONE: `SYNTAX: }
-        { "SYMBOL:" POSTPONE: `SYMBOL: }
-        { "inline" POSTPONE: `inline }
-        { "MACRO:" POSTPONE: `MACRO: }
-        { "call-next-method" POSTPONE: `call-next-method }
-    } ;
-
 : push-functor-words ( -- )
     functor-words use-words ;
 

basis/specialized-arrays/functor/functor.factor

@@ -13,6 +13,9 @@ M: bad-byte-array-length summary
 : (c-array) ( n c-type -- array )
     heap-size * (byte-array) ; inline
 
+: <c-array> ( n type -- array )
+    heap-size * <byte-array> ; inline
+
 FUNCTOR: define-array ( T -- )
 
 A            DEFINES-CLASS ${T}-array

basis/tools/deprecation/deprecation.factor

@@ -1,5 +1,6 @@
 ! (c)2009 Joe Groff bsd license
-USING: accessors arrays assocs compiler.units debugger init io
+USING: accessors arrays assocs combinators.short-circuit
+compiler.units debugger init io
 io.streams.null kernel namespaces prettyprint sequences
 source-files.errors summary tools.crossref
 tools.crossref.private tools.errors words ;
@@ -41,7 +42,7 @@ T{ error-type
 
 : check-deprecations ( usage -- )
     dup word? [
-        dup "forgotten" word-prop
+        dup { [ "forgotten" word-prop ] [ deprecated? ] } 1||
         [ clear-deprecation-note ] [
             dup def>> uses [ deprecated? ] filter
             [ clear-deprecation-note ] [ >array deprecation-note ] if-empty

core/sequences/sequences.factor

@@ -98,9 +98,9 @@ M: f like drop [ f ] when-empty ; inline
 
 INSTANCE: f immutable-sequence
 
-! Integers support the sequence protocol
+! Integers used to support the sequence protocol
-M: integer length ; inline
+M: integer length ; inline deprecated
-M: integer nth-unsafe drop ; inline
+M: integer nth-unsafe drop ; inline deprecated
 
 INSTANCE: integer immutable-sequence