Initial value for alien slots is a BAD-ALIEN

db4
Slava Pestov 2008-07-01 16:33:45 -05:00
parent 664631aa23
commit f8fd065fc5
9 changed files with 28 additions and 22 deletions

View File

@ -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? [

View File

@ -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 ;

View File

@ -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" } }

View File

@ -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 [

View File

@ -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

View File

@ -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

View File

@ -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

View File

@ -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 ;

View File

@ -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 ;