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

basis/bootstrap/tools/tools.factor

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

basis/compiler/cfg/dataflow-analysis/dataflow-analysis.factor

@@ -23,7 +23,11 @@ GENERIC# compute-in-set 2 ( bb out-sets dfa -- set )
 M: kill-block compute-in-set 3drop f ;
 
 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 -- ? )
     bb out-sets dfa compute-in-set

basis/compiler/codegen/codegen.factor

@@ -267,7 +267,7 @@ M: ##alien-global generate-insn
     %alien-global ;
 
 ! ##alien-invoke
-GENERIC: next-fastcall-param ( reg-class -- )
+GENERIC: next-fastcall-param ( rep -- )
 
 : ?dummy-stack-params ( rep -- )
     dummy-stack-params? [ rep-size cell align stack-params +@ ] [ drop ] if ;
@@ -300,7 +300,7 @@ M: reg-class reg-class-full?
     stack-params dup ;
 
 : 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 )
     c-type-rep dup reg-class-of reg-class-full?

basis/compiler/tests/optimizer.factor

@@ -424,4 +424,5 @@ M: object bad-dispatch-position-test* ;
     ] with-compilation-unit
 ] 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

basis/compiler/tree/modular-arithmetic/modular-arithmetic.factor

@@ -172,7 +172,7 @@ MEMO: fixnum-coercion ( flags -- nodes )
     ] when ;
 
 : 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
         [ drop fixnum <class-info> ] change-at
     ] when ;

basis/cpu/ppc/ppc.factor

@@ -89,11 +89,8 @@ HOOK: reserved-area-size os ( -- n )
 : local@ ( n -- x )
     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
 ! 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
     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 ;
 
@@ -478,11 +477,29 @@ M: ppc %compare-branch (%compare) %branch ;
 M: ppc %compare-imm-branch (%compare-imm) %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 ;
 
@@ -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: 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 ( -- )
     ! First parameter is top of stack

basis/help/handbook/handbook.factor

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

basis/see/see.factor

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

basis/tools/deprecation/authors.txt

@@ -0,0 +1 @@
+Joe Groff

basis/tools/deprecation/deprecation-docs.factor

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

basis/tools/deprecation/deprecation.factor

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

basis/tools/deprecation/summary.txt

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

basis/ui/tools/error-list/error-list-docs.factor

@@ -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/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/deprecation-note.tiff" } "Deprecated words used" { $link "tools.deprecation" } }
 } ;
 
 ABOUT: "ui.tools.error-list"

core/bootstrap/syntax.factor

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

core/syntax/syntax-docs.factor

@@ -191,6 +191,10 @@ HELP: 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." } ;
 
+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:
 { $syntax "SYNTAX: foo ... ;" }
 { $description "Defines a parsing word." }

core/syntax/syntax.factor

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

core/words/words-docs.factor

@@ -294,6 +294,16 @@ HELP: 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." } ;
 
+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
 { $values { "word" word } }
 { $description "Declares a word as " { $link POSTPONE: flushable } "." }

core/words/words.factor

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

extra/classes/struct/struct-tests.factor

@@ -1,25 +1,25 @@
 ! (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
 
-STRUCT: foo
+STRUCT: struct-test-foo
     { x char }
     { y int initial: 123 }
     { z boolean } ;
 
-STRUCT: bar
+STRUCT: struct-test-bar
     { 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 foo <struct-boa>   bar <struct-boa>
+    1   2 3 t struct-test-foo <struct-boa>   struct-test-bar <struct-boa>
     {
         [ w>> ] 
         [ foo>> x>> ]
@@ -28,35 +28,85 @@ STRUCT: bar
     } cleave
 ] 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 }
     { 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 ;
 IN: classes.struct.tests
-STRUCT: foo
+STRUCT: struct-test-foo
     { x char initial: 0 } { y int initial: 123 }
     { 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 ;
 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 } ;
 "> ]
-[ [ 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
+

extra/classes/struct/struct.factor

@@ -1,10 +1,11 @@
 ! (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
 classes.tuple.parser classes.tuple.private combinators
 combinators.smart fry generalizations generic.parser kernel
 kernel.private libc macros make math math.order parser
 quotations sequences slots slots.private struct-arrays words ;
+FROM: slots => reader-word writer-word ;
 IN: classes.struct
 
 ! struct class
@@ -92,12 +93,23 @@ M: struct-class writer-quot
 ! Struct as c-type
 
 : 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 -- )
     [
-        [ 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 ]
         [ (unboxer-quot) >>unboxer-quot ]
@@ -171,8 +183,8 @@ M: struct-class direct-array-of
     [ class>> c-type drop ] each ;
 
 : (define-struct-class) ( class slots offsets-quot -- )
-    [ drop struct f define-tuple-class ] swap
+    [ drop struct f define-tuple-class ]
-    '[
+    swap '[
         make-slots dup
         [ check-struct-slots ] _ [ struct-align [ align ] keep ] tri
         (struct-word-props)