diff --git a/basis/alien/structs/fields/fields.factor b/basis/alien/structs/fields/fields.factor new file mode 100644 index 0000000000..5273c2c7ba --- /dev/null +++ b/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* ; + +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 ; + +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 ; + +: ( 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 ; diff --git a/basis/alien/structs/structs-docs.factor b/basis/alien/structs/structs-docs.factor index 6f83885d9f..62b8510d17 100755 --- a/basis/alien/structs/structs-docs.factor +++ b/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." diff --git a/basis/alien/structs/structs.factor b/basis/alien/structs/structs.factor index e6a363941d..e82d663d08 100755 --- a/basis/alien/structs/structs.factor +++ b/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 ) - - 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 ] 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 ; diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index d340c21663..2dd6e440d5 100755 --- a/basis/compiler/compiler.factor +++ b/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 ; diff --git a/basis/cpu/x86/64/64.factor b/basis/cpu/x86/64/64.factor index c1697f1d98..6e864ab968 100755 --- a/basis/cpu/x86/64/64.factor +++ b/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 ) diff --git a/extra/csv/authors.txt b/basis/csv/authors.txt similarity index 100% rename from extra/csv/authors.txt rename to basis/csv/authors.txt diff --git a/extra/csv/csv-docs.factor b/basis/csv/csv-docs.factor similarity index 100% rename from extra/csv/csv-docs.factor rename to basis/csv/csv-docs.factor diff --git a/extra/csv/csv-tests.factor b/basis/csv/csv-tests.factor similarity index 100% rename from extra/csv/csv-tests.factor rename to basis/csv/csv-tests.factor diff --git a/extra/csv/csv.factor b/basis/csv/csv.factor similarity index 100% rename from extra/csv/csv.factor rename to basis/csv/csv.factor diff --git a/extra/csv/summary.txt b/basis/csv/summary.txt similarity index 100% rename from extra/csv/summary.txt rename to basis/csv/summary.txt diff --git a/basis/db/pools/pools-tests.factor b/basis/db/pools/pools-tests.factor index 34e072c3a5..f07d1e8468 100644 --- a/basis/db/pools/pools-tests.factor +++ b/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 "pool" set ] unit-test +[ ] [ "pool-test.db" temp-file sqlite-db "pool" set ] unit-test [ ] [ "pool" get expired>> t >>expired drop ] unit-test diff --git a/basis/debugger/threads/threads.factor b/basis/debugger/threads/threads.factor index 093d231d08..7bb240859e 100644 --- a/basis/debugger/threads/threads.factor +++ b/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 ; diff --git a/basis/mirrors/mirrors-docs.factor b/basis/mirrors/mirrors-docs.factor index 55896a9811..d6a8d51fbe 100755 --- a/basis/mirrors/mirrors-docs.factor +++ b/basis/mirrors/mirrors-docs.factor @@ -30,7 +30,7 @@ HELP: ( object -- mirror ) "TUPLE: circle center radius ;" "C: circle" "{ 100 50 } 15 >alist ." - "{ { \"delegate\" f } { \"center\" { 100 50 } } { \"radius\" 15 } }" + "{ { \"center\" { 100 50 } } { \"radius\" 15 } }" } } ; diff --git a/basis/stack-checker/state/state.factor b/basis/stack-checker/state/state.factor index 3d3db980e1..0d0de7f19b 100755 --- a/basis/stack-checker/state/state.factor +++ b/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 diff --git a/basis/tools/scaffold/authors.txt b/basis/tools/scaffold/authors.txt new file mode 100644 index 0000000000..b4bd0e7b35 --- /dev/null +++ b/basis/tools/scaffold/authors.txt @@ -0,0 +1 @@ +Doug Coleman \ No newline at end of file diff --git a/basis/tools/scaffold/scaffold-docs.factor b/basis/tools/scaffold/scaffold-docs.factor new file mode 100644 index 0000000000..e22e10f8c9 --- /dev/null +++ b/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" diff --git a/basis/tools/scaffold/scaffold.factor b/basis/tools/scaffold/scaffold.factor new file mode 100644 index 0000000000..84636dc106 --- /dev/null +++ b/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 ; + + . ; + +: scaffolding ( path -- ) + "Creating scaffolding for " write . ; + +: 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 [ + 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 + . ; + +: 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 ; diff --git a/basis/tools/vocabs/vocabs.factor b/basis/tools/vocabs/vocabs.factor index 08eb3d7c32..cc49d283b4 100755 --- a/basis/tools/vocabs/vocabs.factor +++ b/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 ; diff --git a/core/classes/mixin/mixin.factor b/core/classes/mixin/mixin.factor index 56e995899b..d569103d97 100755 --- a/core/classes/mixin/mixin.factor +++ b/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? ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index fa29a5a519..cb361ec9e6 100755 --- a/core/compiler/units/units.factor +++ b/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 ) diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index ab39cbcbb8..22c690ffaf 100755 --- a/core/generic/generic-tests.factor +++ b/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 diff --git a/core/generic/generic.factor b/core/generic/generic.factor index f2c154b3b2..c0a21dbaba 100755 --- a/core/generic/generic.factor +++ b/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 ; diff --git a/core/slots/deprecated/deprecated.factor b/core/slots/deprecated/deprecated.factor deleted file mode 100755 index df16f0baa8..0000000000 --- a/core/slots/deprecated/deprecated.factor +++ /dev/null @@ -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 ; - -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 ; - -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 ; diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 8754444ce0..6f831c30c5 100755 --- a/core/slots/slots.factor +++ b/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 ; diff --git a/extra/benchmark/dawes/dawes.factor b/extra/benchmark/dawes/dawes.factor new file mode 100644 index 0000000000..7cff06d1bc --- /dev/null +++ b/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 diff --git a/extra/benchmark/euler150/euler150.factor b/extra/benchmark/euler150/euler150.factor new file mode 100644 index 0000000000..448c8575f9 --- /dev/null +++ b/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 diff --git a/extra/benchmark/euler186/euler186.factor b/extra/benchmark/euler186/euler186.factor new file mode 100644 index 0000000000..681ca0e269 --- /dev/null +++ b/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 diff --git a/extra/benchmark/typecheck2/typecheck2.factor b/extra/benchmark/typecheck2/typecheck2.factor index f408389e69..2571eda412 100644 --- a/extra/benchmark/typecheck2/typecheck2.factor +++ b/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 ; diff --git a/extra/benchmark/typecheck3/typecheck3.factor b/extra/benchmark/typecheck3/typecheck3.factor index b15d81df56..c4887c03c4 100644 --- a/extra/benchmark/typecheck3/typecheck3.factor +++ b/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 ; diff --git a/extra/benchmark/typecheck4/typecheck4.factor b/extra/benchmark/typecheck4/typecheck4.factor index a2595810be..c881864304 100644 --- a/extra/benchmark/typecheck4/typecheck4.factor +++ b/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 ; diff --git a/extra/inverse/inverse.factor b/extra/inverse/inverse.factor index 1e71abf76d..c7925b94be 100755 --- a/extra/inverse/inverse.factor +++ b/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 ; diff --git a/extra/irc/messages/messages.factor b/extra/irc/messages/messages.factor index 201e8de9e7..d3eca92f15 100755 --- a/extra/irc/messages/messages.factor +++ b/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 ; diff --git a/extra/math/blas/cblas/tags.txt b/extra/math/blas/cblas/tags.txt index 241ec1ecda..5118958180 100644 --- a/extra/math/blas/cblas/tags.txt +++ b/extra/math/blas/cblas/tags.txt @@ -1,2 +1,3 @@ math bindings +unportable diff --git a/extra/math/blas/matrices/tags.txt b/extra/math/blas/matrices/tags.txt index 241ec1ecda..5118958180 100644 --- a/extra/math/blas/matrices/tags.txt +++ b/extra/math/blas/matrices/tags.txt @@ -1,2 +1,3 @@ math bindings +unportable diff --git a/extra/math/blas/syntax/tags.txt b/extra/math/blas/syntax/tags.txt index ede10ab61b..6a932d96d2 100644 --- a/extra/math/blas/syntax/tags.txt +++ b/extra/math/blas/syntax/tags.txt @@ -1 +1,2 @@ math +unportable diff --git a/extra/math/blas/vectors/tags.txt b/extra/math/blas/vectors/tags.txt index ede10ab61b..6a932d96d2 100644 --- a/extra/math/blas/vectors/tags.txt +++ b/extra/math/blas/vectors/tags.txt @@ -1 +1,2 @@ math +unportable