steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

decouple struct parsing/printing from tuple parsing/printing a bit

db4
Joe Groff 2009-08-19 18:53:44 -05:00
parent 15a7148de0
commit c898593983
7 changed files with 64 additions and 56 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
basis/inverse/inverse.factor
View File

@ -248,7 +248,7 @@ DEFER: __
"predicate" word-prop [ dupd call assure ] curry ;
: slot-readers ( class -- quot )
class-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
all-slots [ name>> reader-word 1quotation ] map [ cleave ] curry ;
: ?wrapped ( object -- wrapped )
dup wrapper? [ wrapped>> ] when ;
@ -295,4 +295,4 @@ M: no-match summary drop "Fall through in switch" ;
reverse [ [ [undo] ] dip compose ] { } assoc>map
recover-chain ;
MACRO: switch ( quot-alist -- ) [switch] ;
MACRO: switch ( quot-alist -- ) [switch] ;

32
basis/prettyprint/backend/backend.factor
View File

@ -124,29 +124,31 @@ M: pathname pprint*
] if
] if ; inline
: tuple>assoc ( tuple -- assoc )
[ class class-slots ] [ object-slots ] bi zip
: filter-tuple-assoc ( slot,value -- name,value )
[ [ initial>> ] dip = not ] assoc-filter
[ [ name>> ] dip ] assoc-map ;
: tuple>assoc ( tuple -- assoc )
[ class all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
: pprint-slot-value ( name value -- )
<flow \ { pprint-word
[ text ] [ f <inset pprint* block> ] bi*
\ } pprint-word block> ;
: (pprint-tuple) ( opener class slots closer -- )
<flow {
[ pprint-word ]
[ pprint-word ]
[ t <inset [ pprint-slot-value ] assoc-each block> ]
[ pprint-word ]
} spread block> ;
: ?pprint-tuple ( tuple quot -- )
[ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
: pprint-tuple ( tuple -- )
boa-tuples? get [ pprint-object ] [
[
<flow
dup pprint-delims drop pprint-word
dup class pprint-word
t <inset
dup tuple>assoc [ pprint-slot-value ] assoc-each
block>
pprint-delims nip pprint-word
block>
] check-recursion
] if ;
[ [ \ T{ ] dip [ class ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
M: tuple pprint*
pprint-tuple ;
@ -186,7 +188,7 @@ M: callstack >pprint-sequence callstack>array ;
[ 1array ] [ [ f 2array ] dip append ] if-empty ;
M: tuple >pprint-sequence
[ class ] [ object-slots ] bi class-slot-sequence ;
[ class ] [ tuple-slots ] bi class-slot-sequence ;
M: object pprint-narrow? drop f ;
M: byte-vector pprint-narrow? drop f ;

12
core/classes/tuple/parser/parser.factor
View File

@ -92,19 +92,19 @@ GENERIC# boa>object 1 ( class slots -- tuple )
M: tuple-class boa>object
swap prefix >tuple ;
: assoc>object ( class slots -- tuple )
[ [ ] [ initial-values ] [ class-slots ] tri ] dip
: assoc>object ( class slots values -- tuple )
[ [ [ initial>> ] map ] keep ] dip
swap [ [ slot-named* drop ] curry dip ] curry assoc-map
[ dup <enum> ] dip update boa>object ;
: parse-tuple-literal-slots ( class -- tuple )
: parse-tuple-literal-slots ( class slots -- tuple )
scan {
{ f [ unexpected-eof ] }
{ "f" [ \ } parse-until boa>object ] }
{ "f" [ drop \ } parse-until boa>object ] }
{ "{" [ parse-slot-values assoc>object ] }
{ "}" [ new ] }
{ "}" [ drop new ] }
[ bad-literal-tuple ]
} case ;
: parse-tuple-literal ( -- tuple )
scan-word parse-tuple-literal-slots ;
scan-word dup all-slots parse-tuple-literal-slots ;

18
core/classes/tuple/tuple.factor
View File

@ -18,11 +18,6 @@ ERROR: not-a-tuple object ;
: all-slots ( class -- slots )
superclasses [ "slots" word-prop ] map concat ;
GENERIC: class-slots ( class -- slots )
M: tuple-class class-slots
all-slots ;
PREDICATE: immutable-tuple-class < tuple-class ( class -- ? )
all-slots [ read-only>> ] all? ;
@ -55,14 +50,11 @@ M: tuple class layout-of 2 slot { word } declare ; inline
PRIVATE>
: tuple-initial-values ( class -- slots )
: initial-values ( class -- slots )
all-slots [ initial>> ] map ;
: initial-values ( class -- slots )
class-slots [ initial>> ] map ;
: pad-slots ( slots class -- slots' class )
[ tuple-initial-values over length tail append ] keep ; inline
[ initial-values over length tail append ] keep ; inline
: tuple>array ( tuple -- array )
prepare-tuple>array
@ -72,10 +64,6 @@ PRIVATE>
: tuple-slots ( tuple -- seq )
prepare-tuple>array drop copy-tuple-slots ;
GENERIC: object-slots ( object -- seq )
M: tuple object-slots
tuple-slots ;
GENERIC: slots>tuple ( seq class -- tuple )
M: tuple-class slots>tuple ( seq class -- tuple )
@ -159,7 +147,7 @@ ERROR: bad-superclass class ;
dup boa-check-quot "boa-check" set-word-prop ;
: tuple-prototype ( class -- prototype )
[ tuple-initial-values ] keep over [ ] any?
[ initial-values ] keep over [ ] any?
[ slots>tuple ] [ 2drop f ] if ;
: define-tuple-prototype ( class -- )

21
extra/classes/struct/prettyprint/prettyprint.factor
View File

@ -3,11 +3,28 @@ USING: classes.struct kernel prettyprint.backend prettyprint.custom
prettyprint.sections see.private sequences words ;
IN: classes.struct.prettyprint
<PRIVATE
: struct-definer-word ( class -- word )
struct-slots dup length 2 >=
[ second offset>> 0 = \ UNION-STRUCT: \ STRUCT: ? ]
[ drop \ STRUCT: ] if ;
: struct>assoc ( struct -- assoc )
[ class struct-slots ] [ struct-slot-values ] bi zip filter-tuple-assoc ;
PRIVATE>
M: struct-class see-class*
<colon \ STRUCT: pprint-word dup pprint-word
<block "struct-slots" word-prop [ pprint-slot ] each
<colon dup struct-definer-word pprint-word dup pprint-word
<block struct-slots [ pprint-slot ] each
block> pprint-; block> ;
M: struct pprint-delims
drop \ S{ \ } ;
M: struct >pprint-sequence
[ class ] [ struct-slot-values ] bi class-slot-sequence ;
M: struct pprint*
[ [ \ S{ ] dip [ class ] [ struct>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;

2
extra/classes/struct/struct-docs.factor
View File

@ -31,7 +31,7 @@ HELP: STRUCT:
HELP: S{
{ $syntax "S{ class slots... }" }
{ $values { "class" "a " { $link struct } " class word" } { "slots" "slot values" } }
{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; in fact, " { $snippet "T{" } " and " { $snippet "S{" } " can be used interchangeably. Structs will always be printed with " { $snippet "S{" } "." } ;
{ $description "Marks the beginning of a literal struct. The syntax is identical to tuple literal syntax with " { $link POSTPONE: T{ } { $snippet " }" } "; either the assoc syntax (that is, " { $snippet "S{ class { slot value } { slot value } ... }" } ") or the simple syntax (" { $snippet "S{ class f value value ... }" } ") can be used." } ;
HELP: UNION-STRUCT:
{ $syntax "UNION-STRUCT: class { slot type } { slot type } ... ;" }

31
extra/classes/struct/struct.factor
View File

@ -15,6 +15,9 @@ TUPLE: struct
PREDICATE: struct-class < tuple-class
\ struct subclass-of? ;
M: struct-class struct-slots
"struct-slots" word-prop ;
! struct allocation
M: struct >c-ptr
@ -38,7 +41,7 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
[
[ <wrapper> \ (struct) [ ] 2sequence ]
[
"struct-slots" word-prop
struct-slots
[ length \ ndip ]
[ [ name>> setter-word 1quotation ] map \ spread ] bi
] bi
@ -53,11 +56,13 @@ MACRO: <struct-boa> ( class -- quot: ( ... -- struct ) )
M: struct-class boa>object
swap pad-struct-slots
[ (struct) ] [ "struct-slots" word-prop ] bi
[ (struct) ] [ struct-slots ] bi
[ [ (writer-quot) call( value struct -- ) ] with 2each ] curry keep ;
! Struct slot accessors
GENERIC: struct-slot-values ( struct -- sequence )
M: struct-class reader-quot
nip
[ class>> c-type-getter-boxer ]
@ -66,18 +71,15 @@ M: struct-class reader-quot
M: struct-class writer-quot
nip (writer-quot) ;
M: struct-class class-slots
"struct-slots" word-prop ;
: object-slots-quot ( class -- quot )
"struct-slots" word-prop
: struct-slot-values-quot ( class -- quot )
struct-slots
[ name>> reader-word 1quotation ] map
\ cleave [ ] 2sequence
\ output>array [ ] 2sequence ;
: (define-object-slots-method) ( class -- )
[ \ object-slots create-method-in ]
[ object-slots-quot ] bi define ;
: (define-struct-slot-values-method) ( class -- )
[ \ struct-slot-values create-method-in ]
[ struct-slot-values-quot ] bi define ;
! Struct as c-type
@ -125,7 +127,7 @@ M: struct-class direct-array-of
: struct-prototype ( class -- prototype )
[ heap-size <byte-array> ]
[ memory>struct ]
[ "struct-slots" word-prop ] tri
[ struct-slots ] tri
[
[ initial>> ]
[ (writer-quot) ] bi
@ -134,14 +136,14 @@ M: struct-class direct-array-of
: (struct-word-props) ( class slots size align -- )
[
[ "struct-slots" set-word-prop ]
[ struct-slots ]
[ define-accessors ] 2bi
]
[ "struct-size" set-word-prop ]
[ "struct-align" set-word-prop ] tri-curry*
[ tri ] 3curry
[ dup struct-prototype "prototype" set-word-prop ]
[ (define-object-slots-method) ] tri ;
[ (define-struct-slot-values-method) ] tri ;
: check-struct-slots ( slots -- )
[ class>> c-type drop ] each ;
@ -172,5 +174,4 @@ USING: vocabs vocabs.loader ;
"prettyprint" vocab [ "classes.struct.prettyprint" require ] when
SYNTAX: S{
POSTPONE: T{ ;
scan-word dup struct-slots parse-tuple-literal-slots ;