: new-c-type ( class -- type )
new
int-regs >>reg-class
- object >>class ;
+ object >>class ; inline
: <c-type> ( -- type )
\ c-type new-c-type ;
: parse-array-type ( name -- array )
"[" split unclip
- >r [ "]" ?tail drop string>number ] map r> prefix ;
+ [ [ "]" ?tail drop string>number ] map ] dip prefix ;
M: string c-type ( name -- type )
CHAR: ] over member? [
: c-getter ( name -- quot )
c-type-getter [
- [ "Cannot read struct fields with type" throw ]
+ [ "Cannot read struct fields with this type" throw ]
] unless* ;
: c-setter ( name -- quot )
c-type-setter [
- [ "Cannot write struct fields with type" throw ]
+ [ "Cannot write struct fields with this type" throw ]
] unless* ;
: <c-array> ( n type -- array )
1 swap malloc-array ; inline
: malloc-byte-array ( byte-array -- alien )
- dup length dup malloc [ -rot memcpy ] keep ;
+ dup length [ nip malloc dup ] 2keep memcpy ;
: memory>byte-array ( alien len -- byte-array )
- dup <byte-array> [ -rot memcpy ] keep ;
+ [ nip <byte-array> dup ] 2keep memcpy ;
: byte-array>memory ( byte-array base -- )
swap dup length memcpy ;
-: (define-nth) ( word type quot -- )
+: array-accessor ( type quot -- def )
[
\ swap , [ heap-size , [ * >fixnum ] % ] [ % ] bi*
- ] [ ] make define-inline ;
-
-: nth-word ( name vocab -- word )
- [ "-nth" append ] dip create ;
-
-: define-nth ( name vocab -- )
- dupd nth-word swap dup c-getter (define-nth) ;
-
-: set-nth-word ( name vocab -- word )
- [ "set-" swap "-nth" 3append ] dip create ;
-
-: define-set-nth ( name vocab -- )
- dupd set-nth-word swap dup c-setter (define-nth) ;
+ ] [ ] make ;
: typedef ( old new -- ) c-types get set-at ;
-: define-c-type ( type name vocab -- )
- [ tuck typedef ] dip [ define-nth ] 2keep define-set-nth ;
-
TUPLE: long-long-type < c-type ;
: <long-long-type> ( -- type )
M: long-long-type box-return ( type -- )
f swap box-parameter ;
-: define-deref ( name vocab -- )
- [ dup CHAR: * prefix ] dip create
- swap c-getter 0 prefix define-inline ;
+: define-deref ( name -- )
+ [ CHAR: * prefix "alien.c-types" create ]
+ [ c-getter 0 prefix ] bi
+ define-inline ;
-: define-out ( name vocab -- )
- over [ <c-object> tuck 0 ] over c-setter append swap
- [ constructor-word ] 2dip prefix define-inline ;
+: define-out ( name -- )
+ [ "alien.c-types" constructor-word ]
+ [ [ [ <c-object> ] curry ] [ c-setter ] bi append ] bi
+ define-inline ;
: c-bool> ( int -- ? )
zero? not ;
-: >c-array ( seq type word -- byte-array )
- [ [ dup length ] dip <c-array> ] dip
- [ [ execute ] 2curry each-index ] 2keep drop ; inline
-
-: >c-array-quot ( type vocab -- quot )
- dupd set-nth-word [ >c-array ] 2curry ;
-
-: to-array-word ( name vocab -- word )
- [ ">c-" swap "-array" 3append ] dip create ;
-
-: define-to-array ( type vocab -- )
- [ to-array-word ] 2keep >c-array-quot
- (( array -- byte-array )) define-declared ;
-
-: c-array>quot ( type vocab -- quot )
- [
- \ swap ,
- nth-word 1quotation ,
- [ curry map ] %
- ] [ ] make ;
-
-: from-array-word ( name vocab -- word )
- [ "c-" swap "-array>" 3append ] dip create ;
-
-: define-from-array ( type vocab -- )
- [ from-array-word ] 2keep c-array>quot
- (( c-ptr n -- array )) define-declared ;
-
: define-primitive-type ( type name -- )
- "alien.c-types"
- {
- [ define-c-type ]
- [ define-deref ]
- [ define-to-array ]
- [ define-from-array ]
- [ define-out ]
- } 2cleave ;
+ [ typedef ]
+ [ define-deref ]
+ [ define-out ]
+ tri ;
: expand-constants ( c-type -- c-type' )
dup array? [
: if-void ( type true false -- )
pick "void" = [ drop nip call ] [ nip call ] if ; inline
+: primitive-types
+ {
+ "char" "uchar"
+ "short" "ushort"
+ "int" "uint"
+ "long" "ulong"
+ "longlong" "ulonglong"
+ "float" "double"
+ "void*" "bool"
+ } ;
+
[
<c-type>
c-ptr >>class
: c-struct? ( type -- ? ) (c-type) struct-type? ;
-: (define-struct) ( name vocab size align fields -- )
+: (define-struct) ( name size align fields -- )
- >r [ align ] keep r>
+ [ [ align ] keep ] dip
struct-type boa
- -rot define-c-type ;
+ swap typedef ;
: define-struct-early ( name vocab fields -- fields )
[ first2 <field-spec> ] with with map ;
[ c-type-align ] map supremum ;
: define-struct ( name vocab fields -- )
- pick >r
- [ struct-offsets ] keep
- [ [ type>> ] map compute-struct-align ] keep
- [ (define-struct) ] keep
- r> [ swap define-field ] curry each ;
+ pick [
+ [ struct-offsets ] keep
+ [ [ type>> ] map compute-struct-align ] keep
+ [ (define-struct) ] keep
+ ] dip [ swap define-field ] curry each ;
: define-union ( name vocab members -- )
[ expand-constants ] map
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types arrays kernel math namespaces make cocoa
-cocoa.messages cocoa.classes cocoa.types sequences
-continuations ;
+USING: specialized-arrays.int arrays kernel math namespaces make
+cocoa cocoa.messages cocoa.classes cocoa.types sequences
+continuations accessors ;
IN: cocoa.views
: NSOpenGLPFAAllRenderers 1 ;
NSOpenGLPFASamples , 8 ,
] when
0 ,
- ] { } make >c-int-array
+ ] int-array{ } make underlying>>
-> initWithAttributes:
-> autorelease ;
: <GLView> ( class dim -- view )
-
>r -> alloc 0 0 r> first2 <NSRect> <PixelFormat>
+
[ -> alloc 0 0 ] dip first2 <NSRect> <PixelFormat>
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
dup 1 -> setPostsFrameChangedNotifications: ;
swap NSRect-h >fixnum 2array ;
: mouse-location ( view event -- loc )
- over >r
- -> locationInWindow f -> convertPoint:fromView:
- dup NSPoint-x swap NSPoint-y
- r> -> frame NSRect-h swap - 2array ;
+ [
+ -> locationInWindow f -> convertPoint:fromView:
+ [ NSPoint-x ] [ NSPoint-y ] bi
+ ] [ drop -> frame NSRect-h ] 2bi
+ swap - 2array ;
USE: opengl.gl
USE: alien.syntax
db.types tools.walker ascii splitting math.parser combinators
libc shuffle calendar.format byte-arrays destructors prettyprint
accessors strings serialize io.encodings.binary io.encodings.utf8
-alien.strings io.streams.byte-array summary present urls ;
+alien.strings io.streams.byte-array summary present urls
+specialized-arrays.uint specialized-arrays.alien ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
} case ;
: param-types ( statement -- seq )
- in-params>> [ type>> type>oid ] map >c-uint-array ;
+ in-params>> [ type>> type>oid ] uint-array{ } map-as underlying>> ;
: malloc-byte-array/length ( byte-array -- alien length )
[ malloc-byte-array &free ] [ length ] bi ;
: param-values ( statement -- seq seq2 )
[ bind-params>> ] [ in-params>> ] bi
[
- >r value>> r> type>> {
+ [ value>> ] [ type>> ] bi* {
{ FACTOR-BLOB [
dup [ object>bytes malloc-byte-array/length ] [ 0 ] if
] }
] 2map flip [
f f
] [
- first2 [ >c-void*-array ] [ >c-uint-array ] bi*
+ first2 [ >void*-array underlying>> ] [ >uint-array underlying>> ] bi*
] if-empty ;
: param-formats ( statement -- seq )
- in-params>> [ type>> type>param-format ] map >c-uint-array ;
+ in-params>> [ type>> type>param-format ] uint-array{ } map-as underlying>> ;
: do-postgresql-bound-statement ( statement -- res )
[
- >r db get handle>> r>
+ [ db get handle>> ] dip
{
[ sql>> ]
[ bind-params>> length ]
: pq-get-string ( handle row column -- obj )
3dup PQgetvalue utf8 alien>string
- dup empty? [ >r pq-get-is-null f r> ? ] [ 3nip ] if ;
+ dup empty? [ [ pq-get-is-null f ] dip ? ] [ 3nip ] if ;
: pq-get-number ( handle row column -- obj )
pq-get-string dup [ string>number ] when ;
USING: accessors alien alien.c-types arrays hashtables io kernel
math namespaces opengl opengl.gl opengl.glu sequences strings
io.styles vectors combinators math.vectors ui.gadgets colors
-math.order math.geometry.rect locals ;
+math.order math.geometry.rect locals specialized-arrays.float ;
IN: ui.render
SYMBOL: clip
direction dim v* dim over v- swap
colors length dup 1- v/n [ v*n ] with map
[ dup rot v+ 2array ] with map
- concat concat >c-float-array ;
+ concat concat >float-array ;
: gradient-colors ( colors -- seq )
- [ color>raw 4array dup 2array ] map concat concat >c-float-array ;
+ [ color>raw 4array dup 2array ] map concat concat
+ >float-array ;
M: gradient recompute-pen ( gadget gradient -- )
tuck
boundary-count ;
: <polygon> ( color points -- polygon )
- dup close-path [ [ concat >c-float-array ] [ length ] bi ] bi@
+ dup close-path [ [ concat >float-array ] [ length ] bi ] bi@
polygon boa ;
M: polygon draw-boundary
dup string? [
string-width
] [
- 0 -rot [ string-width max ] with each
+ [ 0 ] 2dip [ string-width max ] with each
] if ;
: text-dim ( open-font text -- dim )
! See http://factorcode.org/license.txt for BSD license.
!
! based on glx.h from xfree86, and some of glxtokens.h
- USING: alien alien.c-types alien.syntax alien.syntax.private x11.xlib
+ USING: alien alien.c-types alien.syntax x11.xlib
-namespaces make kernel sequences parser words ;
+namespaces make kernel sequences parser words specialized-arrays.int ;
IN: x11.glx
LIBRARY: glx
GLX_DOUBLEBUFFER ,
GLX_DEPTH_SIZE , 16 ,
0 ,
- ] { } make >c-int-array
+ ] int-array{ } make underlying>>
glXChooseVisual
[ "Could not get a double-buffered GLX RGBA visual" throw ] unless* ;
"( gensym )" f <word> ;
: define-temp ( quot -- word )
- gensym dup rot define ;
+ [ gensym dup ] dip define ;
: reveal ( word -- )
dup [ name>> ] [ vocabulary>> ] bi dup vocab-words
PREDICATE: parsing-word < word "parsing" word-prop ;
+: make-parsing ( word -- ) t "parsing" set-word-prop ;
+
: delimiter? ( obj -- ? )
dup word? [ "delimiter" word-prop ] [ drop f ] if ;
projects / factor.git / commitdiff