diff --git a/basis/alien/c-types/c-types-docs.factor b/basis/alien/c-types/c-types-docs.factor index f5f9e004c4..cd0f90f81c 100644 --- a/basis/alien/c-types/c-types-docs.factor +++ b/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: +{ $deprecated "New code should use " { $link } " 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." } ; -{ malloc-array } related-words - HELP: { $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 } "." } +{ $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." } ; +{ 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." } diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 4c3c8d1668..13607566e0 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -254,16 +254,19 @@ M: f byte-length drop 0 ; inline ] unless* ; : ( n type -- array ) - heap-size * ; inline + heap-size * ; inline deprecated : ( type -- array ) - 1 swap ; inline + heap-size ; inline + +: (c-object) ( type -- array ) + heap-size (byte-array) ; inline : malloc-array ( n type -- alien ) - heap-size calloc ; inline + [ heap-size calloc ] [ ] 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 ; diff --git a/basis/alien/complex/complex-tests.factor b/basis/alien/complex/complex-tests.factor index 2844e505b5..7bf826d87e 100644 --- a/basis/alien/complex/complex-tests.factor +++ b/basis/alien/complex/complex-tests.factor @@ -1,22 +1,21 @@ ! 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 -namespaces math ; +USING: accessors tools.test alien.complex classes.struct kernel +alien.c-types alien.syntax namespaces math ; IN: alien.complex.tests -C-STRUCT: complex-holder - { "complex-float" "z" } ; +STRUCT: complex-holder + { z complex-float } ; : ( z -- alien ) - "complex-holder" - [ set-complex-holder-z ] keep ; + complex-holder ; [ ] [ C{ 1.0 2.0 } "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 -[ number ] [ "complex-double" c-type-boxed-class ] unit-test \ No newline at end of file +[ number ] [ "complex-double" c-type-boxed-class ] unit-test diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 7727546c00..cb66175a29 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/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 -arrays kernel functors vocabs.parser namespaces accessors -quotations ; +USING: accessors alien.structs alien.c-types classes.struct math +math.functions sequences arrays kernel functors vocabs.parser +namespaces quotations ; IN: alien.complex.functor FUNCTOR: define-complex-type ( N T -- ) -T-real DEFINES ${T}-real -T-imaginary DEFINES ${T}-imaginary -set-T-real DEFINES set-${T}-real -set-T-imaginary DEFINES set-${T}-imaginary +T-class DEFINES-CLASS ${T} DEFINES <${T}> *T DEFINES *${T} WHERE +STRUCT: T-class { real N } { imaginary N } ; + : ( z -- alien ) - >rect T [ set-T-imaginary ] [ set-T-real ] [ ] tri ; inline + >rect T-class ; : *T ( alien -- z ) - [ T-real ] [ T-imaginary ] bi rect> ; inline + T-class memory>struct [ real>> ] [ imaginary>> ] bi rect> ; inline -T current-vocab -{ { N "real" } { N "imaginary" } } -define-struct - -T c-type +T-class c-type 1quotation >>unboxer-quot *T 1quotation >>boxer-quot number >>boxed-class diff --git a/basis/classes/struct/struct-docs.factor b/basis/classes/struct/struct-docs.factor index 2b27672018..bcc77f1b25 100644 --- a/basis/classes/struct/struct-docs.factor +++ b/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 diff --git a/basis/classes/struct/struct.factor b/basis/classes/struct/struct.factor index 2cafb5e8fe..45ad3c62bb 100644 --- a/basis/classes/struct/struct.factor +++ b/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 -generalizations generic.parser kernel kernel.private lexer -libc macros make math math.order parser quotations sequences -slots slots.private struct-arrays vectors words -compiler.tree.propagation.transforms ; +combinators combinators.short-circuit combinators.smart +functors.backend fry generalizations generic.parser kernel +kernel.private lexer libc locals macros make math math.order parser +quotations sequences slots slots.private struct-arrays vectors +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 ] 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 ] 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 diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor index 1f9430e443..9da68e368b 100644 --- a/basis/cocoa/enumeration/enumeration.factor +++ b/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 -sequences vectors fry libc destructors -specialized-arrays.direct.alien ; +USING: accessors kernel classes.struct cocoa cocoa.types alien.c-types +locals math sequences vectors fry libc destructors ; 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: - dup 0 = [ drop ] [ - state NSFastEnumerationState-itemsPtr [ stackbuf ] unless* - swap quot each + object state stackbuf count -> countByEnumeratingWithState:objects:count: :> items-count + items-count 0 = [ + state itemsPtr>> [ items-count "id" ] [ stackbuf ] if* :> items + 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 diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor index 9da285f34c..fe003c32e1 100644 --- a/basis/cocoa/messages/messages.factor +++ b/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 -math namespaces make quotations sequences strings words -cocoa.runtime io macros memoize io.encodings.utf8 effects libc -libc.private lexer init core-foundation fry generalizations -specialized-arrays.direct.alien ; +classes.struct continuations combinators compiler compiler.alien +stack-checker kernel math namespaces make quotations sequences +strings words cocoa.runtime io macros memoize io.encodings.utf8 +effects libc libc.private lexer init core-foundation fry +generalizations specialized-arrays.direct.alien ; IN: cocoa.messages : make-sender ( method function -- quot ) @@ -31,11 +31,8 @@ super-message-senders [ H{ } clone ] initialize bi ; : ( receiver -- super ) - "objc-super" [ - [ dup object_getClass class_getSuperclass ] dip - set-objc-super-class - ] keep - [ set-objc-super-receiver ] keep ; + [ ] [ object_getClass class_getSuperclass ] bi + objc-super ; TUPLE: selector name object ; diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 7817d0006c..28d812a489 100644 --- a/basis/cocoa/runtime/runtime.factor +++ b/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 - { "id" "receiver" } - { "Class" "class" } ; +STRUCT: objc-super + { receiver id } + { class Class } ; CONSTANT: CLS_CLASS HEX: 1 CONSTANT: CLS_META HEX: 2 diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index 6e03a21bbc..0e0ef72ad2 100644 --- a/basis/cocoa/types/types.factor +++ b/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 - { "NSUInteger" "location" } - { "NSUInteger" "length" } ; +STRUCT: NSRange + { location NSUInteger } + { length NSUInteger } ; TYPEDEF: NSRange _NSRange @@ -27,13 +27,11 @@ TYPEDEF: int long32 TYPEDEF: uint ulong32 TYPEDEF: void* unknown_type -: ( length location -- size ) - "NSRange" - [ set-NSRange-length ] keep - [ set-NSRange-location ] keep ; +: ( location length -- size ) + NSRange ; -C-STRUCT: NSFastEnumerationState - { "ulong" "state" } - { "id*" "itemsPtr" } - { "ulong*" "mutationsPtr" } - { "ulong[5]" "extra" } ; +STRUCT: NSFastEnumerationState + { state ulong } + { itemsPtr id* } + { mutationsPtr ulong* } + { extra ulong[5] } ; diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor index ce785dd8df..badcac5cdb 100644 --- a/basis/cocoa/views/views.factor +++ b/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 ; diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor index 82f836f28e..63bfaf37ce 100644 --- a/basis/core-foundation/core-foundation.factor +++ b/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,17 +20,15 @@ TYPEDEF: void* CFUUIDRef ALIAS: ALIAS: *CFIndex *long -C-STRUCT: CFRange -{ "CFIndex" "location" } -{ "CFIndex" "length" } ; +STRUCT: CFRange + { location CFIndex } + { length CFIndex } ; : ( location length -- range ) - "CFRange" - [ set-CFRange-length ] keep - [ set-CFRange-location ] keep ; + CFRange ; FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ; FUNCTION: void CFRelease ( CFTypeRef cf ) ; -DESTRUCTOR: CFRelease \ No newline at end of file +DESTRUCTOR: CFRelease diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 4aa531f182..4b2cce994a 100644 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/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 - { "CFIndex" "version" } - { "void*" "info" } - { "void*" "retain" } - { "void*" "release" } - { "void*" "copyDescription" } ; +STRUCT: FSEventStreamContext + { version CFIndex } + { info void* } + { retain void* } + { release void* } + { 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" - [ set-FSEventStreamContext-info ] keep ; + FSEventStreamContext + swap >>info ; :: ( callback info paths latency flags -- event-stream ) f ! allocator diff --git a/basis/core-graphics/types/types.factor b/basis/core-graphics/types/types.factor index 0acdad9c0c..ad4620e174 100644 --- a/basis/core-graphics/types/types.factor +++ b/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 - { "CGFloat" "x" } - { "CGFloat" "y" } ; +STRUCT: CGPoint + { x CGFloat } + { y CGFloat } ; : ( x y -- point ) - "CGPoint" - [ set-CGPoint-y ] keep - [ set-CGPoint-x ] keep ; + CGPoint ; -C-STRUCT: CGSize - { "CGFloat" "w" } - { "CGFloat" "h" } ; +STRUCT: CGSize + { w CGFloat } + { h CGFloat } ; : ( w h -- size ) - "CGSize" - [ set-CGSize-h ] keep - [ set-CGSize-w ] keep ; + CGSize ; -C-STRUCT: CGRect - { "CGPoint" "origin" } - { "CGSize" "size" } ; +STRUCT: CGRect + { origin CGPoint } + { 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 ] - [ CGRect-size CGSize>dim ] + [ origin>> CGPoint>loc ] + [ size>> CGSize>dim ] bi ; 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 : ( x y w h -- rect ) - "CGRect" - [ set-CGRect-h ] keep - [ set-CGRect-w ] keep - [ set-CGRect-y ] keep - [ set-CGRect-x ] keep ; + [ CGPoint ] [ CGSize ] 2bi* + CGRect ; : 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 - { "CGFloat" "a" } - { "CGFloat" "b" } - { "CGFloat" "c" } - { "CGFloat" "d" } - { "CGFloat" "tx" } - { "CGFloat" "ty" } ; +STRUCT: CGAffineTransform + { a CGFloat } + { b CGFloat } + { c CGFloat } + { d CGFloat } + { tx CGFloat } + { ty CGFloat } ; TYPEDEF: void* CGColorRef TYPEDEF: void* CGColorSpaceRef diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor index 52f4eb5e2e..99849c1666 100644 --- a/basis/core-text/core-text.factor +++ b/basis/core-text/core-text.factor @@ -116,8 +116,8 @@ TUPLE: line < disposable line metrics image loc dim ; line [ string open-font font foreground>> |CFRelease ] rect [ line line-rect ] - (loc) [ rect CGRect-origin CGPoint>loc ] - (dim) [ rect CGRect-size CGSize>dim ] + (loc) [ rect origin>> CGPoint>loc ] + (dim) [ rect size>> CGSize>dim ] (ext) [ (loc) (dim) v+ ] loc [ (loc) [ floor ] map ] ext [ (loc) (dim) [ + ceiling ] 2map ] diff --git a/basis/functors/backend/backend.factor b/basis/functors/backend/backend.factor new file mode 100644 index 0000000000..dd3d891f7b --- /dev/null +++ b/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 ; + diff --git a/basis/functors/functors-tests.factor b/basis/functors/functors-tests.factor index a21313312b..bcdc1bae74 100644 --- a/basis/functors/functors-tests.factor +++ b/basis/functors/functors-tests.factor @@ -1,5 +1,5 @@ -USING: functors tools.test math words kernel multiline parser -io.streams.string generic ; +USING: classes.struct functors tools.test math words kernel +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 + diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor index 5f519aeece..62654ece79 100644 --- a/basis/functors/functors.factor +++ b/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 -generic.standard interpolate io.streams.string kernel lexer +combinators effects.parser fry functors.backend generic +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 ) , ; [ 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 ( n type -- array ) + heap-size * ; inline + FUNCTOR: define-array ( T -- ) A DEFINES-CLASS ${T}-array diff --git a/basis/tools/deprecation/deprecation.factor b/basis/tools/deprecation/deprecation.factor index ff6a7ef51a..0ee60b06b5 100644 --- a/basis/tools/deprecation/deprecation.factor +++ b/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 diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index 177a157994..90103a79f9 100755 --- a/core/sequences/sequences.factor +++ b/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 -M: integer length ; inline -M: integer nth-unsafe drop ; inline +! Integers used to support the sequence protocol +M: integer length ; inline deprecated +M: integer nth-unsafe drop ; inline deprecated INSTANCE: integer immutable-sequence