Merge branch 'master' of git://factorcode.org/git/factor

db4
Sascha Matzke 2009-08-22 10:15:56 +02:00
commit 8198ead0d2
21 changed files with 253 additions and 70 deletions

View File

@ -14,6 +14,7 @@ IN: bootstrap.tools
"tools.test" "tools.test"
"tools.time" "tools.time"
"tools.threads" "tools.threads"
"tools.deprecation"
"vocabs.hierarchy" "vocabs.hierarchy"
"vocabs.refresh" "vocabs.refresh"
"vocabs.refresh.monitor" "vocabs.refresh.monitor"

View File

@ -23,7 +23,11 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
M: kill-block compute-in-set 3drop f ; M: kill-block compute-in-set 3drop f ;
M:: basic-block compute-in-set ( bb out-sets dfa -- set ) M:: basic-block compute-in-set ( bb out-sets dfa -- set )
bb dfa predecessors [ out-sets at ] map bb dfa join-sets ; ! Only consider initialized sets.
bb dfa predecessors
[ out-sets key? ] filter
[ out-sets at ] map
bb dfa join-sets ;
:: update-in-set ( bb in-sets out-sets dfa -- ? ) :: update-in-set ( bb in-sets out-sets dfa -- ? )
bb out-sets dfa compute-in-set bb out-sets dfa compute-in-set

View File

@ -267,7 +267,7 @@ M: ##alien-global generate-insn
%alien-global ; %alien-global ;
! ##alien-invoke ! ##alien-invoke
GENERIC: next-fastcall-param ( reg-class -- ) GENERIC: next-fastcall-param ( rep -- )
: ?dummy-stack-params ( rep -- ) : ?dummy-stack-params ( rep -- )
dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ; dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
@ -300,7 +300,7 @@ M: reg-class reg-class-full?
stack-params dup ; stack-params dup ;
: alloc-fastcall-param ( rep -- n reg-class rep ) : alloc-fastcall-param ( rep -- n reg-class rep )
[ reg-class-of [ get ] [ inc ] [ ] tri ] keep ; [ [ reg-class-of get ] [ reg-class-of ] [ next-fastcall-param ] tri ] keep ;
: alloc-parameter ( parameter -- reg rep ) : alloc-parameter ( parameter -- reg rep )
c-type-rep dup reg-class-of reg-class-full? c-type-rep dup reg-class-of reg-class-full?

View File

