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

basis/alien/structs/fields/fields.factor

@@ -0,0 +1,76 @@
+! Copyright (C) 2005, 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors arrays kernel kernel.private math namespaces
+sequences strings words effects combinators alien.c-types ;
+IN: alien.structs.fields
+
+TUPLE: field-spec name offset type reader writer ;
+
+: reader-effect ( type spec -- effect )
+    [ 1array ] [ name>> 1array ] bi* <effect> ;
+
+PREDICATE: slot-reader < word "reading" word-prop >boolean ;
+
+: set-reader-props ( class spec -- )
+    2dup reader-effect
+    over reader>>
+    swap "declared-effect" set-word-prop
+    reader>> swap "reading" set-word-prop ;
+
+: writer-effect ( type spec -- effect )
+    name>> swap 2array 0 <effect> ;
+
+PREDICATE: slot-writer < word "writing" word-prop >boolean ;
+
+: set-writer-props ( class spec -- )
+    2dup writer-effect
+    over writer>>
+    swap "declared-effect" set-word-prop
+    writer>> swap "writing" set-word-prop ;
+
+: reader-word ( class name vocab -- word )
+    >r >r "-" r> 3append r> create ;
+
+: writer-word ( class name vocab -- word )
+    >r [ swap "set-" % % "-" % % ] "" make r> create ;
+
+: <field-spec> ( struct-name vocab type field-name -- spec )
+    field-spec new
+        0 >>offset
+        swap >>name
+        swap expand-constants >>type
+        3dup name>> swap reader-word >>reader
+        3dup name>> swap writer-word >>writer
+    2nip ;
+
+: align-offset ( offset type -- offset )
+    c-type-align align ;
+
+: struct-offsets ( specs -- size )
+    0 [
+        [ type>> align-offset ] keep
+        [ (>>offset) ] [ type>> heap-size + ] 2bi
+    ] reduce ;
+
+: define-struct-slot-word ( spec word quot -- )
+    rot offset>> prefix define-inline ;
+
+: define-getter ( type spec -- )
+    [ set-reader-props ] keep
+    [ ]
+    [ reader>> ]
+    [
+        type>>
+        [ c-getter ] [ c-type-boxer-quot ] bi append
+    ] tri
+    define-struct-slot-word ;
+
+: define-setter ( type spec -- )
+    [ set-writer-props ] keep
+    [ ]
+    [ writer>> ]
+    [ type>> c-setter ] tri
+    define-struct-slot-word ;
+
+: define-field ( type spec -- )
+    [ define-getter ] [ define-setter ] 2bi ;

basis/alien/structs/structs-docs.factor

@@ -1,75 +1,7 @@
-IN: alien.structs
 USING: accessors alien.c-types strings help.markup help.syntax
