Merge branch 'master' of git://factorcode.org/git/factor
commit
8198ead0d2
|
@ -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"
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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?
|
||||||
|
|
|
@ -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
|
|
@ -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 ;
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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" }
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -0,0 +1 @@
|
||||||
|
Joe Groff
|
|
@ -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"
|
|
@ -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
|
|
@ -0,0 +1 @@
|
||||||
|
Tracking usage of deprecated words
|
|
@ -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.
|
@ -67,6 +67,7 @@ IN: bootstrap.syntax
|
||||||
"M\\"
|
"M\\"
|
||||||
"]"
|
"]"
|
||||||
"delimiter"
|
"delimiter"
|
||||||
|
"deprecated"
|
||||||
"f"
|
"f"
|
||||||
"flushable"
|
"flushable"
|
||||||
"foldable"
|
"foldable"
|
||||||
|
|
|
@ -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." }
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 } "." }
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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
|
||||||
|
|
||||||
|
|
|
@ -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)
|
||||||
|
|
Loading…
Reference in New Issue