@ -424,4 +424,5 @@ M: object bad-dispatch-position-test* ;
] with-compilation-unit ] with-compilation-unit
] unit-test ] unit-test
[ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with ! Not sure if I want to fix this...
! [ t [ [ f ] [ 3 ] if >fixnum ] compile-call ] [ no-method? ] must-fail-with

View File

@ -172,7 +172,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
] when ; ] when ;
: optimize-low-order-op ( #call -- nodes ) : optimize-low-order-op ( #call -- nodes )
dup in-d>> first fixnum-value? [ dup in-d>> first actually-defined-by [ value>> fixnum-value? ] all? [
[ ] [ in-d>> first ] [ info>> ] tri [ ] [ in-d>> first ] [ info>> ] tri
[ drop fixnum <class-info> ] change-at [ drop fixnum <class-info> ] change-at
] when ; ] when ;

View File

@ -89,11 +89,8 @@ HOOK: reserved-area-size os ( -- n )
: local@ ( n -- x ) : local@ ( n -- x )
reserved-area-size param-save-size + + ; inline reserved-area-size param-save-size + + ; inline
: spill-integer@ ( n -- offset ) : spill@ ( n -- offset )
spill-integer-offset local@ ; spill-offset local@ ;
: spill-float@ ( n -- offset )
spill-float-offset local@ ;
! Some FP intrinsics need a temporary scratch area in the stack ! Some FP intrinsics need a temporary scratch area in the stack
! frame, 8 bytes in size. This is in the param-save area so it ! frame, 8 bytes in size. This is in the param-save area so it
@ -275,9 +272,11 @@ M:: ppc %float>integer ( dst src -- )
fp-scratch-reg 1 0 scratch@ STFD fp-scratch-reg 1 0 scratch@ STFD
dst 1 4 scratch@ LWZ ; dst 1 4 scratch@ LWZ ;
M: ppc %copy ( dst src -- ) MR ; M: ppc %copy ( dst src rep -- )
{
M: ppc %copy-float ( dst src -- ) FMR ; { int-rep [ MR ] }
{ double-float-rep [ FMR ] }
} case ;
M: ppc %unbox-float ( dst src -- ) float-offset LFD ; M: ppc %unbox-float ( dst src -- ) float-offset LFD ;
@ -478,11 +477,29 @@ M: ppc %compare-branch (%compare) %branch ;
M: ppc %compare-imm-branch (%compare-imm) %branch ; M: ppc %compare-imm-branch (%compare-imm) %branch ;
M: ppc %compare-float-branch (%compare-float) %branch ; M: ppc %compare-float-branch (%compare-float) %branch ;
M: ppc %spill-integer ( src n -- ) spill-integer@ 1 swap STW ; : load-from-frame ( dst n rep -- )
M: ppc %reload-integer ( dst n -- ) spill-integer@ 1 swap LWZ ; {
{ int-rep [ [ 1 ] dip LWZ ] }
{ single-float-rep [ [ 1 ] dip LFS ] }
{ double-float-rep [ [ 1 ] dip LFD ] }
{ stack-params [ [ 0 1 ] dip LWZ [ 0 1 ] dip param@ STW ] }
} case ;
M: ppc %spill-float ( src n -- ) spill-float@ 1 swap STFD ; : next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
M: ppc %reload-float ( dst n -- ) spill-float@ 1 swap LFD ;
: store-to-frame ( src n rep -- )
{
{ int-rep [ [ 1 ] dip STW ] }
{ single-float-rep [ [ 1 ] dip STFS ] }
{ double-float-rep [ [ 1 ] dip STFD ] }
{ stack-params [ [ [ 0 1 ] dip next-param@ LWZ 0 1 ] dip STW ] }
} case ;
M: ppc %spill ( src n rep -- )
[ spill@ ] dip store-to-frame ;
M: ppc %reload ( dst n rep -- )
[ spill@ ] dip load-from-frame ;
M: ppc %loop-entry ; M: ppc %loop-entry ;
@ -490,26 +507,11 @@ M: int-regs return-reg drop 3 ;
M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ; M: int-regs param-regs drop { 3 4 5 6 7 8 9 10 } ;
M: float-regs return-reg drop 1 ; M: float-regs return-reg drop 1 ;
M: int-regs %save-param-reg drop 1 rot local@ STW ; M:: ppc %save-param-reg ( stack reg rep -- )
M: int-regs %load-param-reg drop 1 rot local@ LWZ ; reg stack local@ rep store-to-frame ;
M: single-float-rep %save-param-reg drop 1 rot local@ STFS ; M:: ppc %load-param-reg ( stack reg rep -- )
M: single-float-rep %load-param-reg 1 rot local@ LFS ; reg stack local@ rep load-from-frame ;
M: double-float-rep %save-param-reg drop 1 rot local@ STFD ;
M: double-float-rep %load-param-reg 1 rot local@ LFD ;
M: stack-params %load-param-reg ( stack reg rep -- )
drop [ 0 1 rot local@ LWZ 0 1 ] dip param@ STW ;
: next-param@ ( n -- x ) param@ stack-frame get total-size>> + ;
M: stack-params %save-param-reg ( stack reg rep -- )
#! Funky. Read the parameter from the caller's stack frame.
#! This word is used in callbacks
drop
[ 0 1 ] dip next-param@ LWZ
[ 0 1 ] dip local@ STW ;
M: ppc %prepare-unbox ( -- ) M: ppc %prepare-unbox ( -- )
! First parameter is top of stack ! First parameter is top of stack

View File

@ -288,6 +288,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools"
{ $subsection "prettyprint" } { $subsection "prettyprint" }
{ $subsection "inspector" } { $subsection "inspector" }
{ $subsection "tools.annotations" } { $subsection "tools.annotations" }
{ $subsection "tools.deprecation" }
{ $subsection "tools.inference" } { $subsection "tools.inference" }
{ $heading "Browsing" } { $heading "Browsing" }
{ $subsection "see" } { $subsection "see" }

View File

@ -101,6 +101,7 @@ M: object declarations. drop ;
M: word declarations. M: word declarations.
{ {
POSTPONE: delimiter POSTPONE: delimiter
POSTPONE: deprecated
POSTPONE: inline POSTPONE: inline
POSTPONE: recursive POSTPONE: recursive
POSTPONE: foldable POSTPONE: foldable
@ -229,4 +230,4 @@ PRIVATE>
] { } make prune ; ] { } make prune ;
: see-methods ( word -- ) : see-methods ( word -- )
methods see-all nl ; methods see-all nl ;

View File

@ -0,0 +1 @@
Joe Groff

View File

@ -0,0 +1,13 @@
! (c)2009 Joe Groff bsd license
USING: help.markup help.syntax kernel words ;
IN: tools.deprecation
HELP: :deprecations
{ $description "Prints all deprecation notes." } ;
ARTICLE: "tools.deprecation" "Deprecation tracking"
"Factor's core syntax defines a " { $link POSTPONE: deprecated } " word that can be applied to words to mark them as deprecated. When the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, notes will be collected and reported by the " { $link "tools.errors" } " mechanism when deprecated words are used to define other words."
{ $subsection POSTPONE: deprecated }
{ $subsection :deprecations } ;
ABOUT: "tools.deprecation"

View File

@ -0,0 +1,73 @@
! (c)2009 Joe Groff bsd license
USING: accessors arrays assocs compiler.units
debugger init io kernel namespaces prettyprint sequences
source-files.errors summary tools.crossref
tools.crossref.private tools.errors words ;
IN: tools.deprecation
SYMBOL: +deprecation-note+
SYMBOL: deprecation-notes
deprecation-notes [ H{ } clone ] initialize
TUPLE: deprecation-note < source-file-error ;
M: deprecation-note error-type drop +deprecation-note+ ;
TUPLE: deprecated-usages asset usages ;
: :deprecations ( -- )
deprecation-notes get-global values errors. ;
T{ error-type
{ type +deprecation-note+ }
{ word ":deprecations" }
{ plural "deprecated word usages" }
{ icon "vocab:ui/tools/error-list/icons/deprecation-note.tiff" }
{ quot [ deprecation-notes get values ] }
{ forget-quot [ deprecation-notes get delete-at ] }
} define-error-type
: <deprecation-note> ( error word -- deprecation-note )
\ deprecation-note <definition-error> ;
: deprecation-note ( word usages -- )
[ deprecated-usages boa ]
[ drop <deprecation-note> ]
[ drop deprecation-notes get-global set-at ] 2tri ;
: clear-deprecation-note ( word -- )
deprecation-notes get-global delete-at ;
: check-deprecations ( word -- )
dup "forgotten" word-prop
[ clear-deprecation-note ] [
dup def>> uses [ deprecated? ] filter
[ clear-deprecation-note ] [ >array deprecation-note ] if-empty
] if ;
M: deprecated-usages summary
drop "Deprecated words used" ;
M: deprecated-usages error.
"The definition of " write
dup asset>> pprint
" uses these deprecated words:" write nl
usages>> [ " " write pprint nl ] each ;
SINGLETON: deprecation-observer
: initialize-deprecation-notes ( -- )
get-crossref [ drop deprecated? ] assoc-filter
values [ keys [ check-deprecations ] each ] each ;
M: deprecation-observer definitions-changed
drop keys [ word? ] filter
dup [ deprecated? ] filter empty?
[ [ check-deprecations ] each ]
[ drop initialize-deprecation-notes ] if ;
[ \ deprecation-observer add-definition-observer ]
"tools.deprecation" add-init-hook
initialize-deprecation-notes

View File

@ -0,0 +1 @@
Tracking usage of deprecated words

View File

@ -14,6 +14,7 @@ $nl
{ { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } } { { $image "vocab:ui/tools/error-list/icons/linkage-error.tiff" } "Linkage error" { $link "loading-libs" } }
{ { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } } { { $image "vocab:ui/tools/error-list/icons/help-lint-error.tiff" } "Help lint failure" { $link "help.lint" } }
{ { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } } { { $image "vocab:ui/tools/error-list/icons/unit-test-error.tiff" } "Unit test failure" { $link "tools.test" } }
{ { $image "vocab:ui/tools/error-list/icons/deprecation-note.tiff" } "Deprecated words used" { $link "tools.deprecation" } }
} ; } ;
ABOUT: "ui.tools.error-list" ABOUT: "ui.tools.error-list"