-alien.syntax sequences io arrays slots.deprecated
-kernel words slots assocs namespaces accessors ;
-
-! Deprecated code
-: ($spec-reader-values) ( slot-spec class -- element )
-    dup ?word-name swap 2array
-    over name>>
-    rot class>> 2array 2array
-    [ { $instance } swap suffix ] assoc-map ;
-
-: $spec-reader-values ( slot-spec class -- )
-    ($spec-reader-values) $values ;
-
-: $spec-reader-description ( slot-spec class -- )
-    [
-        "Outputs the value stored in the " ,
-        { $snippet } rot name>> suffix ,
-        " slot of " ,
-        { $instance } swap suffix ,
-        " instance." ,
-    ] { } make $description ;
-
-: slot-of-reader ( reader specs -- spec/f )
-    [ reader>> eq? ] with find nip ;
-
-: $spec-reader ( reader slot-specs class -- )
-    >r slot-of-reader r>
-    over [
-        2dup $spec-reader-values
-        2dup $spec-reader-description
-    ] when 2drop ;
-
-GENERIC: slot-specs ( help-type -- specs )
-
-M: word slot-specs "slots" word-prop ;
-
-: $slot-reader ( reader -- )
-    first dup "reading" word-prop [ slot-specs ] keep
-    $spec-reader ;
-
-: $spec-writer-values ( slot-spec class -- )
-    ($spec-reader-values) reverse $values ;
-
-: $spec-writer-description ( slot-spec class -- )
-    [
-        "Stores a new value to the " ,
-        { $snippet } rot name>> suffix ,
-        " slot of " ,
-        { $instance } swap suffix ,
-        " instance." ,
-    ] { } make $description ;
-
-: slot-of-writer ( writer specs -- spec/f )
-    [ writer>> eq? ] with find nip ;
-
-: $spec-writer ( writer slot-specs class -- )
-    >r slot-of-writer r>
-    over [
-        2dup $spec-writer-values
-        2dup $spec-writer-description
-        dup ?word-name 1array $side-effects
-    ] when 2drop ;
-
-: $slot-writer ( reader -- )
-    first dup "writing" word-prop [ slot-specs ] keep
-    $spec-writer ;
-
-M: string slot-specs c-type fields>> ;
-
-M: array ($instance) first ($instance) " array" write ;
+alien.syntax sequences io arrays kernel words assocs namespaces
+accessors ;
+IN: alien.structs
 
 ARTICLE: "c-structs" "C structure types"
 "A " { $snippet "struct" } " in C is essentially a block of memory with the value of each structure field stored at a fixed offset from the start of the block. The C library interface provides some utilities to define words which read and write structure fields given a base address."

basis/alien/structs/structs.factor

@@ -1,43 +1,10 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors arrays generic hashtables kernel kernel.private
-math namespaces parser sequences strings words libc slots
-slots.deprecated alien.c-types cpu.architecture ;
+math namespaces parser sequences strings words libc
+alien.c-types alien.structs.fields cpu.architecture ;
 IN: alien.structs
 
-: align-offset ( offset type -- offset )
-    c-type-align align ;
-
-: struct-offsets ( specs -- size )
-    0 [
-        [ class>> align-offset ] keep
-        [ (>>offset) ] 2keep
-        class>> heap-size +
-    ] reduce ;
-
-: define-struct-slot-word ( spec word quot -- )
-    rot offset>> prefix define-inline ;
-
-: define-getter ( type spec -- )
-    [ set-reader-props ] keep
-    [ ]
-    [ reader>> ]
-    [
-        class>>
-        [ c-getter ] [ c-type-boxer-quot ] bi append
-    ] tri
-    define-struct-slot-word ;
-
-: define-setter ( type spec -- )
-    [ set-writer-props ] keep
-    [ ]
-    [ writer>> ]
-    [ class>> c-setter ] tri
-    define-struct-slot-word ;
-
-: define-field ( type spec -- )
-    2dup define-getter define-setter ;
-
 : if-value-structs? ( ctype true false -- )
     value-structs?
     [ drop call ] [ >r 2drop "void*" r> call ] if ; inline
@@ -76,17 +43,8 @@ M: struct-type stack-size
     struct-type boa
     -rot define-c-type ;
 
-: make-field ( struct-name vocab type field-name -- spec )
-    <slot-spec>
-        0 >>offset
-        swap >>name
-        swap expand-constants >>class
-        3dup name>> swap reader-word >>reader
-        3dup name>> swap writer-word >>writer
-    2nip ;
-
 : define-struct-early ( name vocab fields -- fields )
-    -rot [ rot first2 make-field ] 2curry map ;
+    -rot [ rot first2 <field-spec> ] 2curry map ;
 
 : compute-struct-align ( types -- n )
     [ c-type-align ] map supremum ;
@@ -94,7 +52,7 @@ M: struct-type stack-size
 : define-struct ( name vocab fields -- )
     pick >r
     [ struct-offsets ] keep
-    [ [ class>> ] map compute-struct-align ] keep
+    [ [ type>> ] map compute-struct-align ] keep
     [ (define-struct) ] keep
     r> [ swap define-field ] curry each ;
 

