diff --git a/basis/inverse/inverse.factor b/basis/inverse/inverse.factor index 39a2d5f3dc..6b1e839ca6 100755 --- a/basis/inverse/inverse.factor +++ b/basis/inverse/inverse.factor @@ -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] ; \ No newline at end of file +MACRO: switch ( quot-alist -- ) [switch] ; diff --git a/basis/prettyprint/backend/backend.factor b/basis/prettyprint/backend/backend.factor index 2f87e5ab05..247067673e 100644 --- a/basis/prettyprint/backend/backend.factor +++ b/basis/prettyprint/backend/backend.factor @@ -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 -- ) ] bi* \ } pprint-word block> ; +: (pprint-tuple) ( opener class slots closer -- ) + ] + [ 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 ] [ - [ - 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 ; diff --git a/core/classes/tuple/parser/parser.factor b/core/classes/tuple/parser/parser.factor index 39a5d56f71..7ba850f744 100644 --- a/core/classes/tuple/parser/parser.factor +++ b/core/classes/tuple/parser/parser.factor @@ -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 ] 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 ; diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index 1452abd4b4..0a437a3d69 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -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 -- ) diff --git a/extra/classes/struct/prettyprint/prettyprint.factor b/extra/classes/struct/prettyprint/prettyprint.factor index b63f153b16..517aa343c6 100644 --- a/extra/classes/struct/prettyprint/prettyprint.factor +++ b/extra/classes/struct/prettyprint/prettyprint.factor @@ -3,11 +3,28 @@ USING: classes.struct kernel prettyprint.backend prettyprint.custom prettyprint.sections see.private sequences words ; IN: classes.struct.prettyprint += + [ 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* - 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 ; diff --git a/extra/classes/struct/struct-docs.factor b/extra/classes/struct/struct-docs.factor index 90247a0495..83d5859f7c 100644 --- a/extra/classes/struct/struct-docs.factor +++ b/extra/classes/struct/struct-docs.factor @@ -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 } ... ;" } diff --git a/extra/classes/struct/struct.factor b/extra/classes/struct/struct.factor index d52c25e413..2b2aa49aeb 100644 --- a/extra/classes/struct/struct.factor +++ b/extra/classes/struct/struct.factor @@ -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: ( class -- quot: ( ... -- struct ) ) [ [ \ (struct) [ ] 2sequence ] [ - "struct-slots" word-prop + struct-slots [ length \ ndip ] [ [ name>> setter-word 1quotation ] map \ spread ] bi ] bi @@ -53,11 +56,13 @@ MACRO: ( 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 ] [ 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 ;