Binary file not shown.

View File

@ -67,6 +67,7 @@ IN: bootstrap.syntax
"M\\" "M\\"
"]" "]"
"delimiter" "delimiter"
"deprecated"
"f" "f"
"flushable" "flushable"
"foldable" "foldable"

View File

@ -191,6 +191,10 @@ HELP: delimiter
{ $syntax ": foo ... ; delimiter" } { $syntax ": foo ... ; delimiter" }
{ $description "Declares the most recently defined word as a delimiter. Delimiters are words which are only ever valid as the end of a nested block to be read by " { $link parse-until } ". An unpaired occurrence of a delimiter is a parse error." } ; { $description "Declares the most recently defined word as a delimiter. Delimiters are words which are only ever valid as the end of a nested block to be read by " { $link parse-until } ". An unpaired occurrence of a delimiter is a parse error." } ;
HELP: deprecated
{ $syntax ": foo ... ; deprecated" }
{ $description "Declares the most recently defined word as deprecated. If the " { $vocab-link "tools.deprecation" } " vocabulary is loaded, usages of deprecated words will be noted as they are made." } ;
HELP: SYNTAX: HELP: SYNTAX:
{ $syntax "SYNTAX: foo ... ;" } { $syntax "SYNTAX: foo ... ;" }
{ $description "Defines a parsing word." } { $description "Defines a parsing word." }