basis/compiler/compiler.factor

@@ -43,8 +43,8 @@ SYMBOL: +failed+
     [
         dup crossref?
         [
-            dependencies get
-            generic-dependencies get
+            dependencies get >alist
+            generic-dependencies get >alist
             compiled-xref
         ] [ drop ] if
     ] tri ;

basis/cpu/x86/64/64.factor

@@ -178,7 +178,7 @@ stack-params "__stack_value" c-type (>>reg-class) >>
 
 : struct-types&offset ( struct-type -- pairs )
     fields>> [
-        [ class>> ] [ offset>> ] bi 2array
+        [ type>> ] [ offset>> ] bi 2array
     ] map ;
 
 : split-struct ( pairs -- seq )

basis/db/pools/pools-tests.factor

@@ -13,7 +13,7 @@ USE: db.sqlite
 
 [ "pool-test.db" temp-file delete-file ] ignore-errors
 
-[ ] [ "pool-test.db" sqlite-db <db-pool> "pool" set ] unit-test
+[ ] [ "pool-test.db" temp-file sqlite-db <db-pool> "pool" set ] unit-test
 
 [ ] [ "pool" get expired>> t >>expired drop ] unit-test
 

basis/debugger/threads/threads.factor

@@ -10,14 +10,17 @@ IN: debugger.threads
         dup id>> #
         " (" % dup name>> %
         ", " % dup quot>> unparse-short % ")" %
-    ] "" make swap write-object ":" print nl ;
+    ] "" make swap write-object ":" print ;
 
 M: thread error-in-thread ( error thread -- )
     initial-thread get-global eq? [
         die drop
     ] [
         global [
-            error-thread get-global error-in-thread. print-error flush
+            error-thread get-global error-in-thread. nl
+            print-error nl
+            :c
+            flush
         ] bind
     ] if ;
 

basis/mirrors/mirrors-docs.factor

@@ -30,7 +30,7 @@ HELP: <mirror> ( object -- mirror )
         "TUPLE: circle center radius ;"
         "C: <circle> circle"
         "{ 100 50 } 15 <circle> <mirror> >alist ."
-        "{ { \"delegate\" f } { \"center\" { 100 50 } } { \"radius\" 15 } }"
+        "{ { \"center\" { 100 50 } } { \"radius\" 15 } }"
     }
 } ;
 

basis/stack-checker/state/state.factor

@@ -89,8 +89,11 @@ SYMBOL: meta-r
 SYMBOL: dependencies
 
 : depends-on ( word how -- )
