Initial value for alien slots is a BAD-ALIEN
parent
664631aa23
commit
f8fd065fc5
|
@ -18,15 +18,18 @@ PREDICATE: pinned-alien < alien underlying>> pinned-c-ptr? ;
|
||||||
UNION: pinned-c-ptr
|
UNION: pinned-c-ptr
|
||||||
pinned-alien POSTPONE: f ;
|
pinned-alien POSTPONE: f ;
|
||||||
|
|
||||||
GENERIC: expired? ( c-ptr -- ? )
|
GENERIC: expired? ( c-ptr -- ? ) flushable
|
||||||
|
|
||||||
M: alien expired? expired?>> ;
|
M: alien expired? expired>> ;
|
||||||
|
|
||||||
M: f expired? drop t ;
|
M: f expired? drop t ;
|
||||||
|
|
||||||
: <alien> ( address -- alien )
|
: <alien> ( address -- alien )
|
||||||
f <displaced-alien> { simple-c-ptr } declare ; inline
|
f <displaced-alien> { simple-c-ptr } declare ; inline
|
||||||
|
|
||||||
|
: <bad-alien> ( -- alien )
|
||||||
|
-1 <alien> t >>expired ; inline
|
||||||
|
|
||||||
M: alien equal?
|
M: alien equal?
|
||||||
over alien? [
|
over alien? [
|
||||||
2dup [ expired? ] either? [
|
2dup [ expired? ] either? [
|
||||||
|
|
|
@ -1,10 +1,10 @@
|
||||||
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
|
! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: arrays alien alien.c-types alien.structs alien.arrays
|
USING: accessors arrays alien alien.c-types alien.structs
|
||||||
alien.strings kernel math namespaces parser sequences words
|
alien.arrays alien.strings kernel math namespaces parser
|
||||||
quotations math.parser splitting grouping effects prettyprint
|
sequences words quotations math.parser splitting grouping
|
||||||
prettyprint.sections prettyprint.backend assocs combinators
|
effects prettyprint prettyprint.sections prettyprint.backend
|
||||||
lexer strings.parser ;
|
assocs combinators lexer strings.parser ;
|
||||||
IN: alien.syntax
|
IN: alien.syntax
|
||||||
|
|
||||||
<PRIVATE
|
<PRIVATE
|
||||||
|
@ -37,6 +37,8 @@ PRIVATE>
|
||||||
|
|
||||||
: ALIEN: scan string>number <alien> parsed ; parsing
|
: ALIEN: scan string>number <alien> parsed ; parsing
|
||||||
|
|
||||||
|
: BAD-ALIEN <bad-alien> parsed ; parsing
|
||||||
|
|
||||||
: LIBRARY: scan "c-library" set ; parsing
|
: LIBRARY: scan "c-library" set ; parsing
|
||||||
|
|
||||||
: FUNCTION:
|
: FUNCTION:
|
||||||
|
@ -67,7 +69,7 @@ PRIVATE>
|
||||||
|
|
||||||
M: alien pprint*
|
M: alien pprint*
|
||||||
{
|
{
|
||||||
{ [ dup expired? ] [ drop "( alien expired )" text ] }
|
{ [ dup expired? ] [ drop \ BAD-ALIEN pprint-word ] }
|
||||||
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
|
{ [ dup pinned-c-ptr? not ] [ drop "( displaced alien )" text ] }
|
||||||
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
|
[ \ ALIEN: [ alien-address pprint* ] pprint-prefix ]
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
|
@ -247,14 +247,12 @@ bi
|
||||||
|
|
||||||
"dll" "alien" create {
|
"dll" "alien" create {
|
||||||
{ "path" { "byte-array" "byte-arrays" } read-only }
|
{ "path" { "byte-array" "byte-arrays" } read-only }
|
||||||
}
|
} define-builtin
|
||||||
define-builtin
|
|
||||||
|
|
||||||
"alien" "alien" create {
|
"alien" "alien" create {
|
||||||
{ "underlying" { "c-ptr" "alien" } read-only }
|
{ "underlying" { "c-ptr" "alien" } read-only }
|
||||||
{ "expired?" read-only }
|
"expired"
|
||||||
}
|
} define-builtin
|
||||||
define-builtin
|
|
||||||
|
|
||||||
"word" "words" create {
|
"word" "words" create {
|
||||||
{ "hashcode" { "fixnum" "math" } }
|
{ "hashcode" { "fixnum" "math" } }
|
||||||
|
|
|
@ -5,7 +5,9 @@ lexer combinators words classes.parser classes.tuple arrays ;
|
||||||
IN: classes.tuple.parser
|
IN: classes.tuple.parser
|
||||||
|
|
||||||
: shadowed-slots ( superclass slots -- shadowed )
|
: shadowed-slots ( superclass slots -- shadowed )
|
||||||
>r all-slot-names r> intersect ;
|
[ all-slots [ name>> ] map ]
|
||||||
|
[ [ dup array? [ first ] when ] map ]
|
||||||
|
bi* intersect ;
|
||||||
|
|
||||||
: check-slot-shadowing ( class superclass slots -- )
|
: check-slot-shadowing ( class superclass slots -- )
|
||||||
shadowed-slots [
|
shadowed-slots [
|
||||||
|
|
|
@ -529,9 +529,6 @@ set-primitive-effect
|
||||||
|
|
||||||
\ fclose { alien } { } <effect> set-primitive-effect
|
\ fclose { alien } { } <effect> set-primitive-effect
|
||||||
|
|
||||||
\ expired? { object } { object } <effect> set-primitive-effect
|
|
||||||
\ expired? make-flushable
|
|
||||||
|
|
||||||
\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
|
\ <wrapper> { object } { wrapper } <effect> set-primitive-effect
|
||||||
\ <wrapper> make-foldable
|
\ <wrapper> make-foldable
|
||||||
|
|
||||||
|
|
|
@ -6,6 +6,8 @@ TUPLE: foo bar baz ;
|
||||||
|
|
||||||
C: <foo> foo
|
C: <foo> foo
|
||||||
|
|
||||||
|
[ 3 ] [ 1 2 <foo> <mirror> assoc-size ] unit-test
|
||||||
|
|
||||||
[ { "delegate" "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
|
[ { "delegate" "bar" "baz" } ] [ 1 2 <foo> <mirror> keys ] unit-test
|
||||||
|
|
||||||
[ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test
|
[ 1 t ] [ "bar" 1 2 <foo> <mirror> at* ] unit-test
|
||||||
|
|
|
@ -1,8 +1,9 @@
|
||||||
! Copyright (C) 2007, 2008 Slava Pestov.
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: assocs hashtables kernel sequences generic words
|
USING: assocs hashtables kernel sequences generic words
|
||||||
arrays classes slots slots.private classes.tuple math vectors
|
arrays classes slots slots.private classes.tuple
|
||||||
quotations accessors combinators ;
|
classes.tuple.private math vectors quotations accessors
|
||||||
|
combinators ;
|
||||||
IN: mirrors
|
IN: mirrors
|
||||||
|
|
||||||
TUPLE: mirror { object read-only } ;
|
TUPLE: mirror { object read-only } ;
|
||||||
|
@ -40,7 +41,7 @@ M: mirror >alist ( mirror -- alist )
|
||||||
[ object>> [ swap slot ] curry ] bi
|
[ object>> [ swap slot ] curry ] bi
|
||||||
map zip ;
|
map zip ;
|
||||||
|
|
||||||
M: mirror assoc-size mirror-slots length ;
|
M: mirror assoc-size object>> layout-of size>> ;
|
||||||
|
|
||||||
INSTANCE: mirror assoc
|
INSTANCE: mirror assoc
|
||||||
|
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
USING: arrays bit-arrays byte-arrays float-arrays kernel
|
USING: arrays bit-arrays byte-arrays float-arrays kernel
|
||||||
kernel.private math namespaces sequences strings words effects
|
kernel.private math namespaces sequences strings words effects
|
||||||
generic generic.standard classes classes.algebra slots.private
|
generic generic.standard classes classes.algebra slots.private
|
||||||
combinators accessors words sequences.private assocs ;
|
combinators accessors words sequences.private assocs alien ;
|
||||||
IN: slots
|
IN: slots
|
||||||
|
|
||||||
TUPLE: slot-spec name offset class initial read-only reader writer ;
|
TUPLE: slot-spec name offset class initial read-only reader writer ;
|
||||||
|
@ -135,6 +135,7 @@ ERROR: no-initial-value class ;
|
||||||
{ [ bit-array bootstrap-word over class<= ] [ ?{ } ] }
|
{ [ bit-array bootstrap-word over class<= ] [ ?{ } ] }
|
||||||
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
|
{ [ byte-array bootstrap-word over class<= ] [ B{ } ] }
|
||||||
{ [ float-array bootstrap-word over class<= ] [ F{ } ] }
|
{ [ float-array bootstrap-word over class<= ] [ F{ } ] }
|
||||||
|
{ [ simple-alien bootstrap-word over class<= ] [ <bad-alien> ] }
|
||||||
[ no-initial-value ]
|
[ no-initial-value ]
|
||||||
} cond nip ;
|
} cond nip ;
|
||||||
|
|
||||||
|
|
|
@ -8,7 +8,7 @@ IN: io.buffers
|
||||||
|
|
||||||
TUPLE: buffer
|
TUPLE: buffer
|
||||||
{ size fixnum }
|
{ size fixnum }
|
||||||
{ ptr simple-alien initial: ALIEN: -1 }
|
{ ptr simple-alien }
|
||||||
{ fill fixnum }
|
{ fill fixnum }
|
||||||
{ pos fixnum }
|
{ pos fixnum }
|
||||||
disposed ;
|
disposed ;
|
||||||
|
|
Loading…
Reference in New Issue