View File

@ -111,6 +111,7 @@ IN: bootstrap.syntax
"foldable" [ word make-foldable ] define-core-syntax "foldable" [ word make-foldable ] define-core-syntax
"flushable" [ word make-flushable ] define-core-syntax "flushable" [ word make-flushable ] define-core-syntax
"delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax "delimiter" [ word t "delimiter" set-word-prop ] define-core-syntax
"deprecated" [ word make-deprecated ] define-core-syntax
"SYNTAX:" [ "SYNTAX:" [
CREATE-WORD parse-definition define-syntax CREATE-WORD parse-definition define-syntax

View File

@ -294,6 +294,16 @@ HELP: delimiter?
{ $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." } { $description "Tests if an object is a delimiter word declared by " { $link POSTPONE: delimiter } "." }
{ $notes "Outputs " { $link f } " if the object is not a word." } ; { $notes "Outputs " { $link f } " if the object is not a word." } ;
HELP: deprecated?
{ $values { "obj" object } { "?" "a boolean" } }
{ $description "Tests if an object is " { $link POSTPONE: deprecated } "." }
{ $notes "Outputs " { $link f } " if the object is not a word." } ;
HELP: make-deprecated
{ $values { "word" word } }
{ $description "Declares a word as " { $link POSTPONE: deprecated } "." }
{ $side-effects "word" } ;
HELP: make-flushable HELP: make-flushable
{ $values { "word" word } } { $values { "word" word } }
{ $description "Declares a word as " { $link POSTPONE: flushable } "." } { $description "Declares a word as " { $link POSTPONE: flushable } "." }

View File

@ -123,6 +123,9 @@ M: word subwords drop f ;
: define-declared ( word def effect -- ) : define-declared ( word def effect -- )
[ nip swap set-stack-effect ] [ drop define ] 3bi ; [ nip swap set-stack-effect ] [ drop define ] 3bi ;
: make-deprecated ( word -- )
t "deprecated" set-word-prop ;
: make-inline ( word -- ) : make-inline ( word -- )
dup inline? [ drop ] [ dup inline? [ drop ] [
[ t "inline" set-word-prop ] [ t "inline" set-word-prop ]
@ -148,7 +151,7 @@ M: word reset-word
{ {
"unannotated-def" "parsing" "inline" "recursive" "unannotated-def" "parsing" "inline" "recursive"
"foldable" "flushable" "reading" "writing" "reader" "foldable" "flushable" "reading" "writing" "reader"
"writer" "delimiter" "writer" "delimiter" "deprecated"
} reset-props ; } reset-props ;
: reset-generic ( word -- ) : reset-generic ( word -- )
@ -200,6 +203,9 @@ M: parsing-word definer drop \ SYNTAX: \ ; ;
: delimiter? ( obj -- ? ) : delimiter? ( obj -- ? )
dup word? [ "delimiter" word-prop ] [ drop f ] if ; dup word? [ "delimiter" word-prop ] [ drop f ] if ;
: deprecated? ( obj -- ? )
dup word? [ "deprecated" word-prop ] [ drop f ] if ;
! Definition protocol ! Definition protocol
M: word where "loc" word-prop ; M: word where "loc" word-prop ;
@ -217,4 +223,4 @@ M: word hashcode*
M: word literalize <wrapper> ; M: word literalize <wrapper> ;
INSTANCE: word definition INSTANCE: word definition

View File

@ -1,25 +1,25 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors alien.c-types classes.c-types classes.struct USING: accessors alien.c-types alien.structs.fields classes.c-types
combinators io.streams.string kernel libc math multiline namespaces classes.struct combinators io.streams.string kernel libc literals math
prettyprint prettyprint.config see tools.test ; multiline namespaces prettyprint prettyprint.config see tools.test ;
IN: classes.struct.tests IN: classes.struct.tests
STRUCT: foo STRUCT: struct-test-foo
{ x char } { x char }
{ y int initial: 123 } { y int initial: 123 }
{ z boolean } ; { z boolean } ;
STRUCT: bar STRUCT: struct-test-bar
{ w ushort initial: HEX: ffff } { w ushort initial: HEX: ffff }
{ foo foo } ; { foo struct-test-foo } ;
[ 12 ] [ foo heap-size ] unit-test [ 12 ] [ struct-test-foo heap-size ] unit-test
[ 16 ] [ bar heap-size ] unit-test [ 16 ] [ struct-test-bar heap-size ] unit-test
[ 123 ] [ foo <struct> y>> ] unit-test [ 123 ] [ struct-test-foo <struct> y>> ] unit-test
[ 123 ] [ bar <struct> foo>> y>> ] unit-test [ 123 ] [ struct-test-bar <struct> foo>> y>> ] unit-test
[ 1 2 3 t ] [ [ 1 2 3 t ] [
1 2 3 t foo <struct-boa> bar <struct-boa> 1 2 3 t struct-test-foo <struct-boa> struct-test-bar <struct-boa>
{ {
[ w>> ] [ w>> ]
[ foo>> x>> ] [ foo>> x>> ]
@ -28,35 +28,85 @@ STRUCT: bar
} cleave } cleave
] unit-test ] unit-test
[ 7654 ] [ S{ foo f 98 7654 f } y>> ] unit-test [ 7654 ] [ S{ struct-test-foo f 98 7654 f } y>> ] unit-test
[ 7654 ] [ S{ foo { y 7654 } } y>> ] unit-test [ 7654 ] [ S{ struct-test-foo { y 7654 } } y>> ] unit-test
UNION-STRUCT: float-and-bits UNION-STRUCT: struct-test-float-and-bits
{ f single-float } { f single-float }
{ bits uint } ; { bits uint } ;
[ 1.0 ] [ float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test [ 1.0 ] [ struct-test-float-and-bits <struct> 1.0 float>bits >>bits f>> ] unit-test
[ 4 ] [ float-and-bits heap-size ] unit-test [ 4 ] [ struct-test-float-and-bits heap-size ] unit-test
[ ] [ foo malloc-struct free ] unit-test [ ] [ struct-test-foo malloc-struct free ] unit-test
[ "S{ foo { y 7654 } }" ] [ "S{ struct-test-foo { y 7654 } }" ]
[ f boa-tuples? [ foo <struct> 7654 >>y [ pprint ] with-string-writer ] with-variable ] unit-test [
f boa-tuples?
[ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
with-variable
] unit-test
[ "S{ foo f 0 7654 f }" ] [ "S{ struct-test-foo f 0 7654 f }" ]
[ t boa-tuples? [ foo <struct> 7654 >>y [ pprint ] with-string-writer ] with-variable ] unit-test [
t boa-tuples?
[ struct-test-foo <struct> 7654 >>y [ pprint ] with-string-writer ]
with-variable
] unit-test
[ <" USING: classes.c-types classes.struct kernel ; [ <" USING: classes.c-types classes.struct kernel ;
IN: classes.struct.tests IN: classes.struct.tests
STRUCT: foo STRUCT: struct-test-foo
{ x char initial: 0 } { y int initial: 123 } { x char initial: 0 } { y int initial: 123 }
{ z boolean initial: f } ; { z boolean initial: f } ;
"> ] "> ]
[ [ foo see ] with-string-writer ] unit-test [ [ struct-test-foo see ] with-string-writer ] unit-test
[ <" USING: classes.c-types classes.struct ; [ <" USING: classes.c-types classes.struct ;
IN: classes.struct.tests IN: classes.struct.tests
UNION-STRUCT: float-and-bits UNION-STRUCT: struct-test-float-and-bits
{ f single-float initial: 0.0 } { bits uint initial: 0 } ; { f single-float initial: 0.0 } { bits uint initial: 0 } ;
"> ] "> ]
[ [ float-and-bits see ] with-string-writer ] unit-test [ [ struct-test-float-and-bits see ] with-string-writer ] unit-test
[ {
T{ field-spec
{ name "x" }
{ offset 0 }
{ type $[ char c-type ] }
{ reader x>> }
{ writer (>>x) }
}
T{ field-spec
{ name "y" }
{ offset 4 }
{ type $[ int c-type ] }
{ reader y>> }
{ writer (>>y) }
}
T{ field-spec
{ name "z" }
{ offset 8 }
{ type $[ boolean c-type ] }
{ reader z>> }
{ writer (>>z) }
}
} ] [ "struct-test-foo" c-type fields>> ] unit-test
[ {
T{ field-spec
{ name "f" }
{ offset 0 }
{ type $[ single-float c-type ] }
{ reader f>> }
{ writer (>>f) }
}
T{ field-spec
{ name "bits" }
{ offset 0 }
{ type $[ uint c-type ] }
{ reader bits>> }
{ writer (>>bits) }
}
} ] [ "struct-test-float-and-bits" c-type fields>> ] unit-test

View File

@ -1,10 +1,11 @@
! (c)Joe Groff bsd license ! (c)Joe Groff bsd license
USING: accessors alien alien.c-types alien.structs arrays USING: accessors alien alien.c-types alien.structs alien.structs.fields arrays
byte-arrays classes classes.c-types classes.parser classes.tuple byte-arrays classes classes.c-types classes.parser classes.tuple
classes.tuple.parser classes.tuple.private combinators classes.tuple.parser classes.tuple.private combinators
combinators.smart fry generalizations generic.parser kernel combinators.smart fry generalizations generic.parser kernel
kernel.private libc macros make math math.order parser kernel.private libc macros make math math.order parser
quotations sequences slots slots.private struct-arrays words ; quotations sequences slots slots.private struct-arrays words ;
FROM: slots => reader-word writer-word ;
IN: classes.struct IN: classes.struct
! struct class ! struct class
@ -92,12 +93,23 @@ M: struct-class writer-quot
! Struct as c-type ! Struct as c-type
: slot>field ( slot -- field ) : slot>field ( slot -- field )
[ class>> c-type ] [ name>> ] bi 2array ; field-spec new swap {
[ name>> >>name ]
[ offset>> >>offset ]
[ class>> c-type >>type ]
[ name>> reader-word >>reader ]
[ name>> writer-word >>writer ]
} cleave ;
: define-struct-for-class ( class -- ) : define-struct-for-class ( class -- )
[ [
[ name>> ] [ vocabulary>> ] [ struct-slots [ slot>field ] map ] tri {
define-struct [ name>> ]
[ "struct-size" word-prop ]
[ "struct-align" word-prop ]
[ struct-slots [ slot>field ] map ]
} cleave
(define-struct)
] [ ] [
[ name>> c-type ] [ name>> c-type ]
[ (unboxer-quot) >>unboxer-quot ] [ (unboxer-quot) >>unboxer-quot ]
@ -171,8 +183,8 @@ M: struct-class direct-array-of
[ class>> c-type drop ] each ; [ class>> c-type drop ] each ;
: (define-struct-class) ( class slots offsets-quot -- ) : (define-struct-class) ( class slots offsets-quot -- )
[ drop struct f define-tuple-class ] swap [ drop struct f define-tuple-class ]
'[ swap '[
make-slots dup make-slots dup
[ check-struct-slots ] _ [ struct-align [ align ] keep ] tri [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
(struct-word-props) (struct-word-props)