From 030351ef876dd8571d2cb596f149c2c70b39bcaa Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 26 Sep 2009 20:09:16 -0500 Subject: [PATCH 01/17] move the png filtering code to images.png --- basis/compression/inflate/inflate.factor | 42 +++--------------------- basis/images/png/png.factor | 35 +++++++++++++++++--- 2 files changed, 35 insertions(+), 42 deletions(-) diff --git a/basis/compression/inflate/inflate.factor b/basis/compression/inflate/inflate.factor index fa3f4d1284..26b851cc1e 100644 --- a/basis/compression/inflate/inflate.factor +++ b/basis/compression/inflate/inflate.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2009 Marc Fauconneau. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs byte-arrays -byte-vectors combinators fry grouping hashtables -compression.huffman images io.binary kernel locals -math math.bitwise math.order math.ranges multiline sequences -sorting ; +USING: accessors arrays assocs byte-vectors combinators +compression.huffman fry hashtables io.binary kernel locals math +math.bitwise math.order math.ranges sequences sorting ; +QUALIFIED-WITH: bitstreams bs IN: compression.inflate QUALIFIED-WITH: bitstreams bs @@ -177,42 +176,9 @@ CONSTANT: dist-table case ] [ produce ] keep call suffix concat ; - - ! [ produce ] keep dip swap suffix - -:: paeth ( a b c -- p ) - a b + c - { a b c } [ [ - abs ] keep 2array ] with map - sort-keys first second ; - -:: png-unfilter-line ( prev curr filter -- curr' ) - prev :> c - prev 3 tail-slice :> b - curr :> a - curr 3 tail-slice :> x - x length [0,b) - filter { - { 0 [ drop ] } - { 1 [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] } - { 2 [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] } - { 3 [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] } - { 4 [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] } - } case - curr 3 tail ; PRIVATE> -: reverse-png-filter' ( lines -- byte-array ) - [ first ] [ 1 tail ] [ map ] bi-curry@ bi nip - concat [ 128 + ] B{ } map-as ; - -: reverse-png-filter ( lines -- byte-array ) - dup first length 0 prefix - [ { 0 0 } prepend ] map - 2 clump [ - first2 dup [ third ] [ [ 0 2 ] dip set-nth ] bi - png-unfilter-line - ] map B{ } concat-as ; - : zlib-inflate ( bytes -- bytes ) bs: [ check-zlib-header ] [ inflate-loop ] bi diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index 8dde02687d..d0a001f3f6 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors images io io.binary io.encodings.ascii -io.encodings.binary io.encodings.string io.files io.files.info kernel -sequences io.streams.limited fry combinators arrays math checksums -checksums.crc32 compression.inflate grouping byte-arrays images.loader ; +USING: accessors arrays checksums checksums.crc32 combinators +compression.inflate fry grouping images images.loader io +io.binary io.encodings.ascii io.encodings.string kernel locals +math math.bitwise math.ranges sequences sorting ; IN: images.png SINGLETON: png-image @@ -90,6 +90,33 @@ ERROR: unknown-filter-method image ; [ unknown-color-type ] } case ; +:: paeth ( a b c -- p ) + a b + c - { a b c } [ [ - abs ] keep 2array ] with map + sort-keys first second ; + +:: png-unfilter-line ( prev curr filter -- curr' ) + prev :> c + prev 3 tail-slice :> b + curr :> a + curr 3 tail-slice :> x + x length [0,b) + filter { + { filter-none [ drop ] } + { filter-sub [ [| n | n x nth n a nth + 256 wrap n x set-nth ] each ] } + { filter-up [ [| n | n x nth n b nth + 256 wrap n x set-nth ] each ] } + { filter-average [ [| n | n x nth n a nth n b nth + 2/ + 256 wrap n x set-nth ] each ] } + { filter-paeth [ [| n | n x nth n a nth n b nth n c nth paeth + 256 wrap n x set-nth ] each ] } + } case + curr 3 tail ; + +: reverse-png-filter ( lines -- byte-array ) + dup first length 0 prefix + [ { 0 0 } prepend ] map + 2 clump [ + first2 dup [ third ] [ [ 0 2 ] dip set-nth ] bi + png-unfilter-line + ] map B{ } concat-as ; + : filter-png ( groups loading-png -- byte-array ) filter-method>> { { filter-none [ reverse-png-filter ] } From 4bc6b302cf2b6d0cb6b2cf23ba04a2607cb9ecc5 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 26 Sep 2009 20:34:10 -0500 Subject: [PATCH 02/17] remove some misguided code,oops --- basis/images/png/png.factor | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index d0a001f3f6..99228f58e1 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -78,7 +78,6 @@ ERROR: bad-checksum ; ERROR: unknown-color-type n ; ERROR: unimplemented-color-type image ; -ERROR: unknown-filter-method image ; : inflate-data ( loading-png -- bytes ) find-compressed-bytes zlib-inflate ; @@ -117,15 +116,8 @@ ERROR: unknown-filter-method image ; png-unfilter-line ] map B{ } concat-as ; -: filter-png ( groups loading-png -- byte-array ) - filter-method>> { - { filter-none [ reverse-png-filter ] } - [ unknown-filter-method ] - } case ; - : png-image-bytes ( loading-png -- byte-array ) - [ [ inflate-data ] [ png-group-width ] bi group ] - [ filter-png ] bi ; + [ inflate-data ] [ png-group-width ] bi group reverse-png-filter ; : decode-greyscale ( loading-png -- loading-png ) unimplemented-color-type ; From 033892dc10e622f5d681bb4f3298770b5908532f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 26 Sep 2009 22:24:14 -0500 Subject: [PATCH 03/17] minor refactoring --- basis/images/png/png.factor | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/basis/images/png/png.factor b/basis/images/png/png.factor index 99228f58e1..7e8f69d555 100755 --- a/basis/images/png/png.factor +++ b/basis/images/png/png.factor @@ -82,17 +82,23 @@ ERROR: unimplemented-color-type image ; : inflate-data ( loading-png -- bytes ) find-compressed-bytes zlib-inflate ; -: png-group-width ( loading-png -- n ) +: scale-bit-depth ( loading-png -- n ) bit-depth>> 8 / ; inline + +: png-bytes-per-pixel ( loading-png -- n ) dup color-type>> { - { 2 [ [ bit-depth>> 8 / 3 * ] [ width>> ] bi * 1 + ] } - { 6 [ [ bit-depth>> 8 / 4 * ] [ width>> ] bi * 1 + ] } + { 2 [ scale-bit-depth 3 * ] } + { 6 [ scale-bit-depth 4 * ] } [ unknown-color-type ] - } case ; + } case ; inline + +: png-group-width ( loading-png -- n ) + ! 1 + is for the filter type, 1 byte preceding each line + [ png-bytes-per-pixel ] [ width>> ] bi * 1 + ; :: paeth ( a b c -- p ) a b + c - { a b c } [ [ - abs ] keep 2array ] with map sort-keys first second ; - + :: png-unfilter-line ( prev curr filter -- curr' ) prev :> c prev 3 tail-slice :> b From 5054c954beddba990cf8f08687566b637ad14272 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sat, 26 Sep 2009 23:14:57 -0500 Subject: [PATCH 04/17] add USING:s and rearrange definitions so macosx can compile without parsing c-type strings --- basis/alien/c-types/c-types.factor | 2 + basis/cocoa/runtime/runtime.factor | 2 +- basis/cocoa/types/types.factor | 2 +- basis/core-foundation/arrays/arrays.factor | 3 +- .../attributed-strings.factor | 6 ++- basis/core-foundation/bundles/bundles.factor | 4 +- basis/core-foundation/data/data.factor | 5 ++- .../dictionaries/dictionaries.factor | 4 +- .../file-descriptors/file-descriptors.factor | 3 +- .../core-foundation/fsevents/fsevents.factor | 4 +- .../core-foundation/run-loop/run-loop.factor | 6 +-- basis/core-foundation/strings/strings.factor | 4 +- basis/core-foundation/time/time.factor | 2 +- basis/core-foundation/timers/timers.factor | 4 +- basis/core-foundation/urls/urls.factor | 4 +- basis/core-graphics/core-graphics.factor | 3 +- basis/core-graphics/types/types.factor | 6 ++- basis/core-text/fonts/fonts.factor | 7 ++-- basis/db/postgresql/ffi/ffi.factor | 1 - basis/environment/unix/macosx/macosx.factor | 2 +- basis/images/tiff/tiff.factor | 1 + basis/io/pipes/unix/unix.factor | 2 +- basis/opengl/gl/gl.factor | 6 +-- basis/opengl/textures/textures.factor | 1 + basis/openssl/libcrypto/libcrypto.factor | 6 +-- basis/openssl/libssl/libssl.factor | 28 ++++++------- .../mersenne-twister/mersenne-twister.factor | 6 +-- basis/tools/disassembler/udis/udis.factor | 4 +- basis/ui/pixel-formats/pixel-formats.factor | 6 +-- basis/unix/bsd/bsd.factor | 4 +- basis/unix/getfsstat/macosx/macosx.factor | 4 +- basis/unix/kqueue/kqueue.factor | 2 +- basis/unix/kqueue/macosx/macosx.factor | 2 +- basis/unix/process/process.factor | 2 +- basis/unix/stat/macosx/macosx.factor | 4 +- basis/unix/statvfs/macosx/macosx.factor | 2 +- basis/unix/types/types.factor | 9 ++++- basis/unix/unix.factor | 39 +++++++++++-------- basis/vm/vm.factor | 3 +- 39 files changed, 115 insertions(+), 90 deletions(-) diff --git a/basis/alien/c-types/c-types.factor b/basis/alien/c-types/c-types.factor index 9aea6fe252..fe8822f8c8 100755 --- a/basis/alien/c-types/c-types.factor +++ b/basis/alien/c-types/c-types.factor @@ -60,6 +60,8 @@ GENERIC: c-type ( name -- type ) foldable GENERIC: resolve-pointer-type ( name -- c-type ) +<< \ void \ void* "pointer-c-type" set-word-prop >> + M: word resolve-pointer-type dup "pointer-c-type" word-prop [ ] [ drop void* ] ?if ; diff --git a/basis/cocoa/runtime/runtime.factor b/basis/cocoa/runtime/runtime.factor index 28d812a489..f02f1f6182 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 classes.struct ; +USING: alien.c-types alien.syntax classes.struct ; IN: cocoa.runtime TYPEDEF: void* SEL diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor index 0e0ef72ad2..1e1ec98245 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 -classes.struct core-graphics.types ; +classes.struct cocoa.runtime core-graphics.types ; IN: cocoa.types TYPEDEF: long NSInteger diff --git a/basis/core-foundation/arrays/arrays.factor b/basis/core-foundation/arrays/arrays.factor index 1205352fcb..f0dfff9143 100644 --- a/basis/core-foundation/arrays/arrays.factor +++ b/basis/core-foundation/arrays/arrays.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel sequences fry ; +USING: alien.c-types alien.syntax core-foundation kernel +sequences fry ; IN: core-foundation.arrays TYPEDEF: void* CFArrayRef diff --git a/basis/core-foundation/attributed-strings/attributed-strings.factor b/basis/core-foundation/attributed-strings/attributed-strings.factor index 48c262f3a3..cd620bb876 100644 --- a/basis/core-foundation/attributed-strings/attributed-strings.factor +++ b/basis/core-foundation/attributed-strings/attributed-strings.factor @@ -1,6 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel destructors core-foundation +USING: alien.c-types alien.syntax kernel destructors +core-foundation core-foundation.dictionaries +core-foundation.strings core-foundation.utilities ; IN: core-foundation.attributed-strings @@ -16,4 +18,4 @@ FUNCTION: CFAttributedStringRef CFAttributedStringCreate ( [ [ >cf &CFRelease ] bi@ [ kCFAllocatorDefault ] 2dip CFAttributedStringCreate - ] with-destructors ; \ No newline at end of file + ] with-destructors ; diff --git a/basis/core-foundation/bundles/bundles.factor b/basis/core-foundation/bundles/bundles.factor index 790f1766c3..e45e2c52be 100644 --- a/basis/core-foundation/bundles/bundles.factor +++ b/basis/core-foundation/bundles/bundles.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel sequences core-foundation -core-foundation.urls ; +USING: alien.c-types alien.syntax kernel sequences +core-foundation core-foundation.urls ; IN: core-foundation.bundles TYPEDEF: void* CFBundleRef diff --git a/basis/core-foundation/data/data.factor b/basis/core-foundation/data/data.factor index ef5973888e..c4c09d0cc5 100644 --- a/basis/core-foundation/data/data.factor +++ b/basis/core-foundation/data/data.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.c-types alien.syntax kernel math sequences ; +USING: alien.c-types alien.syntax core-foundation kernel math +sequences ; IN: core-foundation.data TYPEDEF: void* CFDataRef @@ -16,4 +17,4 @@ FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFInd FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ; : ( byte-array -- alien ) - [ f ] dip dup length CFDataCreate ; \ No newline at end of file + [ f ] dip dup length CFDataCreate ; diff --git a/basis/core-foundation/dictionaries/dictionaries.factor b/basis/core-foundation/dictionaries/dictionaries.factor index cc0175e0ea..04b5aacb39 100644 --- a/basis/core-foundation/dictionaries/dictionaries.factor +++ b/basis/core-foundation/dictionaries/dictionaries.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax core-foundation kernel assocs +USING: alien.c-types alien.syntax core-foundation kernel assocs specialized-arrays math sequences accessors ; IN: core-foundation.dictionaries @@ -31,4 +31,4 @@ FUNCTION: void* CFDictionaryGetValue ( [ [ underlying>> ] bi@ ] [ nip length ] 2bi &: kCFTypeDictionaryKeyCallBacks &: kCFTypeDictionaryValueCallBacks - CFDictionaryCreate ; \ No newline at end of file + CFDictionaryCreate ; diff --git a/basis/core-foundation/file-descriptors/file-descriptors.factor b/basis/core-foundation/file-descriptors/file-descriptors.factor index c9fe3131b1..2520f1c3da 100644 --- a/basis/core-foundation/file-descriptors/file-descriptors.factor +++ b/basis/core-foundation/file-descriptors/file-descriptors.factor @@ -1,11 +1,12 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel math.bitwise core-foundation ; +USING: alien.c-types alien.syntax kernel math.bitwise core-foundation ; IN: core-foundation.file-descriptors TYPEDEF: void* CFFileDescriptorRef TYPEDEF: int CFFileDescriptorNativeDescriptor TYPEDEF: void* CFFileDescriptorCallBack +TYPEDEF: void* CFFileDescriptorContext* FUNCTION: CFFileDescriptorRef CFFileDescriptorCreate ( CFAllocatorRef allocator, diff --git a/basis/core-foundation/fsevents/fsevents.factor b/basis/core-foundation/fsevents/fsevents.factor index 9a22046a3a..6f5484fb77 100755 --- a/basis/core-foundation/fsevents/fsevents.factor +++ b/basis/core-foundation/fsevents/fsevents.factor @@ -4,8 +4,8 @@ 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 classes.struct core-foundation -core-foundation.run-loop core-foundation.strings -core-foundation.time ; +core-foundation.arrays core-foundation.run-loop +core-foundation.strings core-foundation.time unix.types ; IN: core-foundation.fsevents SPECIALIZED-ARRAY: void* diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor index 10d858a32f..7b454266f2 100644 --- a/basis/core-foundation/run-loop/run-loop.factor +++ b/basis/core-foundation/run-loop/run-loop.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien alien.syntax kernel math namespaces -sequences destructors combinators threads heaps deques calendar -core-foundation core-foundation.strings +USING: accessors alien alien.c-types alien.syntax kernel math +namespaces sequences destructors combinators threads heaps +deques calendar core-foundation core-foundation.strings core-foundation.file-descriptors core-foundation.timers core-foundation.time ; IN: core-foundation.run-loop diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor index 4bbe050230..cbabb083aa 100644 --- a/basis/core-foundation/strings/strings.factor +++ b/basis/core-foundation/strings/strings.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax alien.strings io.encodings.string kernel -sequences byte-arrays io.encodings.utf8 math core-foundation +USING: alien.c-types alien.syntax alien.strings io.encodings.string +kernel sequences byte-arrays io.encodings.utf8 math core-foundation core-foundation.arrays destructors parser fry alien words ; IN: core-foundation.strings diff --git a/basis/core-foundation/time/time.factor b/basis/core-foundation/time/time.factor index 15ad7bb1a1..8f09652462 100644 --- a/basis/core-foundation/time/time.factor +++ b/basis/core-foundation/time/time.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: calendar alien.syntax ; +USING: calendar alien.c-types alien.syntax ; IN: core-foundation.time TYPEDEF: double CFTimeInterval diff --git a/basis/core-foundation/timers/timers.factor b/basis/core-foundation/timers/timers.factor index 51ee982592..cf17cb41d9 100644 --- a/basis/core-foundation/timers/timers.factor +++ b/basis/core-foundation/timers/timers.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system math kernel calendar core-foundation -core-foundation.time ; +USING: alien.c-types alien.syntax system math kernel calendar +core-foundation core-foundation.time ; IN: core-foundation.timers TYPEDEF: void* CFRunLoopTimerRef diff --git a/basis/core-foundation/urls/urls.factor b/basis/core-foundation/urls/urls.factor index 7ffef498b6..f22095c344 100644 --- a/basis/core-foundation/urls/urls.factor +++ b/basis/core-foundation/urls/urls.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax kernel core-foundation.strings -core-foundation ; +USING: alien.c-types alien.syntax kernel core-foundation.strings +core-foundation core-foundation.urls ; IN: core-foundation.urls CONSTANT: kCFURLPOSIXPathStyle 0 diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor index a7bec04798..f3f759115c 100644 --- a/basis/core-graphics/core-graphics.factor +++ b/basis/core-graphics/core-graphics.factor @@ -2,7 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.destructors alien.syntax accessors destructors fry kernel math math.bitwise sequences libc colors -images images.memory core-graphics.types core-foundation.utilities ; +images images.memory core-graphics.types core-foundation.utilities +opengl.gl ; IN: core-graphics ! CGImageAlphaInfo diff --git a/basis/core-graphics/types/types.factor b/basis/core-graphics/types/types.factor index ad4620e174..a1e9b1dc9a 100644 --- a/basis/core-graphics/types/types.factor +++ b/basis/core-graphics/types/types.factor @@ -1,10 +1,12 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors alien.c-types alien.syntax classes.struct kernel layouts -math math.rectangles arrays ; +math math.rectangles arrays literals ; +FROM: alien.c-types => float ; IN: core-graphics.types -<< cell 4 = "float" "double" ? "CGFloat" typedef >> +SYMBOL: CGFloat +<< cell 4 = float double ? \ CGFloat typedef >> : ( x -- alien ) cell 4 = [ ] [ ] if ; inline diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor index 2656811c1f..6e85c94909 100644 --- a/basis/core-text/fonts/fonts.factor +++ b/basis/core-text/fonts/fonts.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors alien.syntax assocs core-foundation -core-foundation.strings core-text.utilities destructors init -kernel math memoize fonts combinators ; +USING: accessors alien.c-types alien.syntax assocs core-foundation +core-foundation.dictionaries core-foundation.strings +core-graphics.types core-text.utilities destructors init +kernel math memoize fonts combinators unix.types ; IN: core-text.fonts TYPEDEF: void* CTFontRef diff --git a/basis/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor index 93f93c9a13..1e7f4d5b82 100644 --- a/basis/db/postgresql/ffi/ffi.factor +++ b/basis/db/postgresql/ffi/ffi.factor @@ -68,7 +68,6 @@ TYPEDEF: void* PQconninfoOption* TYPEDEF: void* PGnotify* TYPEDEF: void* PQArgBlock* TYPEDEF: void* PQprintOpt* -TYPEDEF: void* FILE* TYPEDEF: void* SSL* LIBRARY: postgresql diff --git a/basis/environment/unix/macosx/macosx.factor b/basis/environment/unix/macosx/macosx.factor index 51cee7ba08..e811455927 100644 --- a/basis/environment/unix/macosx/macosx.factor +++ b/basis/environment/unix/macosx/macosx.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system environment.unix ; +USING: alien.c-types alien.syntax system environment.unix ; IN: environment.unix.macosx FUNCTION: void* _NSGetEnviron ( ) ; diff --git a/basis/images/tiff/tiff.factor b/basis/images/tiff/tiff.factor index c589349dff..dfc3c8b441 100755 --- a/basis/images/tiff/tiff.factor +++ b/basis/images/tiff/tiff.factor @@ -7,6 +7,7 @@ io.encodings.string io.encodings.utf8 io.files kernel math math.bitwise math.order math.parser pack prettyprint sequences strings math.vectors specialized-arrays locals images.loader ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: images.tiff diff --git a/basis/io/pipes/unix/unix.factor b/basis/io/pipes/unix/unix.factor index 7319ad1db8..8493f14d26 100644 --- a/basis/io/pipes/unix/unix.factor +++ b/basis/io/pipes/unix/unix.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: system kernel unix math sequences +USING: alien.c-types system kernel unix math sequences io.backend.unix io.ports specialized-arrays accessors ; QUALIFIED: io.pipes SPECIALIZED-ARRAY: int diff --git a/basis/opengl/gl/gl.factor b/basis/opengl/gl/gl.factor index 32c3ca4b82..412405c852 100644 --- a/basis/opengl/gl/gl.factor +++ b/basis/opengl/gl/gl.factor @@ -3,9 +3,9 @@ ! This file is based on the gl.h that comes with xorg-x11 6.8.2 -USING: alien alien.syntax combinators kernel parser sequences -system words opengl.gl.extensions ; - +USING: alien alien.c-types alien.syntax combinators kernel parser +sequences system words opengl.gl.extensions ; +FROM: alien.c-types => short ; IN: opengl.gl TYPEDEF: uint GLenum diff --git a/basis/opengl/textures/textures.factor b/basis/opengl/textures/textures.factor index 28d920d8d6..d846afe3a9 100755 --- a/basis/opengl/textures/textures.factor +++ b/basis/opengl/textures/textures.factor @@ -5,6 +5,7 @@ kernel opengl opengl.gl opengl.capabilities combinators images images.tesselation grouping sequences math math.vectors math.matrices generalizations fry arrays namespaces system locals literals specialized-arrays ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: opengl.textures diff --git a/basis/openssl/libcrypto/libcrypto.factor b/basis/openssl/libcrypto/libcrypto.factor index df9955a53c..ed280ecd69 100644 --- a/basis/openssl/libcrypto/libcrypto.factor +++ b/basis/openssl/libcrypto/libcrypto.factor @@ -103,15 +103,15 @@ FUNCTION: void* BIO_f_buffer ( ) ; CONSTANT: EVP_MAX_MD_SIZE 64 +TYPEDEF: void* EVP_MD* +TYPEDEF: void* ENGINE* + STRUCT: EVP_MD_CTX { digest EVP_MD* } { engine ENGINE* } { flags ulong } { md_data void* } ; -TYPEDEF: void* EVP_MD* -TYPEDEF: void* ENGINE* - ! Initialize ciphers and digest tables FUNCTION: void OpenSSL_add_all_ciphers ( ) ; diff --git a/basis/openssl/libssl/libssl.factor b/basis/openssl/libssl/libssl.factor index 520c7175c6..9e2b13159a 100644 --- a/basis/openssl/libssl/libssl.factor +++ b/basis/openssl/libssl/libssl.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2007 Elie CHAFTARI ! Portions copyright (C) 2008 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax combinators kernel system namespaces -assocs parser lexer sequences words quotations math.bitwise -alien.libraries ; +USING: alien alien.c-types alien.syntax combinators kernel +system namespaces assocs parser lexer sequences words +quotations math.bitwise alien.libraries ; IN: openssl.libssl @@ -95,6 +95,17 @@ TYPEDEF: void* SSL* LIBRARY: libssl +! =============================================== +! x509.h +! =============================================== + +TYPEDEF: void* X509_NAME* + +TYPEDEF: void* X509* + +FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ; +FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ; + ! =============================================== ! ssl.h ! =============================================== @@ -258,17 +269,6 @@ CONSTANT: SSL_SESS_CACHE_NO_INTERNAL_STORE HEX: 0200 : SSL_SESS_CACHE_NO_INTERNAL ( -- n ) { SSL_SESS_CACHE_NO_INTERNAL_LOOKUP SSL_SESS_CACHE_NO_INTERNAL_STORE } flags ; inline -! =============================================== -! x509.h -! =============================================== - -TYPEDEF: void* X509_NAME* - -TYPEDEF: void* X509* - -FUNCTION: int X509_NAME_get_text_by_NID ( X509_NAME* name, int nid, void* buf, int len ) ; -FUNCTION: X509_NAME* X509_get_subject_name ( X509* a ) ; - ! =============================================== ! x509_vfy.h ! =============================================== diff --git a/basis/random/mersenne-twister/mersenne-twister.factor b/basis/random/mersenne-twister/mersenne-twister.factor index 3a44066caf..e29f97ef2e 100644 --- a/basis/random/mersenne-twister/mersenne-twister.factor +++ b/basis/random/mersenne-twister/mersenne-twister.factor @@ -2,9 +2,9 @@ ! See http://factorcode.org/license.txt for BSD license. ! mersenne twister based on ! http://www.math.sci.hiroshima-u.ac.jp/~m-mat/MT/MT2002/CODES/mt19937ar.c -USING: kernel math namespaces sequences sequences.private system -init accessors math.ranges random math.bitwise combinators -specialized-arrays fry ; +USING: alien.c-types kernel math namespaces sequences +sequences.private system init accessors math.ranges random +math.bitwise combinators specialized-arrays fry ; SPECIALIZED-ARRAY: uint IN: random.mersenne-twister diff --git a/basis/tools/disassembler/udis/udis.factor b/basis/tools/disassembler/udis/udis.factor index 89bd5f726c..effb2d6f0e 100755 --- a/basis/tools/disassembler/udis/udis.factor +++ b/basis/tools/disassembler/udis/udis.factor @@ -31,7 +31,7 @@ STRUCT: ud { inp_hook void* } { inp_curr uchar } { inp_fill uchar } - { inp_file FILE* } + { inp_file void* } { inp_ctr uchar } { inp_buff uchar* } { inp_buff_end uchar* } @@ -68,7 +68,7 @@ STRUCT: ud { c3 uchar } { inp_cache uchar[256] } { inp_sess uchar[64] } - { itab_entry ud_itab_entry* } ; + { itab_entry void* } ; FUNCTION: void ud_translate_intel ( ud* u ) ; FUNCTION: void ud_translate_att ( ud* u ) ; diff --git a/basis/ui/pixel-formats/pixel-formats.factor b/basis/ui/pixel-formats/pixel-formats.factor index 5dcd9bde9a..abc857c566 100644 --- a/basis/ui/pixel-formats/pixel-formats.factor +++ b/basis/ui/pixel-formats/pixel-formats.factor @@ -1,6 +1,6 @@ -USING: accessors assocs classes destructors functors kernel -lexer math parser sequences specialized-arrays ui.backend -words ; +USING: alien.c-types accessors assocs classes destructors +functors kernel lexer math parser sequences specialized-arrays +ui.backend words ; SPECIALIZED-ARRAY: int IN: ui.pixel-formats diff --git a/basis/unix/bsd/bsd.factor b/basis/unix/bsd/bsd.factor index ebc0b80097..0825e42930 100644 --- a/basis/unix/bsd/bsd.factor +++ b/basis/unix/bsd/bsd.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax classes.struct combinators system -vocabs.loader ; +USING: alien.c-types alien.syntax classes.struct combinators +system unix.types vocabs.loader ; IN: unix CONSTANT: MAXPATHLEN 1024 diff --git a/basis/unix/getfsstat/macosx/macosx.factor b/basis/unix/getfsstat/macosx/macosx.factor index 0db1bb86ad..0b76d048fe 100644 --- a/basis/unix/getfsstat/macosx/macosx.factor +++ b/basis/unix/getfsstat/macosx/macosx.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax ; +USING: alien.c-types alien.syntax unix.statfs.macosx ; IN: unix.getfsstat.macosx CONSTANT: MNT_WAIT 1 ! synchronously wait for I/O to complete CONSTANT: MNT_NOWAIT 2 ! start all I/O, but do not wait for it -FUNCTION: int getfsstat64 ( statfs* buf, int bufsize, int flags ) ; +FUNCTION: int getfsstat64 ( statfs64* buf, int bufsize, int flags ) ; diff --git a/basis/unix/kqueue/kqueue.factor b/basis/unix/kqueue/kqueue.factor index 6c3b9ef2cb..17b653418a 100644 --- a/basis/unix/kqueue/kqueue.factor +++ b/basis/unix/kqueue/kqueue.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax system sequences vocabs.loader words +USING: alien.c-types alien.syntax system sequences vocabs.loader words accessors ; IN: unix.kqueue diff --git a/basis/unix/kqueue/macosx/macosx.factor b/basis/unix/kqueue/macosx/macosx.factor index c30584efab..f0dc8c8f5e 100644 --- a/basis/unix/kqueue/macosx/macosx.factor +++ b/basis/unix/kqueue/macosx/macosx.factor @@ -1,4 +1,4 @@ -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.time ; IN: unix.kqueue STRUCT: kevent diff --git a/basis/unix/process/process.factor b/basis/unix/process/process.factor index 2912f8b744..ab10aef3ea 100644 --- a/basis/unix/process/process.factor +++ b/basis/unix/process/process.factor @@ -1,6 +1,6 @@ USING: kernel alien.c-types alien.data alien.strings sequences math alien.syntax unix namespaces continuations threads assocs -io.backend.unix io.encodings.utf8 unix.utilities fry ; +io.backend.unix io.encodings.utf8 unix.types unix.utilities fry ; IN: unix.process ! Low-level Unix process launching utilities. These are used diff --git a/basis/unix/stat/macosx/macosx.factor b/basis/unix/stat/macosx/macosx.factor index afab727ddb..a2104dcb33 100644 --- a/basis/unix/stat/macosx/macosx.factor +++ b/basis/unix/stat/macosx/macosx.factor @@ -1,8 +1,8 @@ USING: alien.c-types arrays accessors combinators classes.struct -alien.syntax ; +alien.syntax unix.time unix.types ; IN: unix.stat -! Mac OS X ppc +! Mac OS X ! stat64 structure STRUCT: stat diff --git a/basis/unix/statvfs/macosx/macosx.factor b/basis/unix/statvfs/macosx/macosx.factor index 3b1fe71a6a..3fe44a28d0 100644 --- a/basis/unix/statvfs/macosx/macosx.factor +++ b/basis/unix/statvfs/macosx/macosx.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax classes.struct ; +USING: alien.c-types alien.syntax classes.struct unix.types ; IN: unix.statvfs.macosx STRUCT: statvfs diff --git a/basis/unix/types/types.factor b/basis/unix/types/types.factor index 4ca2c4368a..6fdaeef8cf 100644 --- a/basis/unix/types/types.factor +++ b/basis/unix/types/types.factor @@ -1,4 +1,4 @@ -USING: kernel system alien.syntax combinators vocabs.loader ; +USING: kernel system alien.c-types alien.syntax combinators vocabs.loader ; IN: unix.types TYPEDEF: char int8_t @@ -37,6 +37,12 @@ TYPEDEF: fsfilcnt_t __fsfilcnt_t TYPEDEF: __uint64_t rlim_t TYPEDEF: uint32_t id_t +TYPEDEF: void* DIR* +TYPEDEF: void* FILE* +TYPEDEF: void* rlimit* +TYPEDEF: void* rusage* +TYPEDEF: void* sockaddr* + os { { linux [ "unix.types.linux" require ] } { macosx [ "unix.types.macosx" require ] } @@ -45,3 +51,4 @@ os { { netbsd [ "unix.types.netbsd" require ] } { winnt [ ] } } case + diff --git a/basis/unix/unix.factor b/basis/unix/unix.factor index 59a3331354..fa61e9041a 100644 --- a/basis/unix/unix.factor +++ b/basis/unix/unix.factor @@ -5,7 +5,7 @@ USING: alien alien.c-types alien.syntax kernel libc sequences continuations byte-arrays strings math namespaces system combinators vocabs.loader accessors stack-checker macros locals generalizations unix.types -io vocabs classes.struct ; +io vocabs classes.struct unix.time ; IN: unix CONSTANT: PROT_NONE 0 @@ -35,12 +35,6 @@ CONSTANT: DT_LNK 10 CONSTANT: DT_SOCK 12 CONSTANT: DT_WHT 14 -STRUCT: group - { gr_name char* } - { gr_passwd char* } - { gr_gid int } - { gr_mem char** } ; - LIBRARY: libc FUNCTION: char* strerror ( int errno ) ; @@ -68,6 +62,26 @@ MACRO:: unix-system-call ( quot -- ) ] ] ; +<< + +{ + { [ os linux? ] [ "unix.linux" require ] } + { [ os bsd? ] [ "unix.bsd" require ] } + { [ os solaris? ] [ "unix.solaris" require ] } +} cond + +"debugger" vocab [ + "unix.debugger" require +] when + +>> + +STRUCT: group + { gr_name char* } + { gr_passwd char* } + { gr_gid int } + { gr_mem char** } ; + FUNCTION: int accept ( int s, void* sockaddr, socklen_t* socklen ) ; FUNCTION: int bind ( int s, void* name, socklen_t namelen ) ; FUNCTION: int chdir ( char* path ) ; @@ -86,7 +100,7 @@ FUNCTION: int dup2 ( int oldd, int newd ) ; ! FUNCTION: int dup ( int oldd ) ; : _exit ( status -- * ) #! We throw to give this a terminating stack effect. - "int" f "_exit" { "int" } alien-invoke "Exit failed" throw ; + int f "_exit" { int } alien-invoke "Exit failed" throw ; FUNCTION: void endpwent ( ) ; FUNCTION: int fchdir ( int fd ) ; FUNCTION: int fchown ( int fd, uid_t owner, gid_t group ) ; @@ -207,12 +221,3 @@ FUNCTION: int utimes ( char* path, timeval[2] times ) ; FUNCTION: ssize_t write ( int fd, void* buf, size_t nbytes ) ; -{ - { [ os linux? ] [ "unix.linux" require ] } - { [ os bsd? ] [ "unix.bsd" require ] } - { [ os solaris? ] [ "unix.solaris" require ] } -} cond - -"debugger" vocab [ - "unix.debugger" require -] when diff --git a/basis/vm/vm.factor b/basis/vm/vm.factor index 3ea501b561..728cbb83d8 100644 --- a/basis/vm/vm.factor +++ b/basis/vm/vm.factor @@ -1,9 +1,10 @@ ! Copyright (C) 2009 Phil Dawes. ! See http://factorcode.org/license.txt for BSD license. -USING: classes.struct alien.syntax ; +USING: classes.struct alien.c-types alien.syntax ; IN: vm TYPEDEF: void* cell +TYPEDEF: void* context* STRUCT: zone { start cell } From 2bc687f0dea470760265cd973906bd2c77eb90bf Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Sep 2009 12:03:23 -0500 Subject: [PATCH 05/17] add some tests for parse-c-type --- basis/alien/parser/parser-tests.factor | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 basis/alien/parser/parser-tests.factor diff --git a/basis/alien/parser/parser-tests.factor b/basis/alien/parser/parser-tests.factor new file mode 100644 index 0000000000..8309de5641 --- /dev/null +++ b/basis/alien/parser/parser-tests.factor @@ -0,0 +1,26 @@ +! (c)2009 Joe Groff bsd license +USING: alien.c-types alien.parser alien.syntax tools.test +vocabs.parser ; +IN: alien.parser.tests + +TYPEDEF: char char2 + +[ int ] [ "int" parse-c-type ] unit-test +[ { int 5 } ] [ "int[5]" parse-c-type ] unit-test +[ { int 5 10 11 } ] [ "int[5][10][11]" parse-c-type ] unit-test +[ void* ] [ "int*" parse-c-type ] unit-test +[ void* ] [ "int**" parse-c-type ] unit-test +[ void* ] [ "int***" parse-c-type ] unit-test +[ void* ] [ "int****" parse-c-type ] unit-test +[ char* ] [ "char*" parse-c-type ] unit-test +[ void* ] [ "char**" parse-c-type ] unit-test +[ void* ] [ "char***" parse-c-type ] unit-test +[ void* ] [ "char****" parse-c-type ] unit-test +[ char2 ] [ "char2" parse-c-type ] unit-test +[ char* ] [ "char2*" parse-c-type ] unit-test + +SYMBOL: not-c-type + +[ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with +[ "not-word" parse-c-type ] [ no-word-error? ] must-fail-with + From c3935b823f4b02c10a14ab1b32194aff31ee2715 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Sep 2009 12:10:50 -0500 Subject: [PATCH 06/17] oops, jumped the gun on one of the alien.parser tests there --- basis/alien/parser/parser-tests.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/basis/alien/parser/parser-tests.factor b/basis/alien/parser/parser-tests.factor index 8309de5641..b9ef08e890 100644 --- a/basis/alien/parser/parser-tests.factor +++ b/basis/alien/parser/parser-tests.factor @@ -1,6 +1,6 @@ ! (c)2009 Joe Groff bsd license -USING: alien.c-types alien.parser alien.syntax tools.test -vocabs.parser ; +USING: accessors alien.c-types alien.parser alien.syntax +tools.test vocabs.parser ; IN: alien.parser.tests TYPEDEF: char char2 @@ -22,5 +22,6 @@ TYPEDEF: char char2 SYMBOL: not-c-type [ "not-c-type" parse-c-type ] [ no-c-type? ] must-fail-with -[ "not-word" parse-c-type ] [ no-word-error? ] must-fail-with +! uncomment this when string C type parsing goes away +! [ "not-word" parse-c-type ] [ error>> no-word-error? ] must-fail-with From 6376adf4fc0700269344c876ca6c8aa322dd2124 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Sep 2009 12:33:23 -0500 Subject: [PATCH 07/17] fix vim syntax highlighting when a word contains square brackets, and add highlighting for STRUCT: --- misc/vim/syntax/factor.vim | 26 ++++++++++++++------------ 1 file changed, 14 insertions(+), 12 deletions(-) diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index 00b4a4e9f7..07e35a9f5e 100644 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -23,7 +23,7 @@ else set iskeyword=!,@,33-35,%,$,38-64,A-Z,91-96,a-z,123-126,128-255 endif -syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple +syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple,factorStruct syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained syn match factorComment /\<#! .*/ contains=factorTodo @@ -89,6 +89,7 @@ syn match factorSymbol /\/ syn region factorSymbols start=/\/ end=/;/ syn region factorConstructor2 start=/\/ end=/\<;\>/ +syn region factorStruct start=/\<\(UNION-STRUCT:\|STRUCT:\)\>/ end=/\<;\>/ syn match factorConstant /\/ syn match factorSingleton /\/ @@ -143,18 +144,18 @@ syn match factorLiteralStackEffect /\<(( .*--.* ))\>/ "adapted from lisp.vim if exists("g:factor_norainbow") - syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL + syn region factorQuotation matchgroup=factorDelimiter start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ matchgroup=factorDelimiter end=/\<\]\>/ contains=ALL else - syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1 - syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2 - syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3 - syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4 - syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5 - syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6 - syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7 - syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8 - syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9 - syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\('\|\$\|\)\[\)\|\[\(let\||\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0 + syn region factorQuotation0 matchgroup=hlLevel0 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation1,factorArray1 + syn region factorQuotation1 contained matchgroup=hlLevel1 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation2,factorArray2 + syn region factorQuotation2 contained matchgroup=hlLevel2 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation3,factorArray3 + syn region factorQuotation3 contained matchgroup=hlLevel3 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation4,factorArray4 + syn region factorQuotation4 contained matchgroup=hlLevel4 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation5,factorArray5 + syn region factorQuotation5 contained matchgroup=hlLevel5 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation6,factorArray6 + syn region factorQuotation6 contained matchgroup=hlLevel6 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation7,factorArray7 + syn region factorQuotation7 contained matchgroup=hlLevel7 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation8,factorArray8 + syn region factorQuotation8 contained matchgroup=hlLevel8 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation9,factorArray9 + syn region factorQuotation9 contained matchgroup=hlLevel9 start=/\<\(\(\('\|\$\|\)\[\)\|\[\(let\||\)\)\>/ end=/\<\]\>/ contains=@factorCluster,factorQuotation0,factorArray0 endif if exists("g:factor_norainbow") @@ -243,6 +244,7 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorForget Define HiLink factorAlien Define HiLink factorTuple Typedef + HiLink factorStruct Typedef if &bg == "dark" hi hlLevel0 ctermfg=red guifg=red1 From c2145c933bad7663af6937997de4079a4046357e Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Sep 2009 13:19:22 -0500 Subject: [PATCH 08/17] software implementations of vector logical ops (vand, vor, vxor, vnot, v, vunordered?, v?) --- basis/math/vectors/vectors.factor | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/basis/math/vectors/vectors.factor b/basis/math/vectors/vectors.factor index a40506f980..fb4c7592d3 100644 --- a/basis/math/vectors/vectors.factor +++ b/basis/math/vectors/vectors.factor @@ -55,11 +55,33 @@ PRIVATE> [ drop call ] } case ; inline +: fp-bitwise-unary ( x seq quot -- z ) + swap element-type { + { c:double [ [ double>bits ] dip call bits>double ] } + { c:float [ [ float>bits ] dip call bits>float ] } + [ drop call ] + } case ; inline + PRIVATE> : vbitand ( u v -- w ) over '[ _ [ bitand ] fp-bitwise-op ] 2map ; : vbitor ( u v -- w ) over '[ _ [ bitor ] fp-bitwise-op ] 2map ; : vbitxor ( u v -- w ) over '[ _ [ bitxor ] fp-bitwise-op ] 2map ; +: vbitnot ( u -- w ) dup '[ _ [ bitnot ] fp-bitwise-unary ] map ; + +: vand ( u v -- w ) [ and ] 2map ; +: vor ( u v -- w ) [ or ] 2map ; +: vxor ( u v -- w ) [ xor ] 2map ; +: vnot ( u -- w ) [ not ] map ; + +: v< ( u v -- w ) [ < ] { } 2map-as ; +: v<= ( u v -- w ) [ <= ] { } 2map-as ; +: v>= ( u v -- w ) [ >= ] { } 2map-as ; +: v> ( u v -- w ) [ > ] { } 2map-as ; +: vunordered? ( u v -- w ) [ unordered? ] { } 2map-as ; +: v= ( u v -- w ) [ = ] { } 2map-as ; + +: v? ( ? u v -- w ) [ ? ] pick 3map-as ; : vlshift ( u n -- w ) '[ _ shift ] map ; : vrshift ( u n -- w ) neg '[ _ shift ] map ; From 02b4503205298eba33bef3855f43d3aef55b5884 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Sep 2009 14:04:39 -0500 Subject: [PATCH 09/17] add vim syntax highlighting for ALIAS:, QUALIFIED:, QUALIFIED-WITH:, and FROM:. fix highlighting for empty comment at end of line --- misc/vim/syntax/factor.vim | 24 ++++++++++-------------- 1 file changed, 10 insertions(+), 14 deletions(-) diff --git a/misc/vim/syntax/factor.vim b/misc/vim/syntax/factor.vim index 07e35a9f5e..138e142eae 100644 --- a/misc/vim/syntax/factor.vim +++ b/misc/vim/syntax/factor.vim @@ -26,8 +26,8 @@ endif syn cluster factorCluster contains=factorComment,factorKeyword,factorRepeat,factorConditional,factorBoolean,factorCompileDirective,factorString,factorSbuf,@factorNumber,@factorNumErr,factorDelimiter,factorChar,factorCharErr,factorBackslash,@factorWordOps,factorAlien,factorTuple,factorStruct syn match factorTodo /\(TODO\|FIXME\|XXX\):\=/ contained -syn match factorComment /\<#! .*/ contains=factorTodo -syn match factorComment /\.*/ contains=factorTodo +syn match factorComment /\.*/ contains=factorTodo syn cluster factorDefnContents contains=@factorCluster,factorStackEffect,factorLiteralStackEffect,factorArray0,factorQuotation0 @@ -84,6 +84,9 @@ syn match factorChar /\/ syn match factorBackslash /\<\\\>\s\+\S\+\>/ syn region factorUsing start=/\/ end=/;/ +syn match factorQualified /\/ +syn match factorQualifiedWith /\/ +syn region factorFrom start=/\/ end=/;/ syn region factorSingletons start=/\/ end=/;/ syn match factorSymbol /\/ syn region factorSymbols start=/\/ end=/;/ @@ -92,6 +95,7 @@ syn region factorTuple start=/\/ end=/\<;\>/ syn region factorStruct start=/\<\(UNION-STRUCT:\|STRUCT:\)\>/ end=/\<;\>/ syn match factorConstant /\/ +syn match factorAlias /\/ syn match factorSingleton /\/ syn match factorPostpone /\/ syn match factorDefer /\/ @@ -103,8 +107,7 @@ syn match factorMain /\/ syn match factorConstructor /\/ syn match factorAlien /\/ -syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor - +syn cluster factorWordOps contains=factorConstant,factorAlias,factorSingleton,factorSingletons,factorSymbol,factorSymbols,factorPostpone,factorDefer,factorForget,factorMixin,factorInstance,factorHook,factorMain,factorConstructor "TODO: "misc: @@ -114,20 +117,10 @@ syn cluster factorWordOps contains=factorSymbol,factorPostpone,factorDefer " PRIMITIVE: "C interface: -" FIELD: -" BEGIN-STRUCT: " C-ENUM: " FUNCTION: -" END-STRUCT -" DLL" " TYPEDEF: " LIBRARY: -" C-UNION: -"QUALIFIED: -"QUALIFIED-WITH: -"FROM: -"ALIAS: -"! POSTPONE: " "#\ " syn region factorString start=/"/ skip=/\\"/ end=/"/ oneline @@ -223,6 +216,9 @@ if version >= 508 || !exists("did_factor_syn_inits") HiLink factorFloat Float HiLink factorInt Number HiLink factorUsing Include + HiLink factorQualified Include + HiLink factorQualifiedWith Include + HiLink factorFrom Include HiLink factorUse Include HiLink factorUnuse Include HiLink factorIn Define From 630e5ecc3bb8022e7c01bb8761e856026aa13c01 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Sep 2009 15:11:21 -0500 Subject: [PATCH 10/17] update vocabs so a load-all on macosx works without parsing c-type strings --- basis/compression/zlib/ffi/ffi.factor | 3 +- basis/db/postgresql/ffi/ffi.factor | 4 +- basis/glib/glib.factor | 10 +- basis/images/bitmap/loading/loading.factor | 2 +- basis/iokit/hid/hid.factor | 7 +- basis/math/blas/matrices/matrices.factor | 15 +- basis/math/blas/vectors/vectors.factor | 10 +- basis/math/floats/env/x86/x86.factor | 8 +- basis/pango/cairo/cairo.factor | 158 +++++++++++++++++- basis/pango/fonts/fonts.factor | 11 +- basis/pango/layouts/layouts.factor | 152 +---------------- basis/pango/pango.factor | 5 +- basis/ui/pens/gradient/gradient.factor | 1 + basis/ui/pens/polygon/polygon.factor | 8 +- basis/x11/constants/constants.factor | 4 +- basis/x11/xlib/xlib.factor | 8 +- extra/benchmark/dawes/dawes.factor | 3 +- extra/benchmark/dispatch2/dispatch2.factor | 4 +- extra/benchmark/dispatch3/dispatch3.factor | 2 +- extra/benchmark/fasta/fasta.factor | 6 +- extra/benchmark/nbody-simd/nbody-simd.factor | 6 +- extra/benchmark/nbody/nbody.factor | 7 +- extra/benchmark/raytracer/raytracer.factor | 10 +- .../spectral-norm/spectral-norm.factor | 5 +- .../struct-arrays/struct-arrays.factor | 1 + extra/freetype/freetype.factor | 8 +- extra/gpu/render/render-docs.factor | 10 +- extra/gpu/util/util.factor | 1 + extra/gpu/util/wasd/wasd.factor | 1 + extra/grid-meshes/grid-meshes.factor | 1 + .../images/normalization/normalization.factor | 6 +- extra/jamshred/player/player.factor | 3 +- extra/jamshred/tunnel/tunnel.factor | 1 + .../native-thread-test.factor | 7 +- extra/nurbs/nurbs.factor | 7 +- extra/ogg/ogg.factor | 2 +- extra/openal/macosx/macosx.factor | 2 +- extra/openal/other/other.factor | 2 +- extra/opengl/glu/glu.factor | 6 +- extra/terrain/terrain.factor | 1 + extra/tokyo/alien/tchdb/tchdb.factor | 1 + extra/tokyo/alien/tctdb/tctdb.factor | 1 + 42 files changed, 278 insertions(+), 232 deletions(-) diff --git a/basis/compression/zlib/ffi/ffi.factor b/basis/compression/zlib/ffi/ffi.factor index a472f9a2fe..553b55cf6e 100755 --- a/basis/compression/zlib/ffi/ffi.factor +++ b/basis/compression/zlib/ffi/ffi.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax combinators system alien.libraries ; +USING: alien alien.c-types alien.syntax combinators system +alien.libraries ; IN: compression.zlib.ffi << "zlib" { diff --git a/basis/db/postgresql/ffi/ffi.factor b/basis/db/postgresql/ffi/ffi.factor index 1e7f4d5b82..88618c6212 100644 --- a/basis/db/postgresql/ffi/ffi.factor +++ b/basis/db/postgresql/ffi/ffi.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007, 2008 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. ! tested on debian linux with postgresql 8.1 -USING: alien alien.syntax combinators system alien.libraries ; +USING: alien alien.c-types alien.syntax combinators system +alien.libraries ; IN: db.postgresql.ffi << "postgresql" { @@ -69,6 +70,7 @@ TYPEDEF: void* PGnotify* TYPEDEF: void* PQArgBlock* TYPEDEF: void* PQprintOpt* TYPEDEF: void* SSL* +TYPEDEF: void* FILE* LIBRARY: postgresql diff --git a/basis/glib/glib.factor b/basis/glib/glib.factor index ca481cb900..157a426e19 100755 --- a/basis/glib/glib.factor +++ b/basis/glib/glib.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008 Matthew Willis. ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license -USING: alien alien.syntax alien.destructors combinators system -alien.libraries ; +USING: alien alien.c-types alien.syntax alien.destructors +combinators system alien.libraries ; IN: glib << @@ -27,12 +27,10 @@ TYPEDEF: void* gpointer TYPEDEF: int gint TYPEDEF: bool gboolean -FUNCTION: void -g_free ( gpointer mem ) ; +FUNCTION: void g_free ( gpointer mem ) ; LIBRARY: gobject -FUNCTION: void -g_object_unref ( gpointer object ) ; +FUNCTION: void g_object_unref ( gpointer object ) ; DESTRUCTOR: g_object_unref diff --git a/basis/images/bitmap/loading/loading.factor b/basis/images/bitmap/loading/loading.factor index 823cfcd03a..91e0cb882d 100644 --- a/basis/images/bitmap/loading/loading.factor +++ b/basis/images/bitmap/loading/loading.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays byte-arrays combinators +USING: accessors alien.c-types arrays byte-arrays combinators compression.run-length fry grouping images images.loader io io.binary io.encodings.8-bit io.encodings.binary io.encodings.string io.streams.limited kernel math math.bitwise diff --git a/basis/iokit/hid/hid.factor b/basis/iokit/hid/hid.factor index a1a4b942b7..b3894d7b49 100644 --- a/basis/iokit/hid/hid.factor +++ b/basis/iokit/hid/hid.factor @@ -1,6 +1,7 @@ -USING: iokit alien alien.syntax alien.c-types kernel -system core-foundation core-foundation.data -core-foundation.dictionaries ; +USING: iokit alien alien.syntax alien.c-types kernel system +core-foundation core-foundation.arrays core-foundation.data +core-foundation.dictionaries core-foundation.run-loop +core-foundation.strings core-foundation.time ; IN: iokit.hid CONSTANT: kIOHIDDeviceKey "IOHIDDevice" diff --git a/basis/math/blas/matrices/matrices.factor b/basis/math/blas/matrices/matrices.factor index aa9681bb2e..0a6fc147ad 100755 --- a/basis/math/blas/matrices/matrices.factor +++ b/basis/math/blas/matrices/matrices.factor @@ -1,10 +1,11 @@ -USING: accessors alien alien.c-types alien.data arrays -byte-arrays combinators combinators.short-circuit fry -kernel locals macros math math.blas.ffi math.blas.vectors -math.blas.vectors.private math.complex math.functions -math.order functors words sequences sequences.merged -sequences.private shuffle parser prettyprint.backend -prettyprint.custom ascii specialized-arrays ; +USING: accessors alien alien.c-types alien.complex +alien.data arrays byte-arrays combinators +combinators.short-circuit fry kernel locals macros math +math.blas.ffi math.blas.vectors math.blas.vectors.private +math.complex math.functions math.order functors words +sequences sequences.merged sequences.private shuffle +parser prettyprint.backend prettyprint.custom ascii +specialized-arrays ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: double diff --git a/basis/math/blas/vectors/vectors.factor b/basis/math/blas/vectors/vectors.factor index 20ee7925b0..8d057de720 100755 --- a/basis/math/blas/vectors/vectors.factor +++ b/basis/math/blas/vectors/vectors.factor @@ -1,8 +1,8 @@ -USING: accessors alien alien.c-types arrays ascii byte-arrays combinators -combinators.short-circuit fry kernel math math.blas.ffi -math.complex math.functions math.order sequences sequences.private -functors words locals parser prettyprint.backend prettyprint.custom -specialized-arrays ; +USING: accessors alien alien.c-types alien.complex arrays ascii +byte-arrays combinators combinators.short-circuit fry kernel +math math.blas.ffi math.complex math.functions math.order +sequences sequences.private functors words locals parser +prettyprint.backend prettyprint.custom specialized-arrays ; FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float SPECIALIZED-ARRAY: double diff --git a/basis/math/floats/env/x86/x86.factor b/basis/math/floats/env/x86/x86.factor index e9120567aa..2b73628b4c 100644 --- a/basis/math/floats/env/x86/x86.factor +++ b/basis/math/floats/env/x86/x86.factor @@ -1,7 +1,7 @@ -USING: accessors alien.syntax arrays assocs biassocs -classes.struct combinators cpu.x86.features kernel literals -math math.bitwise math.floats.env math.floats.env.private -system ; +USING: accessors alien.c-types alien.syntax arrays assocs +biassocs classes.struct combinators cpu.x86.features kernel +literals math math.bitwise math.floats.env +math.floats.env.private system ; IN: math.floats.env.x86 STRUCT: sse-env diff --git a/basis/pango/cairo/cairo.factor b/basis/pango/cairo/cairo.factor index 45b7a9cb31..2ad730ee6e 100644 --- a/basis/pango/cairo/cairo.factor +++ b/basis/pango/cairo/cairo.factor @@ -3,8 +3,12 @@ ! See http://factorcode.org/license.txt for BSD license. ! ! pangocairo bindings, from pango/pangocairo.h -USING: alien alien.syntax combinators system cairo.ffi -alien.libraries ; +USING: arrays sequences alien alien.c-types alien.destructors +alien.libraries alien.syntax math math.functions math.vectors +destructors combinators colors fonts accessors assocs namespaces +kernel pango pango.fonts pango.layouts glib unicode.data images +cache init system math.rectangles fry memoize io.encodings.utf8 +classes.struct cairo cairo.ffi ; IN: pango.cairo << { @@ -15,6 +19,9 @@ IN: pango.cairo LIBRARY: pangocairo +TYPEDEF: void* PangoCairoFontMap* +TYPEDEF: void* PangoCairoFont* + FUNCTION: PangoFontMap* pango_cairo_font_map_new ( ) ; @@ -87,3 +94,150 @@ pango_cairo_layout_path ( cairo_t* cr, PangoLayout* layout ) ; FUNCTION: void pango_cairo_error_underline_path ( cairo_t* cr, double x, double y, double width, double height ) ; + +TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ; + +SYMBOL: dpi + +72 dpi set-global + +: set-layout-font ( font layout -- ) + swap cache-font-description pango_layout_set_font_description ; + +: set-layout-text ( str layout -- ) + #! Replace nulls with something else since Pango uses null-terminated + #! strings + swap -1 pango_layout_set_text ; + +: layout-extents ( layout -- ink-rect logical-rect ) + PangoRectangle + PangoRectangle + [ pango_layout_get_extents ] 2keep + [ PangoRectangle>rect ] bi@ ; + +: layout-baseline ( layout -- baseline ) + pango_layout_get_iter &pango_layout_iter_free + pango_layout_iter_get_baseline + pango>float ; + +: set-foreground ( cr font -- ) + foreground>> set-source-color ; + +: fill-background ( cr font dim -- ) + [ background>> set-source-color ] + [ [ { 0 0 } ] dip fill-rect ] bi-curry* bi ; + +: rect-translate-x ( rect x -- rect' ) + '[ _ 0 2array v- ] change-loc ; + +: first-line ( layout -- line ) + layout>> 0 pango_layout_get_line_readonly ; + +: line-offset>x ( layout n -- x ) + #! n is an index into the UTF8 encoding of the text + [ drop first-line ] [ swap string>> >utf8-index ] 2bi + 0 0 [ pango_layout_line_index_to_x ] keep + *int pango>float ; + +: x>line-offset ( layout x -- n ) + #! n is an index into the UTF8 encoding of the text + [ + [ first-line ] dip + float>pango 0 0 + [ pango_layout_line_x_to_index drop ] 2keep + [ *int ] bi@ swap + ] [ drop string>> ] 2bi utf8-index> + ; + +: selection-start/end ( selection -- start end ) + selection>> [ start>> ] [ end>> ] bi ; + +: selection-rect ( layout -- rect ) + [ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi + [ drop nip 0 2array ] [ swap - swap second 2array ] 3bi ; + +: fill-selection-background ( cr layout -- ) + dup selection>> [ + [ selection>> color>> set-source-color ] + [ + [ selection-rect ] [ ink-rect>> loc>> first ] bi + rect-translate-x + fill-rect + ] 2bi + ] [ 2drop ] if ; + +: text-position ( layout -- loc ) + [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ; + +: set-text-position ( cr loc -- ) + first2 cairo_move_to ; + +: draw-layout ( layout -- image ) + dup ink-rect>> dim>> [ >fixnum ] map [ + swap { + [ layout>> pango_cairo_update_layout ] + [ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ] + [ fill-selection-background ] + [ text-position set-text-position ] + [ font>> set-foreground ] + [ layout>> pango_cairo_show_layout ] + } 2cleave + ] make-bitmap-image ; + +: escape-nulls ( str -- str' ) + { { 0 CHAR: zero-width-no-break-space } } substitute ; + +: unpack-selection ( layout string/selection -- layout ) + dup selection? [ + [ string>> escape-nulls >>string ] [ >>selection ] bi + ] [ escape-nulls >>string ] if ; inline + +: set-layout-resolution ( layout -- ) + pango_layout_get_context dpi get pango_cairo_context_set_resolution ; + +: ( text font -- layout ) + dummy-cairo pango_cairo_create_layout |g_object_unref + [ set-layout-resolution ] keep + [ set-layout-font ] keep + [ set-layout-text ] keep ; + +: glyph-height ( font string -- y ) + swap &g_object_unref layout-extents drop dim>> second ; + +MEMO: missing-font-metrics ( font -- metrics ) + #! Pango doesn't provide x-height and cap-height but Core Text does, so we + #! simulate them on Pango. + [ + [ metrics new ] dip + [ "x" glyph-height >>x-height ] + [ "Y" glyph-height >>cap-height ] bi + ] with-destructors ; + +: layout-metrics ( layout -- metrics ) + dup font>> missing-font-metrics clone + swap + [ layout>> layout-baseline >>ascent ] + [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi + dup [ height>> ] [ ascent>> ] bi - >>descent ; + +: ( font string -- line ) + [ + layout new-disposable + swap unpack-selection + swap >>font + dup [ string>> ] [ font>> ] bi >>layout + dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi* + dup layout-metrics >>metrics + dup draw-layout >>image + ] with-destructors ; + +M: layout dispose* layout>> g_object_unref ; + +SYMBOL: cached-layouts + +: cached-layout ( font string -- layout ) + cached-layouts get [ ] 2cache ; + +: cached-line ( font string -- line ) + cached-layout layout>> first-line ; + +[ cached-layouts set-global ] "pango.cairo" add-init-hook diff --git a/basis/pango/fonts/fonts.factor b/basis/pango/fonts/fonts.factor index abfc086820..eb3e2208b1 100644 --- a/basis/pango/fonts/fonts.factor +++ b/basis/pango/fonts/fonts.factor @@ -15,6 +15,15 @@ PANGO_STYLE_OBLIQUE PANGO_STYLE_ITALIC ; TYPEDEF: int PangoWeight +TYPEDEF: void* PangoFont* +TYPEDEF: void* PangoFontFamily* +TYPEDEF: void* PangoFontFace* +TYPEDEF: void* PangoFontMap* +TYPEDEF: void* PangoFontMetrics* +TYPEDEF: void* PangoFontDescription* +TYPEDEF: void* PangoGlyphString* +TYPEDEF: void* PangoLanguage* + CONSTANT: PANGO_WEIGHT_THIN 100 CONSTANT: PANGO_WEIGHT_ULTRALIGHT 200 CONSTANT: PANGO_WEIGHT_LIGHT 300 @@ -102,4 +111,4 @@ MEMO: (cache-font-description) ( font -- description ) : cache-font-description ( font -- description ) strip-font-colors (cache-font-description) ; -[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-init-hook \ No newline at end of file +[ \ (cache-font-description) reset-memoized ] "pango.fonts" add-init-hook diff --git a/basis/pango/layouts/layouts.factor b/basis/pango/layouts/layouts.factor index 7a7bd86aea..a03d26fb67 100644 --- a/basis/pango/layouts/layouts.factor +++ b/basis/pango/layouts/layouts.factor @@ -4,12 +4,16 @@ USING: arrays sequences alien alien.c-types alien.destructors alien.syntax math math.functions math.vectors destructors combinators colors fonts accessors assocs namespaces kernel pango pango.fonts -pango.cairo cairo cairo.ffi glib unicode.data images cache init +glib unicode.data images cache init math.rectangles fry memoize io.encodings.utf8 classes.struct ; IN: pango.layouts LIBRARY: pango +TYPEDEF: void* PangoLayout* +TYPEDEF: void* PangoLayoutIter* +TYPEDEF: void* PangoLayoutLine* + FUNCTION: PangoLayout* pango_layout_new ( PangoContext* context ) ; @@ -60,149 +64,3 @@ pango_layout_iter_free ( PangoLayoutIter* iter ) ; DESTRUCTOR: pango_layout_iter_free -TUPLE: layout < disposable font string selection layout metrics ink-rect logical-rect image ; - -SYMBOL: dpi - -72 dpi set-global - -: set-layout-font ( font layout -- ) - swap cache-font-description pango_layout_set_font_description ; - -: set-layout-text ( str layout -- ) - #! Replace nulls with something else since Pango uses null-terminated - #! strings - swap -1 pango_layout_set_text ; - -: set-layout-resolution ( layout -- ) - pango_layout_get_context dpi get pango_cairo_context_set_resolution ; - -: ( text font -- layout ) - dummy-cairo pango_cairo_create_layout |g_object_unref - [ set-layout-resolution ] keep - [ set-layout-font ] keep - [ set-layout-text ] keep ; - -: layout-extents ( layout -- ink-rect logical-rect ) - PangoRectangle - PangoRectangle - [ pango_layout_get_extents ] 2keep - [ PangoRectangle>rect ] bi@ ; - -: glyph-height ( font string -- y ) - swap &g_object_unref layout-extents drop dim>> second ; - -MEMO: missing-font-metrics ( font -- metrics ) - #! Pango doesn't provide x-height and cap-height but Core Text does, so we - #! simulate them on Pango. - [ - [ metrics new ] dip - [ "x" glyph-height >>x-height ] - [ "Y" glyph-height >>cap-height ] bi - ] with-destructors ; - -: layout-baseline ( layout -- baseline ) - pango_layout_get_iter &pango_layout_iter_free - pango_layout_iter_get_baseline - pango>float ; - -: set-foreground ( cr font -- ) - foreground>> set-source-color ; - -: fill-background ( cr font dim -- ) - [ background>> set-source-color ] - [ [ { 0 0 } ] dip fill-rect ] bi-curry* bi ; - -: rect-translate-x ( rect x -- rect' ) - '[ _ 0 2array v- ] change-loc ; - -: first-line ( layout -- line ) - layout>> 0 pango_layout_get_line_readonly ; - -: line-offset>x ( layout n -- x ) - #! n is an index into the UTF8 encoding of the text - [ drop first-line ] [ swap string>> >utf8-index ] 2bi - 0 0 [ pango_layout_line_index_to_x ] keep - *int pango>float ; - -: x>line-offset ( layout x -- n ) - #! n is an index into the UTF8 encoding of the text - [ - [ first-line ] dip - float>pango 0 0 - [ pango_layout_line_x_to_index drop ] 2keep - [ *int ] bi@ swap - ] [ drop string>> ] 2bi utf8-index> + ; - -: selection-start/end ( selection -- start end ) - selection>> [ start>> ] [ end>> ] bi ; - -: selection-rect ( layout -- rect ) - [ ink-rect>> dim>> ] [ ] [ selection-start/end ] tri [ line-offset>x ] bi-curry@ bi - [ drop nip 0 2array ] [ swap - swap second 2array ] 3bi ; - -: fill-selection-background ( cr layout -- ) - dup selection>> [ - [ selection>> color>> set-source-color ] - [ - [ selection-rect ] [ ink-rect>> loc>> first ] bi - rect-translate-x - fill-rect - ] 2bi - ] [ 2drop ] if ; - -: text-position ( layout -- loc ) - [ logical-rect>> ] [ ink-rect>> ] bi [ loc>> ] bi@ v- ; - -: set-text-position ( cr loc -- ) - first2 cairo_move_to ; - -: layout-metrics ( layout -- metrics ) - dup font>> missing-font-metrics clone - swap - [ layout>> layout-baseline >>ascent ] - [ logical-rect>> dim>> [ first >>width ] [ second >>height ] bi ] bi - dup [ height>> ] [ ascent>> ] bi - >>descent ; - -: draw-layout ( layout -- image ) - dup ink-rect>> dim>> [ >fixnum ] map [ - swap { - [ layout>> pango_cairo_update_layout ] - [ [ font>> ] [ ink-rect>> dim>> ] bi fill-background ] - [ fill-selection-background ] - [ text-position set-text-position ] - [ font>> set-foreground ] - [ layout>> pango_cairo_show_layout ] - } 2cleave - ] make-bitmap-image ; - -: escape-nulls ( str -- str' ) - { { 0 CHAR: zero-width-no-break-space } } substitute ; - -: unpack-selection ( layout string/selection -- layout ) - dup selection? [ - [ string>> escape-nulls >>string ] [ >>selection ] bi - ] [ escape-nulls >>string ] if ; inline - -: ( font string -- line ) - [ - layout new-disposable - swap unpack-selection - swap >>font - dup [ string>> ] [ font>> ] bi >>layout - dup layout>> layout-extents [ >>ink-rect ] [ >>logical-rect ] bi* - dup layout-metrics >>metrics - dup draw-layout >>image - ] with-destructors ; - -M: layout dispose* layout>> g_object_unref ; - -SYMBOL: cached-layouts - -: cached-layout ( font string -- layout ) - cached-layouts get [ ] 2cache ; - -: cached-line ( font string -- line ) - cached-layout layout>> first-line ; - -[ cached-layouts set-global ] "pango.layouts" add-init-hook diff --git a/basis/pango/pango.factor b/basis/pango/pango.factor index 11e15ae951..03134ed787 100644 --- a/basis/pango/pango.factor +++ b/basis/pango/pango.factor @@ -23,8 +23,9 @@ CONSTANT: PANGO_SCALE 1024 : pango>float ( n -- x ) PANGO_SCALE /f ; inline : float>pango ( x -- n ) PANGO_SCALE * >integer ; inline -FUNCTION: PangoContext* -pango_context_new ( ) ; +TYPEDEF: void* PangoContext* + +FUNCTION: PangoContext* pango_context_new ( ) ; STRUCT: PangoRectangle { x int } diff --git a/basis/ui/pens/gradient/gradient.factor b/basis/ui/pens/gradient/gradient.factor index 53b4357d44..7f7bd02204 100644 --- a/basis/ui/pens/gradient/gradient.factor +++ b/basis/ui/pens/gradient/gradient.factor @@ -3,6 +3,7 @@ USING: kernel accessors math math.vectors locals sequences specialized-arrays colors arrays combinators opengl opengl.gl ui.pens ui.pens.caching ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: ui.pens.gradient diff --git a/basis/ui/pens/polygon/polygon.factor b/basis/ui/pens/polygon/polygon.factor index a39a5cb7cd..c1e1ada61b 100644 --- a/basis/ui/pens/polygon/polygon.factor +++ b/basis/ui/pens/polygon/polygon.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors colors help.markup help.syntax kernel opengl -opengl.gl sequences math.vectors ui.gadgets ui.pens -specialized-arrays ; +USING: accessors alien.c-types colors help.markup help.syntax +kernel opengl opengl.gl sequences math.vectors ui.gadgets +ui.pens specialized-arrays ; SPECIALIZED-ARRAY: float IN: ui.pens.polygon @@ -36,4 +36,4 @@ M: polygon draw-interior : ( color points -- gadget ) [ ] [ { 0 0 } [ vmax ] reduce ] bi - [ ] 2dip [ >>interior ] [ >>dim ] bi* ; \ No newline at end of file + [ ] 2dip [ >>interior ] [ >>dim ] bi* ; diff --git a/basis/x11/constants/constants.factor b/basis/x11/constants/constants.factor index 1fe825d6af..763cddaaf1 100644 --- a/basis/x11/constants/constants.factor +++ b/basis/x11/constants/constants.factor @@ -3,7 +3,7 @@ ! Based on X.h -USING: alien alien.syntax math x11.xlib ; +USING: alien alien.c-types alien.syntax math x11.xlib ; IN: x11.constants TYPEDEF: ulong Mask @@ -406,4 +406,4 @@ CONSTANT: MSBFirst 1 ! * EXTENDED WINDOW MANAGER HINTS ! ***************************************************************** -C-ENUM: _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ; \ No newline at end of file +C-ENUM: _NET_WM_STATE_REMOVE _NET_WM_STATE_ADD _NET_WM_STATE_TOGGLE ; diff --git a/basis/x11/xlib/xlib.factor b/basis/x11/xlib/xlib.factor index 0cd7704cf8..2b90b1bff2 100644 --- a/basis/x11/xlib/xlib.factor +++ b/basis/x11/xlib/xlib.factor @@ -410,10 +410,6 @@ STRUCT: XCharStruct { descent short } { attributes ushort } ; -X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ; -X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; -X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; - STRUCT: XFontStruct { ext_data XExtData* } { fid Font } @@ -432,6 +428,10 @@ STRUCT: XFontStruct { ascent int } { descent int } ; +X-FUNCTION: Font XLoadFont ( Display* display, char* name ) ; +X-FUNCTION: XFontStruct* XQueryFont ( Display* display, XID font_ID ) ; +X-FUNCTION: XFontStruct* XLoadQueryFont ( Display* display, char* name ) ; + X-FUNCTION: int XTextWidth ( XFontStruct* font_struct, char* string, int count ) ; ! 8.6 - Drawing Text diff --git a/extra/benchmark/dawes/dawes.factor b/extra/benchmark/dawes/dawes.factor index ebfa37cdbc..31c202b803 100644 --- a/extra/benchmark/dawes/dawes.factor +++ b/extra/benchmark/dawes/dawes.factor @@ -1,4 +1,5 @@ -USING: sequences kernel math specialized-arrays fry ; +USING: alien.c-types sequences kernel math specialized-arrays +fry ; SPECIALIZED-ARRAY: int IN: benchmark.dawes diff --git a/extra/benchmark/dispatch2/dispatch2.factor b/extra/benchmark/dispatch2/dispatch2.factor index 5dcefdda5a..87848cee9d 100644 --- a/extra/benchmark/dispatch2/dispatch2.factor +++ b/extra/benchmark/dispatch2/dispatch2.factor @@ -1,4 +1,4 @@ -USING: make math sequences splitting grouping +USING: alien.c-types make math sequences splitting grouping kernel columns specialized-arrays bit-arrays ; SPECIALIZED-ARRAY: double IN: benchmark.dispatch2 @@ -29,4 +29,4 @@ IN: benchmark.dispatch2 1000000 sequences [ [ 0 swap nth don't-flush-me ] each ] curry times ; -MAIN: dispatch-test \ No newline at end of file +MAIN: dispatch-test diff --git a/extra/benchmark/dispatch3/dispatch3.factor b/extra/benchmark/dispatch3/dispatch3.factor index 58301b57af..d5b5432f07 100644 --- a/extra/benchmark/dispatch3/dispatch3.factor +++ b/extra/benchmark/dispatch3/dispatch3.factor @@ -1,4 +1,4 @@ -USING: sequences math mirrors splitting grouping +USING: alien.c-types sequences math mirrors splitting grouping kernel make assocs alien.syntax columns specialized-arrays bit-arrays ; SPECIALIZED-ARRAY: double diff --git a/extra/benchmark/fasta/fasta.factor b/extra/benchmark/fasta/fasta.factor index 5b1a50c9e6..1ad769173b 100755 --- a/extra/benchmark/fasta/fasta.factor +++ b/extra/benchmark/fasta/fasta.factor @@ -1,7 +1,7 @@ ! Based on http://shootout.alioth.debian.org/gp4/benchmark.php?test=fasta&lang=java&id=2 -USING: math kernel io io.files locals multiline assocs sequences -sequences.private benchmark.reverse-complement hints -io.encodings.ascii byte-arrays specialized-arrays ; +USING: alien.c-types math kernel io io.files locals multiline +assocs sequences sequences.private benchmark.reverse-complement +hints io.encodings.ascii byte-arrays specialized-arrays ; SPECIALIZED-ARRAY: double IN: benchmark.fasta diff --git a/extra/benchmark/nbody-simd/nbody-simd.factor b/extra/benchmark/nbody-simd/nbody-simd.factor index c47cdf4ee8..6648c52639 100644 --- a/extra/benchmark/nbody-simd/nbody-simd.factor +++ b/extra/benchmark/nbody-simd/nbody-simd.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors fry kernel locals math math.constants -math.functions math.vectors math.vectors.simd prettyprint -combinators.smart sequences hints classes.struct +USING: accessors alien.c-types fry kernel locals math +math.constants math.functions math.vectors math.vectors.simd +prettyprint combinators.smart sequences hints classes.struct specialized-arrays ; SIMD: double IN: benchmark.nbody-simd diff --git a/extra/benchmark/nbody/nbody.factor b/extra/benchmark/nbody/nbody.factor index fc1cbaa12c..c7ffed2bb3 100644 --- a/extra/benchmark/nbody/nbody.factor +++ b/extra/benchmark/nbody/nbody.factor @@ -1,8 +1,9 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors specialized-arrays fry kernel locals math -math.constants math.functions math.vectors prettyprint -combinators.smart sequences hints arrays ; +USING: accessors specialized-arrays fry kernel +locals math math.constants math.functions math.vectors +prettyprint combinators.smart sequences hints arrays ; +FROM: alien.c-types => double ; SPECIALIZED-ARRAY: double IN: benchmark.nbody diff --git a/extra/benchmark/raytracer/raytracer.factor b/extra/benchmark/raytracer/raytracer.factor index 96f345510f..2413e7fd1e 100755 --- a/extra/benchmark/raytracer/raytracer.factor +++ b/extra/benchmark/raytracer/raytracer.factor @@ -1,10 +1,10 @@ ! Factor port of the raytracer benchmark from ! http://www.ffconsultancy.com/free/ray_tracer/languages.html - -USING: arrays accessors specialized-arrays io io.files -io.files.temp io.encodings.binary kernel math math.constants -math.functions math.vectors math.parser make sequences -sequences.private words hints ; +USING: arrays accessors specialized-arrays io +io.files io.files.temp io.encodings.binary kernel math +math.constants math.functions math.vectors math.parser make +sequences sequences.private words hints ; +FROM: alien.c-types => double ; SPECIALIZED-ARRAY: double IN: benchmark.raytracer diff --git a/extra/benchmark/spectral-norm/spectral-norm.factor b/extra/benchmark/spectral-norm/spectral-norm.factor index 41ae5b3578..68efffe083 100644 --- a/extra/benchmark/spectral-norm/spectral-norm.factor +++ b/extra/benchmark/spectral-norm/spectral-norm.factor @@ -1,7 +1,8 @@ ! Factor port of ! http://shootout.alioth.debian.org/gp4/benchmark.php?test=spectralnorm&lang=all -USING: specialized-arrays kernel math math.functions -math.vectors sequences prettyprint words hints locals ; +USING: alien.c-types specialized-arrays kernel math +math.functions math.vectors sequences prettyprint words hints +locals ; SPECIALIZED-ARRAY: double IN: benchmark.spectral-norm diff --git a/extra/benchmark/struct-arrays/struct-arrays.factor b/extra/benchmark/struct-arrays/struct-arrays.factor index 24c3ec965d..942f78a483 100644 --- a/extra/benchmark/struct-arrays/struct-arrays.factor +++ b/extra/benchmark/struct-arrays/struct-arrays.factor @@ -3,6 +3,7 @@ USING: accessors classes.struct combinators.smart fry kernel math math.functions math.order math.parser sequences specialized-arrays io ; +FROM: alien.c-types => float ; IN: benchmark.struct-arrays STRUCT: point { x float } { y float } { z float } ; diff --git a/extra/freetype/freetype.factor b/extra/freetype/freetype.factor index 6644596828..6105381f86 100644 --- a/extra/freetype/freetype.factor +++ b/extra/freetype/freetype.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax kernel system combinators +USING: alien alien.c-types alien.syntax kernel system combinators alien.libraries classes.struct ; IN: freetype @@ -38,8 +38,8 @@ TYPEDEF: long FT_F26Dot6 FUNCTION: FT_Error FT_Init_FreeType ( void* library ) ; ! circular reference between glyph and face -TYPEDEF: void face -TYPEDEF: void glyph +TYPEDEF: void* face* +TYPEDEF: void* glyph* STRUCT: glyph { library void* } @@ -166,6 +166,8 @@ STRUCT: FT_Bitmap { palette_mode char } { palette void* } ; +TYPEDEF: void* FT_Face* + FUNCTION: FT_Error FT_New_Face ( void* library, FT_Char* font, FT_Long index, face* face ) ; FUNCTION: FT_Error FT_New_Memory_Face ( void* library, FT_Byte* file_base, FT_Long file_size, FT_Long face_index, FT_Face* aface ) ; diff --git a/extra/gpu/render/render-docs.factor b/extra/gpu/render/render-docs.factor index 35b529df5f..e34b9b119d 100755 --- a/extra/gpu/render/render-docs.factor +++ b/extra/gpu/render/render-docs.factor @@ -1,9 +1,11 @@ ! (c)2009 Joe Groff bsd license -USING: alien alien.syntax byte-arrays classes gpu.buffers -gpu.framebuffers gpu.shaders gpu.textures help.markup +USING: alien alien.c-types alien.syntax byte-arrays classes +gpu.buffers gpu.framebuffers gpu.shaders gpu.textures help.markup help.syntax images kernel math sequences specialized-arrays strings ; -SPECIALIZED-ARRAY: float +QUALIFIED-WITH: alien.c-types c +QUALIFIED-WITH: math m +SPECIALIZED-ARRAY: c:float SPECIALIZED-ARRAY: int SPECIALIZED-ARRAY: uint SPECIALIZED-ARRAY: ulong @@ -49,7 +51,7 @@ $nl "Uniform parameters are passed from Factor to the shader program through the uniform tuple as follows:" { $list { { $link int-uniform } "s and " { $link uint-uniform } "s take their values from Factor " { $link integer } "s." } -{ { $link float-uniform } "s take their values from Factor " { $link float } "s." } +{ { $link float-uniform } "s take their values from Factor " { $link m:float } "s." } { { $link bool-uniform } "s take their values from Factor " { $link boolean } "s." } { { $link texture-uniform } "s take their values from " { $link texture } " objects." } { "Vector uniforms take their values from Factor " { $link sequence } "s of the corresponding component type." diff --git a/extra/gpu/util/util.factor b/extra/gpu/util/util.factor index 862c94d4b3..1c9c8e629c 100644 --- a/extra/gpu/util/util.factor +++ b/extra/gpu/util/util.factor @@ -1,6 +1,7 @@ ! (c)2009 Joe Groff bsd license USING: gpu.buffers gpu.render gpu.shaders gpu.textures images kernel specialized-arrays ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: gpu.util diff --git a/extra/gpu/util/wasd/wasd.factor b/extra/gpu/util/wasd/wasd.factor index 9145434d90..496735f0db 100644 --- a/extra/gpu/util/wasd/wasd.factor +++ b/extra/gpu/util/wasd/wasd.factor @@ -5,6 +5,7 @@ gpu.render gpu.state kernel literals locals math math.constants math.functions math.matrices math.order math.vectors opengl.gl sequences ui ui.gadgets.worlds specialized-arrays ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: gpu.util.wasd diff --git a/extra/grid-meshes/grid-meshes.factor b/extra/grid-meshes/grid-meshes.factor index 94638de346..4eaa702468 100644 --- a/extra/grid-meshes/grid-meshes.factor +++ b/extra/grid-meshes/grid-meshes.factor @@ -1,6 +1,7 @@ ! (c)2009 Joe Groff bsd license USING: accessors arrays destructors kernel math opengl opengl.gl sequences sequences.product specialized-arrays ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: grid-meshes diff --git a/extra/images/normalization/normalization.factor b/extra/images/normalization/normalization.factor index 8706ac5834..f557e979dd 100755 --- a/extra/images/normalization/normalization.factor +++ b/extra/images/normalization/normalization.factor @@ -1,7 +1,9 @@ ! Copyright (C) 2009 Doug Coleman ! See http://factorcode.org/license.txt for BSD license. -USING: kernel accessors grouping sequences combinators math -byte-arrays fry images half-floats specialized-arrays ; +USING: alien.c-types kernel accessors grouping sequences +combinators math byte-arrays fry images half-floats +specialized-arrays ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: uint SPECIALIZED-ARRAY: ushort SPECIALIZED-ARRAY: float diff --git a/extra/jamshred/player/player.factor b/extra/jamshred/player/player.factor index 536974952e..e4c954d793 100644 --- a/extra/jamshred/player/player.factor +++ b/extra/jamshred/player/player.factor @@ -4,7 +4,8 @@ USING: accessors colors.constants combinators jamshred.log jamshred.oint jamshred.sound jamshred.tunnel kernel locals math math.constants math.order math.ranges math.vectors math.matrices sequences shuffle specialized-arrays strings system ; -SPECIALIZED-ARRAY: float +QUALIFIED-WITH: alien.c-types c +SPECIALIZED-ARRAY: c:float IN: jamshred.player TUPLE: player < oint diff --git a/extra/jamshred/tunnel/tunnel.factor b/extra/jamshred/tunnel/tunnel.factor index 2767444c8f..742f834622 100644 --- a/extra/jamshred/tunnel/tunnel.factor +++ b/extra/jamshred/tunnel/tunnel.factor @@ -5,6 +5,7 @@ kernel literals locals math math.constants math.matrices math.order math.quadratic math.ranges math.vectors random sequences specialized-arrays vectors ; FROM: jamshred.oint => distance ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: jamshred.tunnel diff --git a/extra/native-thread-test/native-thread-test.factor b/extra/native-thread-test/native-thread-test.factor index 16eff168d4..508e590d01 100644 --- a/extra/native-thread-test/native-thread-test.factor +++ b/extra/native-thread-test/native-thread-test.factor @@ -1,5 +1,6 @@ -USING: alien.syntax io io.encodings.utf16n io.encodings.utf8 io.files -kernel namespaces sequences system threads unix.utilities ; +USING: alien.c-types alien.syntax io io.encodings.utf16n +io.encodings.utf8 io.files kernel namespaces sequences system threads +unix.utilities ; IN: native-thread-test FUNCTION: void* start_standalone_factor_in_new_thread ( int argc, char** argv ) ; @@ -22,4 +23,4 @@ M: unix native-string-encoding utf8 ; : testthread ( -- ) "/tmp/hello" utf8 [ "hello!\n" write ] with-file-appender 5000000 sleep ; -MAIN: testthread \ No newline at end of file +MAIN: testthread diff --git a/extra/nurbs/nurbs.factor b/extra/nurbs/nurbs.factor index b8f2f1cb5f..0df063e2c6 100644 --- a/extra/nurbs/nurbs.factor +++ b/extra/nurbs/nurbs.factor @@ -1,7 +1,8 @@ ! (c)2009 Joe Groff bsd license -USING: accessors arrays grouping kernel locals math math.order -math.ranges math.vectors math.vectors.homogeneous sequences -specialized-arrays ; +USING: accessors alien.c-types arrays grouping kernel locals +math math.order math.ranges math.vectors +math.vectors.homogeneous sequences specialized-arrays ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: nurbs diff --git a/extra/ogg/ogg.factor b/extra/ogg/ogg.factor index 6cd6964721..24227167c9 100644 --- a/extra/ogg/ogg.factor +++ b/extra/ogg/ogg.factor @@ -122,7 +122,7 @@ FUNCTION: int ogg_sync_pageout ( ogg-sync-state* oy, ogg-page* og ) ; FUNCTION: int ogg_stream_pagein ( ogg-stream-state* os, ogg-page* og ) ; FUNCTION: int ogg_stream_packetout ( ogg-stream-state* os, ogg-packet* op ) ; FUNCTION: int ogg_stream_packetpeek ( ogg-stream-state* os, ogg-packet* op ) ; -FUNCTION: int ogg_stream_init (ogg-stream-state* os, int serialno ) ; +FUNCTION: int ogg_stream_init ( ogg-stream-state* os, int serialno ) ; FUNCTION: int ogg_stream_clear ( ogg-stream-state* os ) ; FUNCTION: int ogg_stream_reset ( ogg-stream-state* os ) ; FUNCTION: int ogg_stream_reset_serialno ( ogg-stream-state* os, int serialno ) ; diff --git a/extra/openal/macosx/macosx.factor b/extra/openal/macosx/macosx.factor index 81d360eca1..f0a6b928e9 100644 --- a/extra/openal/macosx/macosx.factor +++ b/extra/openal/macosx/macosx.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types kernel alien alien.syntax shuffle -openal.backend namespaces system generalizations ; +openal openal.backend namespaces system generalizations ; IN: openal.macosx LIBRARY: alut diff --git a/extra/openal/other/other.factor b/extra/openal/other/other.factor index 0936c94150..ada8d6b1fb 100644 --- a/extra/openal/other/other.factor +++ b/extra/openal/other/other.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2007 Chris Double. ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types alien.syntax combinators generalizations -kernel openal.backend ; +kernel openal openal.backend ; IN: openal.other LIBRARY: alut diff --git a/extra/opengl/glu/glu.factor b/extra/opengl/glu/glu.factor index a8404bb13a..a62745cb6a 100644 --- a/extra/opengl/glu/glu.factor +++ b/extra/opengl/glu/glu.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Alex Chapman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.libraries alien.syntax kernel sequences words system -combinators ; +USING: alien alien.c-types alien.libraries alien.syntax kernel +sequences words system combinators opengl.gl ; IN: opengl.glu << @@ -268,4 +268,4 @@ FUNCTION: GLint gluUnProject ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdo ! FUNCTION: GLint gluUnProject4 ( GLdouble winX, GLdouble winY, GLdouble winZ, GLdouble clipW, GLdouble* model, GLdouble* proj, GLint* view, GLdouble nearVal, GLdouble farVal, GLdouble* objX, GLdouble* objY, GLdouble* objZ, GLdouble* objW ) ; : gl-look-at ( eye focus up -- ) - [ first3 ] tri@ gluLookAt ; \ No newline at end of file + [ first3 ] tri@ gluLookAt ; diff --git a/extra/terrain/terrain.factor b/extra/terrain/terrain.factor index 95322e423a..050a835422 100644 --- a/extra/terrain/terrain.factor +++ b/extra/terrain/terrain.factor @@ -9,6 +9,7 @@ terrain.generation terrain.shaders ui ui.gadgets ui.gadgets.worlds ui.pixel-formats game-worlds method-chains math.affine-transforms noise ui.gestures combinators.short-circuit destructors grid-meshes ; +FROM: alien.c-types => float ; SPECIALIZED-ARRAY: float IN: terrain diff --git a/extra/tokyo/alien/tchdb/tchdb.factor b/extra/tokyo/alien/tchdb/tchdb.factor index 3793846050..b9503bdab4 100755 --- a/extra/tokyo/alien/tchdb/tchdb.factor +++ b/extra/tokyo/alien/tchdb/tchdb.factor @@ -6,6 +6,7 @@ IN: tokyo.alien.tchdb LIBRARY: tokyocabinet +TYPEDEF: void* TCXSTR* TYPEDEF: void* TCHDB* CONSTANT: HDBFOPEN 1 diff --git a/extra/tokyo/alien/tctdb/tctdb.factor b/extra/tokyo/alien/tctdb/tctdb.factor index e43ed9c765..8373a6aaaa 100755 --- a/extra/tokyo/alien/tctdb/tctdb.factor +++ b/extra/tokyo/alien/tctdb/tctdb.factor @@ -8,6 +8,7 @@ LIBRARY: tokyocabinet TYPEDEF: void* TDBIDX* TYPEDEF: void* TCTDB* +TYPEDEF: void* TCMAP* CONSTANT: TDBFOPEN HDBFOPEN CONSTANT: TDBFFATAL HDBFFATAL From 18cf8c37e1282be2970db4682fb5f6b8dfcc55b0 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Sep 2009 17:18:02 -0500 Subject: [PATCH 11/17] math.vectors.simd: add *-cast words for converting between representations --- basis/math/vectors/simd/functor/functor.factor | 8 ++++++++ basis/math/vectors/simd/simd-docs.factor | 1 + 2 files changed, 9 insertions(+) diff --git a/basis/math/vectors/simd/functor/functor.factor b/basis/math/vectors/simd/functor/functor.factor index c76ed573d5..6ed74caa1f 100644 --- a/basis/math/vectors/simd/functor/functor.factor +++ b/basis/math/vectors/simd/functor/functor.factor @@ -111,6 +111,7 @@ N [ 16 T heap-size /i ] A DEFINES-CLASS ${T}-${N} A-boa DEFINES ${A}-boa A-with DEFINES ${A}-with +A-cast DEFINES ${A}-cast >A DEFINES >${A} A{ DEFINES ${A}{ @@ -170,6 +171,9 @@ SYNTAX: A{ \ } [ >A ] parse-literal ; \ A-boa \ A-rep \ A define-boa-custom-inlining ] when +: A-cast ( simd-array -- simd-array' ) + underlying>> \ A boa ; inline + INSTANCE: A sequence A DEFINES >${A} A{ DEFINES ${A}{ @@ -295,6 +300,9 @@ M: A pprint* pprint-object ; \ A-rep 2 boa-effect \ A-boa set-stack-effect +: A-cast ( simd-array -- simd-array' ) + [ underlying1>> ] [ underlying2>> ] bi \ A boa ; inline + INSTANCE: A sequence : A-vv->v-op ( v1 v2 quot -- v3 ) diff --git a/basis/math/vectors/simd/simd-docs.factor b/basis/math/vectors/simd/simd-docs.factor index 2fdb9ff88c..6dc0f87dd4 100644 --- a/basis/math/vectors/simd/simd-docs.factor +++ b/basis/math/vectors/simd/simd-docs.factor @@ -68,6 +68,7 @@ ARTICLE: "math.vectors.simd.words" "SIMD vector words" { "Word" "Stack effect" "Description" } { { $snippet "type-with" } { $snippet "( x -- simd-array )" } "creates a new instance where all components are set to a single scalar" } { { $snippet "type-boa" } { $snippet "( ... -- simd-array )" } "creates a new instance where components are read from the stack" } + { { $snipept "type-cast" } { $snippet "( simd-array -- simd-array' )" } "creates a new SIMD array where the underlying data is taken from another SIMD array, with no format conversion" } { { $snippet ">type" } { $snippet "( seq -- simd-array )" } "creates a new instance initialized with the elements of an existing sequence, which must have the correct length" } { { $snippet "type{" } { $snippet "type{ elements... }" } "parsing word defining literal syntax for an SIMD vector; the correct number of elements must be given" } } From 232d1d319c16c3e14232905271f1f331e9b3cf6b Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Sep 2009 17:41:18 -0500 Subject: [PATCH 12/17] update alien.c-types tests to use c-type words --- basis/alien/c-types/c-types-tests.factor | 36 ++++++++++++------------ 1 file changed, 18 insertions(+), 18 deletions(-) mode change 100644 => 100755 basis/alien/c-types/c-types-tests.factor diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor old mode 100644 new mode 100755 index a893ffebe8..6c93b81fff --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -1,50 +1,50 @@ USING: alien alien.syntax alien.c-types kernel tools.test sequences system libc alien.strings io.encodings.utf8 -math.constants ; +math.constants classes.struct ; IN: alien.c-types.tests CONSTANT: xyz 123 -[ 492 ] [ { "int" xyz } heap-size ] unit-test +[ 492 ] [ { int xyz } heap-size ] unit-test [ -1 ] [ -1 *char ] unit-test [ -1 ] [ -1 *short ] unit-test [ -1 ] [ -1 *int ] unit-test -C-UNION: foo - "int" - "int" ; +UNION-STRUCT: foo + { a int } + { b int } ; -[ f ] [ "char*" c-type "void*" c-type eq? ] unit-test -[ t ] [ "char**" c-type "void*" c-type eq? ] unit-test +[ f ] [ "char*" parse-c-type c-type void* c-type eq? ] unit-test +[ t ] [ "char**" parse-c-type c-type void* c-type eq? ] unit-test -[ t ] [ "foo" heap-size "int" heap-size = ] unit-test +[ t ] [ foo heap-size int heap-size = ] unit-test TYPEDEF: int MyInt -[ t ] [ "int" c-type "MyInt" c-type eq? ] unit-test -[ t ] [ "void*" c-type "MyInt*" c-type eq? ] unit-test +[ t ] [ int c-type MyInt c-type eq? ] unit-test +[ t ] [ void* c-type "MyInt*" parse-c-type c-type eq? ] unit-test TYPEDEF: char MyChar -[ t ] [ "char" c-type "MyChar" c-type eq? ] unit-test -[ f ] [ "void*" c-type "MyChar*" c-type eq? ] unit-test -[ t ] [ "char*" c-type "MyChar*" c-type eq? ] unit-test +[ t ] [ char c-type MyChar c-type eq? ] unit-test +[ f ] [ void* c-type "MyChar*" parse-c-type c-type eq? ] unit-test +[ t ] [ "char*" parse-c-type c-type "MyChar*" parse-c-type c-type eq? ] unit-test -[ 32 ] [ { "int" 8 } heap-size ] unit-test +[ 32 ] [ { int 8 } heap-size ] unit-test TYPEDEF: char* MyString -[ t ] [ "char*" c-type "MyString" c-type eq? ] unit-test -[ t ] [ "void*" c-type "MyString*" c-type eq? ] unit-test +[ t ] [ char* c-type MyString c-type eq? ] unit-test +[ t ] [ void* c-type "MyString*" parse-c-type c-type eq? ] unit-test TYPEDEF: int* MyIntArray -[ t ] [ "void*" c-type "MyIntArray" c-type eq? ] unit-test +[ t ] [ void* c-type MyIntArray c-type eq? ] unit-test TYPEDEF: uchar* MyLPBYTE -[ t ] [ { char* utf8 } c-type "MyLPBYTE" c-type = ] unit-test +[ t ] [ { char* utf8 } c-type MyLPBYTE c-type = ] unit-test [ 0 B{ 1 2 3 4 } From 91e63c0c6f8d48e5116f82881df9fe738ee31690 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Sep 2009 18:06:30 -0500 Subject: [PATCH 13/17] cpu.x86.32: implement %unary-float-function and %binary-float-function; speeds up partial-sums and struct-arrays benchmarks --- basis/cpu/x86/32/32.factor | 23 +++++++++++++++++++++++ basis/cpu/x86/64/64.factor | 3 --- basis/cpu/x86/x86.factor | 1 + 3 files changed, 24 insertions(+), 3 deletions(-) diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 5f6c0d4696..1a9e833835 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -282,6 +282,29 @@ M: x86.32 %callback-value ( ctype -- ) ! Unbox EAX unbox-return ; +:: float-function-param ( stack-slot dst src -- ) + ! We can clobber dst here since its going to contain the + ! final result + dst src n>> spill@ MOVSD + stack-slot dst MOVSD ; + +: float-function-return ( reg -- ) + ESP [] FSTPL + ESP [] MOVSD + ESP 16 ADD ; + +M:: x86.32 %unary-float-function ( dst src func -- ) + ESP -16 [+] dst src float-function-param + ESP 16 SUB + func f %alien-invoke + dst float-function-return ; + +M:: x86.32 %binary-float-function ( dst src1 src2 func -- ) + ESP -16 [+] dst src1 float-function-param + ESP -8 [+] dst src2 float-function-param + ESP 16 SUB + func f %alien-invoke + dst float-function-return ; M: x86.32 %cleanup ( params -- ) #! a) If we just called an stdcall function in Windows, it diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 562563039e..424fdec5b9 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -249,9 +249,6 @@ M:: x86.64 %call-gc ( gc-root-count temp -- ) ! x86-64. enable-alien-4-intrinsics -! Enable fast calling of libc math functions -enable-float-functions - USE: vocabs.loader { diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index d89e360d09..40a720aa1b 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -989,6 +989,7 @@ enable-fixnum-log2 enable-float-intrinsics enable-fsqrt enable-float-min/max + enable-float-functions install-sse2-check ] when ; From 20621bbbb6c36836aa4b3e9c4405cade5c3e1574 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Sep 2009 18:18:13 -0500 Subject: [PATCH 14/17] add missing USING: to alien.c-types test --- basis/alien/c-types/c-types-tests.factor | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/basis/alien/c-types/c-types-tests.factor b/basis/alien/c-types/c-types-tests.factor index 6c93b81fff..f48ed50a34 100755 --- a/basis/alien/c-types/c-types-tests.factor +++ b/basis/alien/c-types/c-types-tests.factor @@ -1,6 +1,6 @@ -USING: alien alien.syntax alien.c-types kernel tools.test -sequences system libc alien.strings io.encodings.utf8 -math.constants classes.struct ; +USING: alien alien.syntax alien.c-types alien.parser +kernel tools.test sequences system libc alien.strings +io.encodings.utf8 math.constants classes.struct ; IN: alien.c-types.tests CONSTANT: xyz 123 From 4f82861bf349b77b144bc803d1b137aaa050ee89 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Sep 2009 18:19:53 -0500 Subject: [PATCH 15/17] update windows vocabs to load without c-type strings --- basis/opengl/gl/windows/windows.factor | 2 +- basis/windows/advapi32/advapi32.factor | 10 +-- basis/windows/com/com.factor | 96 ++++++++++++++------------ basis/windows/com/syntax/syntax.factor | 42 ++++++----- basis/windows/gdi32/gdi32.factor | 4 +- basis/windows/kernel32/kernel32.factor | 6 +- basis/windows/ole32/ole32.factor | 4 -- basis/windows/shell32/shell32.factor | 4 +- basis/windows/types/types.factor | 20 +++--- basis/windows/user32/user32.factor | 6 +- basis/windows/usp10/usp10.factor | 6 +- 11 files changed, 106 insertions(+), 94 deletions(-) mode change 100644 => 100755 basis/opengl/gl/windows/windows.factor mode change 100644 => 100755 basis/windows/com/com.factor mode change 100644 => 100755 basis/windows/shell32/shell32.factor diff --git a/basis/opengl/gl/windows/windows.factor b/basis/opengl/gl/windows/windows.factor old mode 100644 new mode 100755 index c8a179edf5..5821e3f212 --- a/basis/opengl/gl/windows/windows.factor +++ b/basis/opengl/gl/windows/windows.factor @@ -1,4 +1,4 @@ -USING: alien.syntax kernel windows.types ; +USING: alien.c-types alien.syntax kernel windows.types ; IN: opengl.gl.windows LIBRARY: gl diff --git a/basis/windows/advapi32/advapi32.factor b/basis/windows/advapi32/advapi32.factor index 21f048a00f..fa478b03ed 100755 --- a/basis/windows/advapi32/advapi32.factor +++ b/basis/windows/advapi32/advapi32.factor @@ -1,5 +1,5 @@ -USING: alien.syntax kernel math windows.types windows.kernel32 -math.bitwise classes.struct ; +USING: alien.c-types alien.syntax kernel math windows.types +windows.kernel32 math.bitwise classes.struct ; IN: windows.advapi32 LIBRARY: advapi32 @@ -222,15 +222,15 @@ C-ENUM: SE_WMIGUID_OBJECT SE_REGISTRY_WOW64_32KEY ; -TYPEDEF: TRUSTEE* PTRUSTEE - STRUCT: TRUSTEE - { pMultipleTrustee PTRUSTEE } + { pMultipleTrustee TRUSTEE* } { MultipleTrusteeOperation MULTIPLE_TRUSTEE_OPERATION } { TrusteeForm TRUSTEE_FORM } { TrusteeType TRUSTEE_TYPE } { ptstrName LPTSTR } ; +TYPEDEF: TRUSTEE* PTRUSTEE + STRUCT: EXPLICIT_ACCESS { grfAccessPermissions DWORD } { grfAccessMode ACCESS_MODE } diff --git a/basis/windows/com/com.factor b/basis/windows/com/com.factor old mode 100644 new mode 100755 index e06f5b6071..45a74e2250 --- a/basis/windows/com/com.factor +++ b/basis/windows/com/com.factor @@ -1,45 +1,51 @@ -USING: alien alien.c-types alien.destructors windows.com.syntax -windows.ole32 windows.types continuations kernel alien.syntax -libc destructors accessors alien.data ; -IN: windows.com - -LIBRARY: ole32 - -COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} - HRESULT QueryInterface ( REFGUID iid, void** ppvObject ) - ULONG AddRef ( ) - ULONG Release ( ) ; - -COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046} - HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) - HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) - HRESULT QueryGetData ( FORMATETC* pFormatetc ) - HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut ) - HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease ) - HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc ) - HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection ) - HRESULT DUnadvise ( DWORD pdwConnection ) - HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ; - -COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} - HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) - HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) - HRESULT DragLeave ( ) - HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ; - -: com-query-interface ( interface iid -- interface' ) - [ - "void*" malloc-object &free - [ IUnknown::QueryInterface ole32-error ] keep *void* - ] with-destructors ; - -: com-add-ref ( interface -- interface ) - [ IUnknown::AddRef drop ] keep ; inline - -: com-release ( interface -- ) - IUnknown::Release drop ; inline - -: with-com-interface ( interface quot -- ) - over [ com-release ] curry [ ] cleanup ; inline - -DESTRUCTOR: com-release +USING: alien alien.c-types alien.destructors windows.com.syntax +windows.ole32 windows.types continuations kernel alien.syntax +libc destructors accessors alien.data ; +IN: windows.com + +LIBRARY: ole32 + +COM-INTERFACE: IUnknown f {00000000-0000-0000-C000-000000000046} + HRESULT QueryInterface ( REFGUID iid, void** ppvObject ) + ULONG AddRef ( ) + ULONG Release ( ) ; + +TYPEDEF: void* IAdviseSink* + +COM-INTERFACE: IDataObject IUnknown {0000010E-0000-0000-C000-000000000046} + HRESULT GetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) + HRESULT GetDataHere ( FORMATETC* pFormatetc, STGMEDIUM* pmedium ) + HRESULT QueryGetData ( FORMATETC* pFormatetc ) + HRESULT GetCanonicalFormatEtc ( FORMATETC* pFormatetcIn, FORMATETC* pFormatetcOut ) + HRESULT SetData ( FORMATETC* pFormatetc, STGMEDIUM* pmedium, BOOL fRelease ) + HRESULT EnumFormatEtc ( DWORD dwDirection, IEnumFORMATETC** ppenumFormatetc ) + HRESULT DAdvise ( FORMATETC* pFormatetc, DWORD advf, IAdviseSink* pAdvSink, DWORD* pdwConnection ) + HRESULT DUnadvise ( DWORD pdwConnection ) + HRESULT EnumDAdvise ( IEnumSTATDATA** ppenumAdvise ) ; + +COM-INTERFACE: IDropTarget IUnknown {00000122-0000-0000-C000-000000000046} + HRESULT DragEnter ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) + HRESULT DragOver ( DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) + HRESULT DragLeave ( ) + HRESULT Drop ( IDataObject* pDataObject, DWORD grfKeyState, POINTL pt, DWORD* pdwEffect ) ; + +FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ; +FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ; +FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; + +: com-query-interface ( interface iid -- interface' ) + [ + "void*" malloc-object &free + [ IUnknown::QueryInterface ole32-error ] keep *void* + ] with-destructors ; + +: com-add-ref ( interface -- interface ) + [ IUnknown::AddRef drop ] keep ; inline + +: com-release ( interface -- ) + IUnknown::Release drop ; inline + +: with-com-interface ( interface quot -- ) + over [ com-release ] curry [ ] cleanup ; inline + +DESTRUCTOR: com-release diff --git a/basis/windows/com/syntax/syntax.factor b/basis/windows/com/syntax/syntax.factor index 3cf8b55e39..bbade332cc 100755 --- a/basis/windows/com/syntax/syntax.factor +++ b/basis/windows/com/syntax/syntax.factor @@ -1,8 +1,8 @@ -USING: alien alien.c-types alien.accessors effects kernel -windows.ole32 parser lexer splitting grouping sequences -namespaces assocs quotations generalizations accessors words -macros alien.syntax fry arrays layouts math classes.struct -windows.kernel32 ; +USING: alien alien.c-types alien.accessors alien.parser +effects kernel windows.ole32 parser lexer splitting grouping +sequences namespaces assocs quotations generalizations +accessors words macros alien.syntax fry arrays layouts math +classes.struct windows.kernel32 ; IN: windows.com.syntax com-interface-definition TUPLE: com-function-definition name return parameters ; @@ -25,22 +25,25 @@ SYMBOL: +com-interface-definitions+ [ H{ } +com-interface-definitions+ set-global ] unless +ERROR: no-com-interface interface ; + : find-com-interface-definition ( name -- definition ) - dup "f" = [ drop f ] [ + [ dup +com-interface-definitions+ get-global at* - [ nip ] - [ " COM interface hasn't been defined" prepend throw ] - if - ] if ; + [ nip ] [ drop no-com-interface ] if + ] [ f ] if* ; : save-com-interface-definition ( definition -- ) - dup name>> +com-interface-definitions+ get-global set-at ; + dup word>> +com-interface-definitions+ get-global set-at ; : (parse-com-function) ( tokens -- definition ) [ second ] [ first ] - [ 3 tail [ CHAR: , swap remove ] map 2 group { "void*" "this" } prefix ] - tri + [ + 3 tail [ CHAR: , swap remove ] map + 2 group [ first2 normalize-c-arg 2array ] map + { void* "this" } prefix + ] tri ; : parse-com-functions ( -- functions ) @@ -48,10 +51,11 @@ unless [ (parse-com-function) ] map ; : (iid-word) ( definition -- word ) - name>> "-iid" append create-in ; + word>> name>> "-iid" append create-in ; : (function-word) ( function interface -- word ) - name>> "::" rot name>> 3append create-in ; + swap [ word>> name>> "::" ] [ name>> ] bi* + 3append create-in ; : family-tree ( definition -- definitions ) dup parent>> [ family-tree ] [ { } ] if* @@ -79,7 +83,7 @@ unless : define-words-for-com-interface ( definition -- ) [ [ (iid-word) ] [ iid>> 1quotation ] bi (( -- iid )) define-declared ] - [ name>> "com-interface" swap typedef ] + [ word>> void* swap typedef ] [ dup family-tree-functions [ (define-word-for-function) ] with each-index @@ -89,8 +93,8 @@ unless PRIVATE> SYNTAX: COM-INTERFACE: - scan - scan find-com-interface-definition + CREATE-C-TYPE + scan-object find-com-interface-definition scan string>guid parse-com-functions diff --git a/basis/windows/gdi32/gdi32.factor b/basis/windows/gdi32/gdi32.factor index 5187c3f660..43307cb6ba 100755 --- a/basis/windows/gdi32/gdi32.factor +++ b/basis/windows/gdi32/gdi32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax alien.destructors kernel windows.types -math.bitwise ; +USING: alien alien.c-types alien.syntax alien.destructors +kernel windows.types math.bitwise ; IN: windows.gdi32 CONSTANT: BI_RGB 0 diff --git a/basis/windows/kernel32/kernel32.factor b/basis/windows/kernel32/kernel32.factor index 075b0218b3..bb0a679c01 100755 --- a/basis/windows/kernel32/kernel32.factor +++ b/basis/windows/kernel32/kernel32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax kernel windows.types multiline -classes.struct ; +USING: alien alien.c-types alien.syntax kernel windows.types +multiline classes.struct ; IN: windows.kernel32 CONSTANT: MAX_PATH 260 @@ -543,7 +543,7 @@ STRUCT: DCB TYPEDEF: DCB* PDCB TYPEDEF: DCB* LPDCB -STRUCT: COMM_CONFIG +STRUCT: COMMCONFIG { dwSize DWORD } { wVersion WORD } { wReserved WORD } diff --git a/basis/windows/ole32/ole32.factor b/basis/windows/ole32/ole32.factor index 3bc7f45960..6e90cae89a 100755 --- a/basis/windows/ole32/ole32.factor +++ b/basis/windows/ole32/ole32.factor @@ -111,10 +111,6 @@ CONSTANT: COINIT_SPEED_OVER_MEMORY 8 FUNCTION: HRESULT OleInitialize ( void* reserved ) ; FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ; -FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ; -FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ; -FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ; - : succeeded? ( hresult -- ? ) 0 HEX: 7FFFFFFF between? ; diff --git a/basis/windows/shell32/shell32.factor b/basis/windows/shell32/shell32.factor old mode 100644 new mode 100755 index 6b4e0d797e..bede62c813 --- a/basis/windows/shell32/shell32.factor +++ b/basis/windows/shell32/shell32.factor @@ -3,8 +3,8 @@ USING: alien alien.c-types alien.strings alien.syntax classes.struct combinators io.encodings.utf16n io.files io.pathnames kernel windows.errors windows.com -windows.com.syntax windows.user32 windows.ole32 windows -specialized-arrays ; +windows.com.syntax windows.types windows.user32 +windows.ole32 windows specialized-arrays ; SPECIALIZED-ARRAY: ushort IN: windows.shell32 diff --git a/basis/windows/types/types.factor b/basis/windows/types/types.factor index f3455fbb0f..ea5daba688 100755 --- a/basis/windows/types/types.factor +++ b/basis/windows/types/types.factor @@ -61,6 +61,7 @@ TYPEDEF: ulong ULONG_PTR TYPEDEF: int INT32 TYPEDEF: uint UINT32 TYPEDEF: uint DWORD32 +TYPEDEF: long LONG32 TYPEDEF: ulong ULONG32 TYPEDEF: ulonglong ULONG64 TYPEDEF: long* POINTER_32 @@ -75,6 +76,8 @@ TYPEDEF: longlong LARGE_INTEGER TYPEDEF: ulonglong ULARGE_INTEGER TYPEDEF: LARGE_INTEGER* PLARGE_INTEGER TYPEDEF: ULARGE_INTEGER* PULARGE_INTEGER +TYPEDEF: size_t SIZE_T +TYPEDEF: ptrdiff_t SSIZE_T TYPEDEF: wchar_t* LPCSTR TYPEDEF: wchar_t* LPWSTR @@ -201,15 +204,6 @@ TYPEDEF: LONG_PTR SSIZE_T TYPEDEF: LONGLONG USN TYPEDEF: UINT_PTR WPARAM -TYPEDEF: RECT* LPRECT -TYPEDEF: void* PWNDCLASS -TYPEDEF: void* PWNDCLASSEX -TYPEDEF: void* LPWNDCLASS -TYPEDEF: void* LPWNDCLASSEX -TYPEDEF: void* MSGBOXPARAMSA -TYPEDEF: void* MSGBOXPARAMSW -TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE - TYPEDEF: size_t socklen_t TYPEDEF: void* WNDPROC @@ -343,6 +337,14 @@ TYPEDEF: PFD* LPPFD TYPEDEF: HANDLE HGLRC TYPEDEF: HANDLE HRGN +TYPEDEF: void* PWNDCLASS +TYPEDEF: void* PWNDCLASSEX +TYPEDEF: void* LPWNDCLASS +TYPEDEF: void* LPWNDCLASSEX +TYPEDEF: void* MSGBOXPARAMSA +TYPEDEF: void* MSGBOXPARAMSW +TYPEDEF: void* LPOVERLAPPED_COMPLETION_ROUTINE + STRUCT: LVITEM { mask uint } { iItem int } diff --git a/basis/windows/user32/user32.factor b/basis/windows/user32/user32.factor index 43b59d613b..e10ee67357 100755 --- a/basis/windows/user32/user32.factor +++ b/basis/windows/user32/user32.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien alien.syntax parser namespaces kernel math -windows.types generalizations math.bitwise classes.struct -literals ; +USING: alien alien.c-types alien.syntax parser namespaces +kernel math windows.types generalizations math.bitwise +classes.struct literals windows.kernel32 ; IN: windows.user32 ! HKL for ActivateKeyboardLayout diff --git a/basis/windows/usp10/usp10.factor b/basis/windows/usp10/usp10.factor index eb57a46925..f021b55289 100755 --- a/basis/windows/usp10/usp10.factor +++ b/basis/windows/usp10/usp10.factor @@ -1,6 +1,7 @@ ! Copyright (C) 2009 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: alien.syntax alien.destructors classes.struct ; +USING: alien.c-types alien.syntax alien.destructors classes.struct +windows.types ; IN: windows.usp10 LIBRARY: usp10 @@ -56,6 +57,9 @@ SCRIPT_JUSTIFFY_RESERVED4 ; STRUCT: SCRIPT_VISATTR { flags WORD } ; +TYPEDEF: void* SCRIPT_CACHE* +TYPEDEF: void* ABC* + FUNCTION: HRESULT ScriptShape ( HDC hdc, SCRIPT_CACHE* psc, From f8251d2045c4b8955bb2cccfba33a9ca2674d589 Mon Sep 17 00:00:00 2001 From: Joe Groff Date: Sun, 27 Sep 2009 18:41:20 -0500 Subject: [PATCH 16/17] update vocabs so load-all on windows works without parsing string c-types --- basis/windows/dinput/dinput.factor | 2 +- basis/windows/winsock/winsock.factor | 12 ++++++++---- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/basis/windows/dinput/dinput.factor b/basis/windows/dinput/dinput.factor index 598df9a389..157bde9dbd 100755 --- a/basis/windows/dinput/dinput.factor +++ b/basis/windows/dinput/dinput.factor @@ -1,6 +1,6 @@ USING: windows.kernel32 windows.ole32 windows.com windows.com.syntax alien alien.c-types alien.syntax kernel system namespaces math -classes.struct ; +classes.struct windows.types ; IN: windows.dinput LIBRARY: dinput diff --git a/basis/windows/winsock/winsock.factor b/basis/windows/winsock/winsock.factor index dc751e64a6..b50fadb5ba 100755 --- a/basis/windows/winsock/winsock.factor +++ b/basis/windows/winsock/winsock.factor @@ -105,6 +105,8 @@ CONSTANT: SD_BOTH 2 CONSTANT: SOL_SOCKET HEX: ffff +TYPEDEF: void* sockaddr* + STRUCT: sockaddr-in { family short } { port ushort } @@ -139,13 +141,15 @@ STRUCT: timeval { sec long } { usec long } ; +TYPEDEF: void* fd_set* + LIBRARY: winsock FUNCTION: int setsockopt ( SOCKET s, int level, int optname, char* optval, int optlen ) ; FUNCTION: ushort htons ( ushort n ) ; FUNCTION: ushort ntohs ( ushort n ) ; -FUNCTION: int bind ( void* socket, sockaddr_in* sockaddr, int len ) ; +FUNCTION: int bind ( void* socket, sockaddr-in* sockaddr, int len ) ; FUNCTION: int listen ( void* socket, int backlog ) ; FUNCTION: char* inet_ntoa ( int in-addr ) ; FUNCTION: int getaddrinfo ( char* nodename, @@ -158,15 +162,15 @@ FUNCTION: void freeaddrinfo ( addrinfo* ai ) ; FUNCTION: hostent* gethostbyname ( char* name ) ; FUNCTION: int gethostname ( char* name, int len ) ; -FUNCTION: int connect ( void* socket, sockaddr_in* sockaddr, int addrlen ) ; +FUNCTION: int connect ( void* socket, sockaddr-in* sockaddr, int addrlen ) ; FUNCTION: int select ( int nfds, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, timeval* timeout ) ; FUNCTION: int closesocket ( SOCKET s ) ; FUNCTION: int shutdown ( SOCKET s, int how ) ; FUNCTION: int send ( SOCKET s, char* buf, int len, int flags ) ; FUNCTION: int recv ( SOCKET s, char* buf, int len, int flags ) ; -FUNCTION: int getsockname ( SOCKET s, sockaddr_in* address, int* addrlen ) ; -FUNCTION: int getpeername ( SOCKET s, sockaddr_in* address, int* addrlen ) ; +FUNCTION: int getsockname ( SOCKET s, sockaddr-in* address, int* addrlen ) ; +FUNCTION: int getpeername ( SOCKET s, sockaddr-in* address, int* addrlen ) ; TYPEDEF: uint SERVICETYPE TYPEDEF: OVERLAPPED WSAOVERLAPPED From 705b4ab5c3106d9352d082b24e3ede5637a5e5cc Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 27 Sep 2009 19:28:20 -0500 Subject: [PATCH 17/17] compiler.cfg.linear-scan: fix partial sync point logic in case where dst == src, and clean up spilling code --- .../cfg/instructions/instructions.factor | 7 +++--- .../linear-scan/allocation/allocation.factor | 10 +++++--- .../linear-scan/allocation/state/state.factor | 7 +++--- .../linear-scan/assignment/assignment.factor | 2 +- .../cfg/linear-scan/linear-scan-tests.factor | 16 ++++++------- .../linear-scan/resolve/resolve-tests.factor | 12 +++++----- .../cfg/linear-scan/resolve/resolve.factor | 4 ++-- basis/compiler/codegen/codegen.factor | 4 ++-- basis/compiler/tests/codegen.factor | 24 ++++++++++++++----- basis/cpu/architecture/architecture.factor | 4 ++-- basis/cpu/ppc/ppc.factor | 8 +++---- basis/cpu/x86/32/32.factor | 11 ++++++--- basis/cpu/x86/64/64.factor | 6 +++-- basis/cpu/x86/x86.factor | 12 +++++----- 14 files changed, 76 insertions(+), 51 deletions(-) diff --git a/basis/compiler/cfg/instructions/instructions.factor b/basis/compiler/cfg/instructions/instructions.factor index 6f5a05c672..5b494a39d9 100644 --- a/basis/compiler/cfg/instructions/instructions.factor +++ b/basis/compiler/cfg/instructions/instructions.factor @@ -657,7 +657,8 @@ literal: label def: dst/int-rep use: src1/int-rep src2/int-rep ; -TUPLE: spill-slot n ; C: spill-slot +TUPLE: spill-slot { n integer } ; +C: spill-slot INSN: _gc temp: temp1 temp2 @@ -667,11 +668,11 @@ literal: data-values tagged-values uninitialized-locs ; ! virtual registers INSN: _spill use: src -literal: rep n ; +literal: rep dst ; INSN: _reload def: dst -literal: rep n ; +literal: rep src ; INSN: _spill-area-size literal: n ; diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor index c23867ffe2..ac32265e65 100644 --- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor +++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor @@ -34,11 +34,15 @@ IN: compiler.cfg.linear-scan.allocation [ drop assign-blocked-register ] } cond ; +: spill-at-sync-point ( live-interval n -- ? ) + ! If the live interval has a usage at 'n', don't spill it, + ! since this means its being defined by the sync point + ! instruction. Output t if this is the case. + 2dup [ uses>> ] dip swap member? [ 2drop t ] [ spill f ] if ; + : handle-sync-point ( n -- ) [ active-intervals get values ] dip - [ '[ [ _ spill ] each ] each ] - [ drop [ delete-all ] each ] - 2bi ; + '[ [ _ spill-at-sync-point ] filter-here ] each ; :: handle-progress ( n sync? -- ) n { diff --git a/basis/compiler/cfg/linear-scan/allocation/state/state.factor b/basis/compiler/cfg/linear-scan/allocation/state/state.factor index a311f97b66..3ae000891e 100644 --- a/basis/compiler/cfg/linear-scan/allocation/state/state.factor +++ b/basis/compiler/cfg/linear-scan/allocation/state/state.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs combinators cpu.architecture fry heaps kernel math math.order namespaces sequences vectors -compiler.cfg compiler.cfg.registers +compiler.cfg compiler.cfg.registers compiler.cfg.instructions compiler.cfg.linear-scan.live-intervals ; IN: compiler.cfg.linear-scan.allocation.state @@ -118,7 +118,8 @@ SYMBOL: unhandled-intervals : next-spill-slot ( rep -- n ) rep-size cfg get - [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop ; + [ swap [ align dup ] [ + ] bi ] change-spill-area-size drop + ; ! Minheap of sync points which still need to be processed SYMBOL: unhandled-sync-points @@ -126,7 +127,7 @@ SYMBOL: unhandled-sync-points ! Mapping from vregs to spill slots SYMBOL: spill-slots -: vreg-spill-slot ( vreg -- n ) +: vreg-spill-slot ( vreg -- spill-slot ) spill-slots get [ rep-of next-spill-slot ] cache ; : init-allocator ( registers -- ) diff --git a/basis/compiler/cfg/linear-scan/assignment/assignment.factor b/basis/compiler/cfg/linear-scan/assignment/assignment.factor index 572107be6c..8959add822 100644 --- a/basis/compiler/cfg/linear-scan/assignment/assignment.factor +++ b/basis/compiler/cfg/linear-scan/assignment/assignment.factor @@ -33,7 +33,7 @@ ERROR: bad-vreg vreg ; : (vreg>reg) ( vreg pending -- reg ) ! If a live vreg is not in the pending set, then it must ! have been spilled. - ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ; + ?at [ spill-slots get ?at [ ] [ bad-vreg ] if ] unless ; : vreg>reg ( vreg -- reg ) pending-interval-assoc get (vreg>reg) ; diff --git a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor index f09fe403e6..77c9e348c9 100644 --- a/basis/compiler/cfg/linear-scan/linear-scan-tests.factor +++ b/basis/compiler/cfg/linear-scan/linear-scan-tests.factor @@ -92,7 +92,7 @@ H{ { end 2 } { uses V{ 0 1 } } { ranges V{ T{ live-range f 0 2 } } } - { spill-to 0 } + { spill-to T{ spill-slot f 0 } } } T{ live-interval { vreg 1 } @@ -100,7 +100,7 @@ H{ { end 5 } { uses V{ 5 } } { ranges V{ T{ live-range f 5 5 } } } - { reload-from 0 } + { reload-from T{ spill-slot f 0 } } } ] [ T{ live-interval @@ -119,7 +119,7 @@ H{ { end 1 } { uses V{ 0 } } { ranges V{ T{ live-range f 0 1 } } } - { spill-to 4 } + { spill-to T{ spill-slot f 4 } } } T{ live-interval { vreg 2 } @@ -127,7 +127,7 @@ H{ { end 5 } { uses V{ 1 5 } } { ranges V{ T{ live-range f 1 5 } } } - { reload-from 4 } + { reload-from T{ spill-slot f 4 } } } ] [ T{ live-interval @@ -146,7 +146,7 @@ H{ { end 1 } { uses V{ 0 } } { ranges V{ T{ live-range f 0 1 } } } - { spill-to 8 } + { spill-to T{ spill-slot f 8 } } } T{ live-interval { vreg 3 } @@ -154,7 +154,7 @@ H{ { end 30 } { uses V{ 20 30 } } { ranges V{ T{ live-range f 20 30 } } } - { reload-from 8 } + { reload-from T{ spill-slot f 8 } } } ] [ T{ live-interval @@ -1042,8 +1042,8 @@ V{ [ _spill ] [ 1 get instructions>> second class ] unit-test [ _reload ] [ 4 get instructions>> 4 swap nth class ] unit-test -[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ n>> cell / ] map ] unit-test -[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ n>> cell / ] map ] unit-test +[ V{ 3 2 1 } ] [ 8 get instructions>> [ _spill? ] filter [ dst>> n>> cell / ] map ] unit-test +[ V{ 3 2 1 } ] [ 9 get instructions>> [ _reload? ] filter [ src>> n>> cell / ] map ] unit-test ! Resolve pass should insert this [ _reload ] [ 5 get predecessors>> first instructions>> first class ] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor index 47c1f0ae76..e7f291d613 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve-tests.factor @@ -17,7 +17,7 @@ IN: compiler.cfg.linear-scan.resolve.tests [ { - T{ _reload { dst 1 } { rep int-rep } { n 0 } } + T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 0 } } } } ] [ [ @@ -27,7 +27,7 @@ IN: compiler.cfg.linear-scan.resolve.tests [ { - T{ _spill { src 1 } { rep int-rep } { n 0 } } + T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 0 } } } } ] [ [ @@ -54,14 +54,14 @@ H{ } clone spill-temps set { { { 0 int-rep } { 1 int-rep } } { { 1 int-rep } { 0 int-rep } } } mapping-instructions { { - T{ _spill { src 0 } { rep int-rep } { n 8 } } + T{ _spill { src 0 } { rep int-rep } { dst T{ spill-slot f 8 } } } T{ ##copy { dst 0 } { src 1 } { rep int-rep } } - T{ _reload { dst 1 } { rep int-rep } { n 8 } } + T{ _reload { dst 1 } { rep int-rep } { src T{ spill-slot f 8 } } } } { - T{ _spill { src 1 } { rep int-rep } { n 8 } } + T{ _spill { src 1 } { rep int-rep } { dst T{ spill-slot f 8 } } } T{ ##copy { dst 1 } { src 0 } { rep int-rep } } - T{ _reload { dst 0 } { rep int-rep } { n 8 } } + T{ _reload { dst 0 } { rep int-rep } { src T{ spill-slot f 8 } } } } } member? ] unit-test diff --git a/basis/compiler/cfg/linear-scan/resolve/resolve.factor b/basis/compiler/cfg/linear-scan/resolve/resolve.factor index 15dff23448..20c9ee4e99 100644 --- a/basis/compiler/cfg/linear-scan/resolve/resolve.factor +++ b/basis/compiler/cfg/linear-scan/resolve/resolve.factor @@ -34,10 +34,10 @@ SYMBOL: spill-temps ] if ; : memory->register ( from to -- ) - swap [ first2 ] [ first n>> ] bi* _reload ; + swap [ first2 ] [ first ] bi* _reload ; : register->memory ( from to -- ) - [ first2 ] [ first n>> ] bi* _spill ; + [ first2 ] [ first ] bi* _spill ; : temp->register ( from to -- ) nip [ first ] [ second ] [ second spill-temp ] tri _reload ; diff --git a/basis/compiler/codegen/codegen.factor b/basis/compiler/codegen/codegen.factor index 0c9d7ab45a..76c47d2ef2 100755 --- a/basis/compiler/codegen/codegen.factor +++ b/basis/compiler/codegen/codegen.factor @@ -240,7 +240,7 @@ CODEGEN: _reload %reload GENERIC# save-gc-root 1 ( gc-root operand temp -- ) M:: spill-slot save-gc-root ( gc-root operand temp -- ) - temp int-rep operand n>> %reload + temp int-rep operand %reload gc-root temp %save-gc-root ; M: object save-gc-root drop %save-gc-root ; @@ -253,7 +253,7 @@ GENERIC# load-gc-root 1 ( gc-root operand temp -- ) M:: spill-slot load-gc-root ( gc-root operand temp -- ) gc-root temp %load-gc-root - temp int-rep operand n>> %spill ; + temp int-rep operand %spill ; M: object load-gc-root drop %load-gc-root ; diff --git a/basis/compiler/tests/codegen.factor b/basis/compiler/tests/codegen.factor index 3dbde076a6..a4f19966b1 100644 --- a/basis/compiler/tests/codegen.factor +++ b/basis/compiler/tests/codegen.factor @@ -1,9 +1,10 @@ -USING: generalizations accessors arrays compiler kernel kernel.private -math hashtables.private math.private namespaces sequences tools.test -namespaces.private slots.private sequences.private byte-arrays alien -alien.accessors layouts words definitions compiler.units io -combinators vectors grouping make alien.c-types combinators.short-circuit -math.order math.libm math.parser alien.c-types ; +USING: generalizations accessors arrays compiler kernel +kernel.private math hashtables.private math.private namespaces +sequences tools.test namespaces.private slots.private +sequences.private byte-arrays alien alien.accessors layouts +words definitions compiler.units io combinators vectors grouping +make alien.c-types combinators.short-circuit math.order +math.libm math.parser math.functions ; FROM: math => float ; QUALIFIED: namespaces.private IN: compiler.tests.codegen @@ -432,6 +433,7 @@ cell 4 = [ ] compile-call ] unit-test +! Bug in CSSA construction TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read-only } ; [ 2 ] [ @@ -449,3 +451,13 @@ TUPLE: myseq { underlying1 byte-array read-only } { underlying2 byte-array read- ] 2curry each-integer ] compile-call ] unit-test + +! Bug in linear scan's partial sync point logic +[ t ] [ + [ 1.0 100 [ fsin ] times 1.0 float+ ] compile-call + 1.168852488727981 1.e-9 ~ +] unit-test + +[ 65537.0 ] [ + [ 2.0 4 [ 2.0 fpow ] times 1.0 float+ ] compile-call +] unit-test diff --git a/basis/cpu/architecture/architecture.factor b/basis/cpu/architecture/architecture.factor index c27aacb875..114e63209a 100644 --- a/basis/cpu/architecture/architecture.factor +++ b/basis/cpu/architecture/architecture.factor @@ -311,8 +311,8 @@ HOOK: %compare-imm-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-float-ordered-branch cpu ( label cc src1 src2 -- ) HOOK: %compare-float-unordered-branch cpu ( label cc src1 src2 -- ) -HOOK: %spill cpu ( src rep n -- ) -HOOK: %reload cpu ( dst rep n -- ) +HOOK: %spill cpu ( src rep dst -- ) +HOOK: %reload cpu ( dst rep src -- ) HOOK: %loop-entry cpu ( -- ) diff --git a/basis/cpu/ppc/ppc.factor b/basis/cpu/ppc/ppc.factor index 64df207975..90e38a802b 100644 --- a/basis/cpu/ppc/ppc.factor +++ b/basis/cpu/ppc/ppc.factor @@ -632,11 +632,11 @@ M:: ppc %compare-float-unordered-branch ( label src1 src2 cc -- ) { stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] } } case ; -M: ppc %spill ( src rep n -- ) - swap [ spill@ ] dip store-to-frame ; +M: ppc %spill ( src rep dst -- ) + swap [ n>> spill@ ] dip store-to-frame ; -M: ppc %reload ( dst rep n -- ) - swap [ spill@ ] dip load-from-frame ; +M: ppc %reload ( dst rep src -- ) + swap [ n>> spill@ ] dip load-from-frame ; M: ppc %loop-entry ; diff --git a/basis/cpu/x86/32/32.factor b/basis/cpu/x86/32/32.factor index 1a9e833835..809e068430 100755 --- a/basis/cpu/x86/32/32.factor +++ b/basis/cpu/x86/32/32.factor @@ -282,11 +282,16 @@ M: x86.32 %callback-value ( ctype -- ) ! Unbox EAX unbox-return ; -:: float-function-param ( stack-slot dst src -- ) +GENERIC: float-function-param ( stack-slot dst src -- ) + +M:: spill-slot float-function-param ( stack-slot dst src -- ) ! We can clobber dst here since its going to contain the ! final result - dst src n>> spill@ MOVSD - stack-slot dst MOVSD ; + dst src double-rep %copy + stack-slot dst double-rep %copy ; + +M: register float-function-param + nip double-rep %copy ; : float-function-return ( reg -- ) ESP [] FSTPL diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index 424fdec5b9..805dda982b 100644 --- a/basis/cpu/x86/64/64.factor +++ b/basis/cpu/x86/64/64.factor @@ -218,8 +218,8 @@ M: x86.64 %callback-value ( ctype -- ) ! Unbox former top of data stack to return registers unbox-return ; -: float-function-param ( i spill-slot -- ) - [ float-regs param-regs nth ] [ n>> spill@ ] bi* MOVSD ; +: float-function-param ( i src -- ) + [ float-regs param-regs nth ] dip double-rep %copy ; : float-function-return ( reg -- ) float-regs return-reg double-rep %copy ; @@ -230,6 +230,8 @@ M:: x86.64 %unary-float-function ( dst src func -- ) dst float-function-return ; M:: x86.64 %binary-float-function ( dst src1 src2 func -- ) + ! src1 might equal dst; otherwise it will be a spill slot + ! src2 is always a spill slot 0 src1 float-function-param 1 src2 float-function-param func f %alien-invoke diff --git a/basis/cpu/x86/x86.factor b/basis/cpu/x86/x86.factor index 40a720aa1b..51b5cef23a 100644 --- a/basis/cpu/x86/x86.factor +++ b/basis/cpu/x86/x86.factor @@ -135,7 +135,10 @@ M: double-2-rep copy-register* drop MOVUPD ; M: vector-rep copy-register* drop MOVDQU ; M: x86 %copy ( dst src rep -- ) - 2over eq? [ 3drop ] [ copy-register* ] if ; + 2over eq? [ 3drop ] [ + [ [ dup spill-slot? [ n>> spill@ ] when ] bi@ ] dip + copy-register* + ] if ; :: overflow-template ( label dst src1 src2 insn -- ) src1 src2 insn call @@ -937,11 +940,8 @@ M: x86 %compare-float-ordered-branch ( label src1 src2 cc -- ) M: x86 %compare-float-unordered-branch ( label src1 src2 cc -- ) \ UCOMISD (%compare-float-branch) ; -M:: x86 %spill ( src rep n -- ) - n spill@ src rep %copy ; - -M:: x86 %reload ( dst rep n -- ) - dst n spill@ rep %copy ; +M:: x86 %spill ( src rep dst -- ) dst src rep %copy ; +M:: x86 %reload ( dst rep src -- ) dst src rep %copy ; M: x86 %loop-entry 16 code-alignment [ NOP ] times ;