-    dependencies get dup
-    [ swap '[ , strongest-dependency ] change-at ] [ 3drop ] if ;
+    over primitive? [ 2drop ] [
+        dependencies get dup [
+            swap '[ , strongest-dependency ] change-at
+        ] [ 3drop ] if
+    ] if ;
 
 ! Generic words that the current quotation depends on
 SYMBOL: generic-dependencies

basis/tools/scaffold/authors.txt

@@ -0,0 +1 @@
+Doug Coleman

basis/tools/scaffold/scaffold-docs.factor

@@ -0,0 +1,47 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel strings words ;
+IN: tools.scaffold
+
+HELP: developer-name
+{ $description "Set this symbol to hold your name so that the scaffold tools can generate the correct file header for copyright. Setting this variable in your .factor-boot-rc file is recommended." }
+{ $unchecked-example "USING: namespaces tools.scaffold ;\n\"Stacky Guy\" developer-name set-global" } ;
+
+HELP: help.
+{ $values
+     { "word" word } }
+{ $description "Prints out scaffold help markup for a given word." } ;
+
+HELP: scaffold-help
+{ $values
+     { "vocab-root" "a vocabulary root string" } { "string" string } }
+{ $description "Takes an existing vocabulary and creates a help file with scaffolded help for each word. This word only works if no help file yet exists." } ;
+
+HELP: scaffold-undocumented
+{ $values
+     { "string" string } }
+{ $description "Prints scaffolding documenation for undocumented words in a vocabuary except for automatically generated class predicates." } ;
+
+{ scaffold-help scaffold-undocumented } related-words
+
+HELP: scaffold-vocab
+{ $values
+     { "vocab-root" "a vocabulary root string" } { "string" string } }
+{ $description "Creates a direcory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
+
+HELP: using
+{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ;
+
+ARTICLE: "tools.scaffold" "Scaffold tool"
+"Scaffold setup:"
+{ $subsection developer-name }
+"Generate new vocabs:"
+{ $subsection scaffold-vocab }
+"Generate help scaffolding:"
+{ $subsection scaffold-help }
+{ $subsection scaffold-undocumented }
+{ $subsection help. }
+"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead."
+;
+
+ABOUT: "tools.scaffold"

basis/tools/scaffold/scaffold.factor

@@ -0,0 +1,222 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs io.files hashtables kernel namespaces sequences
+vocabs.loader io combinators io.encodings.utf8 calendar accessors
+math.parser io.streams.string ui.tools.operations quotations
+strings arrays prettyprint words vocabs sorting sets cords
+classes sequences.lib combinators.lib ;
+IN: tools.scaffold
+
+SYMBOL: developer-name
+SYMBOL: using
+
+ERROR: not-a-vocab-root string ;
+ERROR: vocab-name-contains-separator path ;
+ERROR: vocab-name-contains-dot path ;
+ERROR: no-vocab vocab ;
+
+<PRIVATE
+: root? ( string -- ? )
+    vocab-roots get member?  ;
+
+: check-vocab-name ( string -- string )
+    dup dup [ CHAR: . = ] trim [ length ] bi@ =
+    [ vocab-name-contains-dot ] unless
+    ".." over subseq? [ vocab-name-contains-dot ] when
+    dup [ path-separator? ] contains?
+    [ vocab-name-contains-separator ] when ;
+
+: check-root ( string -- string )
+    check-vocab-name
+    dup "resource:" head? [ "resource:" prepend ] unless
+    dup root? [ not-a-vocab-root ] unless ;
+
+: directory-exists ( path -- )
+    "Not creating a directory, it already exists: " write print ;
+
+: scaffold-directory ( path -- )
+    dup exists? [ directory-exists ] [ make-directories ] if ;
+
+: not-scaffolding ( path -- )
+    "Not creating scaffolding for " write <pathname> . ;
+
+: scaffolding ( path -- )
+    "Creating scaffolding for " write <pathname> . ;
+
+: scaffold-path ( path string -- path ? )
+    dupd [ file-name ] dip append append-path
+    dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
+
+: scaffold-copyright ( -- )
+    "! Copyright (C) " write now year>> number>string write
+    developer-name get [ "Your name" ] unless* bl write "." print
+    "! See http://factorcode.org/license.txt for BSD license." print ;
+
+: main-file-string ( vocab -- string )
+    [
+        scaffold-copyright
+        "USING: ;" print
+        "IN: " write print
+    ] with-string-writer ;
+
+: set-scaffold-main-file ( path vocab -- )
+    main-file-string swap utf8 set-file-contents ;
+
+: scaffold-main ( path vocab -- )
+    [ ".factor" scaffold-path ] dip
+    swap [ set-scaffold-main-file ] [ 2drop ] if ;
+
+: tests-file-string ( vocab -- string )
+    [
+        scaffold-copyright
+        "USING: tools.test " write dup write " ;" print
+        "IN: " write write ".tests" print
+    ] with-string-writer ;
+
+: set-scaffold-tests-file ( path vocab -- )
+    tests-file-string swap utf8 set-file-contents ;
+
+: scaffold-tests ( path vocab -- )
+    [ "-tests.factor" scaffold-path ] dip
+    swap [ set-scaffold-tests-file ] [ 2drop ] if ;
+
+: scaffold-authors ( path -- )
+    "authors.txt" append-path dup exists? [
+        not-scaffolding
+    ] [
+        dup scaffolding
+        developer-name get swap utf8 set-file-contents
+    ] if ;
+
+: lookup-type ( string -- object/string ? )
+    H{
+        { "object" object } { "obj" object }
+        { "obj1" object } { "obj2" object }
+        { "obj3" object } { "obj4" object }
+        { "quot" quotation } { "quot1" quotation }
+        { "quot2" quotation } { "quot3" quotation }
+        { "string" string } { "string1" string }
+        { "string2" string } { "string3" string }
+        { "str" string }
+        { "str1" string } { "str2" string } { "str3" string }
+        { "hash" hashtable }
+        { "hashtable" hashtable }
+        { "?" "a boolean" }
+        { "ch" "a character" }
+        { "word" word }
+        { "array" array }
+        { "path" "a pathname string" }
+        { "vocab" "a vocabulary specifier" }
+        { "vocab-root" "a vocabulary root string" }
+    } at* ;
+
+: add-using ( object -- )
+    vocabulary>> using get [ conjoin ] [ drop ] if* ;
+
+: ($values.) ( array -- )
+    [
+        " { " write
+        dup array? [ first ] when
+        dup lookup-type [
+            [ unparse write bl ]
+            [ [ pprint ] [ dup string? [ drop ] [ add-using ] if ] bi ] bi*
+        ] [
+            drop unparse write bl null pprint
+            null add-using
+        ] if
+        " }" write
+    ] each ;
+
+: $values. ( word -- )
+    "declared-effect" word-prop [
+        [ in>> ] [ out>> ] bi
+        2dup [ empty? ] bi@ and [
+            2drop
+        ] [
+            "{ $values" print
+            [ "    " write ($values.) ]
+            [ [ nl "    " write ($values.) ] unless-empty ] bi*
+            " }" write nl
+        ] if
+    ] when* ;
+
+: $description. ( word -- )
+    drop
+    "{ $description } ;" print ;
+
+: help-header. ( word -- )
+    "HELP: " write name>> print ;
+
+: (help.) ( word -- )
+    [ help-header. ] [ $values. ] [ $description. ] tri ;
+
+: help-file-string ( str1 -- str2 )
+    [
+        [ "IN: " write print nl ]
+        [ words natural-sort [ (help.) nl ] each ]
+        [ "ARTICLE: " write unparse dup write bl print ";" print nl ]
+        [ "ABOUT: " write unparse print ] quad
+    ] with-string-writer ;
+
+: write-using ( -- )
+    "USING:" write
+    using get keys
+    { "help.markup" "help.syntax" } cord-append natural-sort 
+    [ bl write ] each
+    " ;" print ;
+
+: set-scaffold-help-file ( path vocab -- )
+    swap utf8 <file-writer> [
+        scaffold-copyright help-file-string write-using write
+    ] with-output-stream ;
+
+: check-scaffold ( vocab-root string -- vocab-root string )
+    [ check-root ] [ check-vocab-name ] bi* ;
+
+: vocab>scaffold-path ( vocab-root string -- path )
+    path-separator first CHAR: . associate substitute
+    append-path ;
+
+: prepare-scaffold ( vocab-root string -- string path )
+    check-scaffold [ vocab>scaffold-path ] keep ;
+
+: with-scaffold ( quot -- )
+    [ H{ } clone using ] dip with-variable ; inline
+
+: check-vocab ( vocab -- vocab )
+    dup find-vocab-root [ no-vocab ] unless ;
+PRIVATE>
+
+: link-vocab ( vocab -- )
+    check-vocab
+    "Edit documentation: " write
+    [ find-vocab-root ] keep
+    [ append-path ] keep "-docs.factor" append append-path
+    <pathname> . ;
+
+: help. ( word -- )
+    [ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
+
+: scaffold-help ( vocab-root string -- )
+    [
+        check-vocab
+        prepare-scaffold
+        [ "-docs.factor" scaffold-path ] dip
+        swap [ set-scaffold-help-file ] [ 2drop ] if
+    ] with-scaffold ;
+
+: scaffold-undocumented ( string -- )
+    dup words
+    [ [ "help" word-prop ] [ predicate? ] bi or not ] filter
+    natural-sort [ (help.) nl ] each
+    link-vocab ;
+
+: scaffold-vocab ( vocab-root string -- )
+    prepare-scaffold
+    {
+        [ drop scaffold-directory ]
+        [ scaffold-main ]
+        [ scaffold-tests ]
+        [ drop scaffold-authors ]
+        [ nip require ]
+    } 2cleave ;

basis/tools/vocabs/vocabs.factor

@@ -190,7 +190,7 @@ M: vocab-link summary vocab-summary ;
     vocab-dir "tags.txt" append-path ;
 
 : vocab-tags ( vocab -- tags )
-    dup vocab-tags-path vocab-file-contents ;
+    dup vocab-tags-path vocab-file-contents harvest ;
 
 : set-vocab-tags ( tags vocab -- )
     dup vocab-tags-path set-vocab-file-contents ;
@@ -202,7 +202,7 @@ M: vocab-link summary vocab-summary ;
     vocab-dir "authors.txt" append-path ;
 
 : vocab-authors ( vocab -- authors )
-    dup vocab-authors-path vocab-file-contents ;
+    dup vocab-authors-path vocab-file-contents harvest ;
 
 : set-vocab-authors ( authors vocab -- )
     dup vocab-authors-path set-vocab-file-contents ;

core/classes/mixin/mixin.factor

@@ -62,10 +62,13 @@ TUPLE: check-mixin-class mixin ;
     ] if-mixin-member? ;
 
 : remove-mixin-instance ( class mixin -- )
+    #! The order of the three clauses is important here. The last
+    #! one must come after the other two so that the entries it
+    #! adds to changed-generics are not overwritten.
     [
-        [ class-usages update-methods ]
         [ [ swap remove ] change-mixin-class ]
         [ nip update-classes ]
+        [ class-usages update-methods ]
         2tri
     ] [ 2drop ] if-mixin-member? ;
 

core/compiler/units/units.factor

@@ -110,8 +110,7 @@ SYMBOL: update-tuples-hook
 : (compiled-generic-usages) ( generic class -- assoc )
     dup class? [
         [ compiled-generic-usage ] dip
-        [ [ classes-intersect? ] [ null class<= ] bi or nip ]
-        curry assoc-filter
+        [ classes-intersect? nip ] curry assoc-filter
     ] [ 2drop f ] if ;
 
 : compiled-generic-usages ( assoc -- assocs )

core/generic/generic-tests.factor

@@ -2,7 +2,7 @@ USING: accessors alien arrays definitions generic generic.standard
 generic.math assocs hashtables io kernel math namespaces parser
 prettyprint sequences strings tools.test vectors words
 quotations classes classes.algebra classes.tuple continuations
-layouts classes.union sorting compiler.units eval ;
+layouts classes.union sorting compiler.units eval multiline ;
 IN: generic.tests
 
 GENERIC: foobar ( x -- y )
@@ -135,7 +135,7 @@ M: f tag-and-f 4 ;
 [ 3.4 3 ] [ 3.4 tag-and-f ] unit-test
 
 ! Issues with forget
-GENERIC: generic-forget-test-1
+GENERIC: generic-forget-test-1 ( a b -- c )
 
 M: integer generic-forget-test-1 / ;
 
@@ -187,7 +187,7 @@ M: f generic-forget-test-3 ;
 
 : a-word ;
 
-GENERIC: a-generic
+GENERIC: a-generic ( a -- b )
 
 M: integer a-generic a-word ;
 
@@ -198,3 +198,27 @@ M: integer a-generic a-word ;
 [ ] [ "IN: generic.tests : a-generic ;" eval ] unit-test
 
 [ f ] [ "m" get \ a-word usage memq? ] unit-test
+
+! erg's regression
+[ ] [
+    <"
+    IN: compiler.tests
+
+    GENERIC: jeah ( a -- b )
+    TUPLE: boii ;
+    M: boii jeah ;
+    GENERIC: jeah* ( a -- b )
+    M: boii jeah* jeah ;
+    "> eval
+
+    <"
+    IN: compiler.tests
+    FORGET: boii
+    "> eval
+    
+    <"
+    IN: compiler.tests
+    TUPLE: boii ;
+    M: boii jeah ;
+    "> eval
+] unit-test

core/generic/generic.factor

@@ -130,7 +130,7 @@ M: method-spec definition
     first2 method definition ;
 
 M: method-spec forget*
-    first2 method forget* ;
+    first2 method [ forgotten-definition ] [ forget* ] bi ;
 
 M: method-spec smart-usage
     second smart-usage ;

core/slots/deprecated/deprecated.factor

@@ -1,81 +0,0 @@
-! Copyright (C) 2005, 2008 Slava Pestov.
-! See http://factorcode.org/license.txt for BSD license.
-USING: accessors arrays kernel kernel.private math namespaces
-sequences strings words effects generic generic.standard
-classes slots.private combinators slots ;
-IN: slots.deprecated
-
-: reader-effect ( class spec -- effect )
-    >r ?word-name 1array r> name>> 1array <effect> ;
-
-PREDICATE: slot-reader < word "reading" word-prop >boolean ;
-
-: set-reader-props ( class spec -- )
-    2dup reader-effect
-    over reader>>
-    swap "declared-effect" set-word-prop
-    reader>> swap "reading" set-word-prop ;
-
-: define-slot-word ( class word quot -- )
-    [
-        dup define-simple-generic
-        create-method
-    ] dip define ;
-
-: define-reader ( class spec -- )
-    dup reader>> [
-        [ set-reader-props ] 2keep
-        dup reader>>
-        swap reader-quot
-        define-slot-word
-    ] [
-        2drop
-    ] if ;
-
-: writer-effect ( class spec -- effect )
-    name>> swap ?word-name 2array 0 <effect> ;
-
-PREDICATE: slot-writer < word "writing" word-prop >boolean ;
-
-: set-writer-props ( class spec -- )
-    2dup writer-effect
-    over writer>>
-    swap "declared-effect" set-word-prop
-    writer>> swap "writing" set-word-prop ;
-
-: define-writer ( class spec -- )
-    dup writer>> [
-        [ set-writer-props ] 2keep
-        dup writer>>
-        swap writer-quot
-        define-slot-word
-    ] [
-        2drop
-    ] if ;
-
-: define-slot ( class spec -- )
-    2dup define-reader define-writer ;
-
-: define-slots ( class specs -- )
-    [ define-slot ] with each ;
-
-: reader-word ( class name vocab -- word )
-    >r >r "-" r> 3append r> create ;
-
-: writer-word ( class name vocab -- word )
-    >r [ swap "set-" % % "-" % % ] "" make r> create ;
-
-: (simple-slot-word) ( class name -- class name vocab )
-    over vocabulary>> >r >r name>> r> r> ;
-
-: simple-reader-word ( class name -- word )
-    (simple-slot-word) reader-word ;
-
-: simple-writer-word ( class name -- word )
-    (simple-slot-word) writer-word ;
-
-: deprecated-slots ( class slot-specs -- slot-specs' )
-    [
-        2dup name>> simple-reader-word >>reader
-        2dup name>> simple-writer-word >>writer
-    ] map nip ;

core/slots/slots.factor

@@ -6,7 +6,7 @@ classes.algebra slots.private combinators accessors words
 sequences.private assocs alien ;
 IN: slots
 
-TUPLE: slot-spec name offset class initial read-only reader writer ;
+TUPLE: slot-spec name offset class initial read-only ;
 
 PREDICATE: reader < word "reader" word-prop ;
 

extra/benchmark/dawes/dawes.factor

@@ -0,0 +1,21 @@
+USING: sequences alien.c-types math hints kernel byte-arrays ;
+IN: benchmark.dawes
+
+! Phil Dawes's performance problem
+
+: int-length ( byte-array -- n ) length "int" heap-size /i ; inline
+
+: count-ones ( byte-array -- n )
+    0 swap [ int-length ] keep [
+        int-nth 1 = [ 1 + ] when
+    ] curry each-integer ;
+
+HINTS: count-ones byte-array ;
+
+: make-byte-array ( -- byte-array )
+    120000 [ 255 bitand ] map >c-int-array ;
+
+: dawes-benchmark ( -- )
+    make-byte-array 200 swap [ count-ones ] curry replicate drop ;
+
+MAIN: dawes-benchmark

extra/benchmark/euler150/euler150.factor

@@ -0,0 +1,7 @@
+IN: benchmark.euler150
+USING: kernel project-euler.150 ;
+
+: euler150-benchmark ( -- )
+    euler150 -271248680 assert= ;
+
+MAIN: euler150-benchmark

extra/benchmark/euler186/euler186.factor

@@ -0,0 +1,7 @@
+IN: benchmark.euler186
+USING: kernel project-euler.186 ;
+
+: euler186-benchmark ( -- )
+    euler186 2325629 assert= ;
+
+MAIN: euler186-benchmark

extra/benchmark/typecheck2/typecheck2.factor

@@ -3,7 +3,7 @@ IN: benchmark.typecheck2
 
 TUPLE: hello n ;
 
-: hello-n* ( obj -- value ) dup tuple? [ 3 slot ] [ 3 throw ] if ;
+: hello-n* ( obj -- value ) dup tuple? [ 2 slot ] [ 3 throw ] if ;
 
 : foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
 

extra/benchmark/typecheck3/typecheck3.factor

@@ -3,7 +3,7 @@ IN: benchmark.typecheck3
 
 TUPLE: hello n ;
 
-: hello-n* ( obj -- val ) dup tag 2 eq? [ 3 slot ] [ 3 throw ] if ;
+: hello-n* ( obj -- val ) dup tag 2 eq? [ 2 slot ] [ 3 throw ] if ;
 
 : foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
 

extra/benchmark/typecheck4/typecheck4.factor

@@ -3,7 +3,7 @@ IN: benchmark.typecheck4
 
 TUPLE: hello n ;
 
-: hello-n* ( obj -- val ) 3 slot ;
+: hello-n* ( obj -- val ) 2 slot ;
 
 : foo ( obj -- obj n ) 0 100000000 [ over hello-n* + ] times ;
 

extra/inverse/inverse.factor

@@ -207,7 +207,7 @@ DEFER: _
     "predicate" word-prop [ dupd call assure ] curry ;
 
 : slot-readers ( class -- quot )
-    all-slots rest ! tail gets rid of delegate
+    all-slots
     [ name>> reader-word 1quotation [ keep ] curry ] map concat
     [ ] like [ drop ] compose ;
 

extra/irc/messages/messages.factor

@@ -127,4 +127,4 @@ M: sender-in-prefix irc-message-sender ( sender-in-prefix -- sender )
     } case
     [ [ tuple-slots ] [ parameters>> ] bi append ] dip
     [ all-slots over [ length ] bi@ min head >quotation ] keep
-    '[ @ , boa nip ] call ;
+    '[ @ , boa ] call ;

extra/math/blas/cblas/tags.txt

@@ -1,2 +1,3 @@
 math
 bindings
+unportable

extra/math/blas/matrices/tags.txt

@@ -1,2 +1,3 @@
 math
 bindings
+unportable

extra/math/blas/syntax/tags.txt

@@ -1 +1,2 @@
 math
+unportable

extra/math/blas/vectors/tags.txt

@@ -1 +1,2 @@
 math
+unportable