diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 7d4db3c473..035d95d3ab 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -16,12 +16,6 @@ IN: bootstrap.compiler "cpu." cpu append require -: enable-compiler ( -- ) - [ optimized-recompile-hook ] recompile-hook set-global ; - -: disable-compiler ( -- ) - [ default-recompile-hook ] recompile-hook set-global ; - enable-compiler nl diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index f0d9b77981..fc963683b6 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -444,7 +444,6 @@ PRIVATE> "resource:/core/bootstrap/stage1.factor" run-file build-image write-image - \ word-props target-word ] with-scope ; : make-images ( -- ) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 6c4462ed98..f3846de5b1 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -159,17 +159,24 @@ num-types get f builtins set "tuple-layout" "classes.tuple.private" create register-builtin ! Catch-all class for providing a default method. -"object" "kernel" create [ drop t ] "predicate" set-word-prop "object" "kernel" create -f builtins get [ ] subset union-class define-class +[ f builtins get [ ] subset union-class define-class ] +[ [ drop t ] "predicate" set-word-prop ] +bi + +"object?" "kernel" vocab-words delete-at ! Class of objects with object tag "hi-tag" "kernel.private" create -f builtins get num-tags get tail union-class define-class +builtins get num-tags get tail define-union-class ! Empty class with no instances -"null" "kernel" create [ drop f ] "predicate" set-word-prop -"null" "kernel" create f { } union-class define-class +"null" "kernel" create +[ f { } union-class define-class ] +[ [ drop f ] "predicate" set-word-prop ] +bi + +"null?" "kernel" vocab-words delete-at "fixnum" "math" create { } define-builtin "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop @@ -378,17 +385,9 @@ define-builtin ] } cleave -! Define general-t type, which is any object that is not f. -"general-t" "kernel" create -f "f" "syntax" lookup builtins get remove [ ] subset union-class -define-class - "f" "syntax" create [ not ] "predicate" set-word-prop "f?" "syntax" vocab-words delete-at -"general-t" "kernel" create [ ] "predicate" set-word-prop -"general-t?" "kernel" vocab-words delete-at - ! Create special tombstone values "tombstone" "hashtables.private" create "tuple" "kernel" lookup diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index e7e90d8dd0..b3e5cb0120 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -66,6 +66,7 @@ IN: bootstrap.syntax "CS{" "<<" ">>" + "call-next-method" } [ "syntax" create drop ] each "t" "syntax" lookup define-symbol diff --git a/core/classes/algebra/algebra-tests.factor b/core/classes/algebra/algebra-tests.factor index 32664dc823..0f468908a9 100755 --- a/core/classes/algebra/algebra-tests.factor +++ b/core/classes/algebra/algebra-tests.factor @@ -23,8 +23,8 @@ random inference effects kernel.private ; [ t ] [ number object number class-and* ] unit-test [ t ] [ object number number class-and* ] unit-test [ t ] [ slice reversed null class-and* ] unit-test -[ t ] [ general-t \ f null class-and* ] unit-test -[ t ] [ general-t \ f object class-or* ] unit-test +[ t ] [ \ f class-not \ f null class-and* ] unit-test +[ t ] [ \ f class-not \ f object class-or* ] unit-test TUPLE: first-one ; TUPLE: second-one ; diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 9573de8949..0560a0e755 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -21,7 +21,6 @@ $nl { { $link f } { $snippet "[ not ]" } { "The conventional name for a word which outputs true when given false is " { $link not } "; " { $snippet "f?" } " would be confusing." } } { { $link object } { $snippet "[ drop t ]" } { "All objects are instances of " { $link object } } } { { $link null } { $snippet "[ drop f ]" } { "No object is an instance of " { $link null } } } - { { $link general-t } { $snippet "[ ]" } { "All objects with a true value are instances of " { $link general-t } } } } "The set of class predicate words is a class:" { $subsection predicate } diff --git a/core/classes/classes-tests.factor b/core/classes/classes-tests.factor index ae9e6ec154..ae19f38d14 100755 --- a/core/classes/classes-tests.factor +++ b/core/classes/classes-tests.factor @@ -3,7 +3,7 @@ kernel math namespaces parser prettyprint sequences strings tools.test vectors words quotations classes classes.private classes.union classes.mixin classes.predicate classes.algebra vectors definitions source-files -compiler.units ; +compiler.units kernel.private ; IN: classes.tests ! DEFER: bah @@ -153,3 +153,10 @@ TUPLE: flat-mx-2-1 ; INSTANCE: flat-mx-2-1 flat-mx-2 ! Test generic see and parsing [ "USING: alien math ;\nIN: classes.tests\nUNION: bah fixnum alien ;\n" ] [ [ \ bah see ] with-string-writer ] unit-test + +[ t ] [ 3 object instance? ] unit-test +[ t ] [ 3 fixnum instance? ] unit-test +[ f ] [ 3 float instance? ] unit-test +[ t ] [ 3 number instance? ] unit-test +[ f ] [ 3 null instance? ] unit-test +[ t ] [ "hi" \ hi-tag instance? ] unit-test diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 0baf235edb..c45fd7360b 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -60,7 +60,7 @@ PREDICATE: predicate < word "predicating" word-prop >boolean ; dup class? [ "superclass" word-prop ] [ drop f ] if ; : superclasses ( class -- supers ) - [ dup ] [ [ superclass ] keep ] [ ] unfold nip reverse ; + [ superclass ] follow reverse ; : members ( class -- seq ) #! Output f for non-classes to work with algebra code @@ -133,3 +133,6 @@ GENERIC: class ( object -- class ) M: hi-tag class hi-tag type>class ; M: object class tag type>class ; + +: instance? ( obj class -- ? ) + "predicate" word-prop call ; diff --git a/core/classes/tuple/tuple-docs.factor b/core/classes/tuple/tuple-docs.factor index 18c8143654..664f0545fa 100755 --- a/core/classes/tuple/tuple-docs.factor +++ b/core/classes/tuple/tuple-docs.factor @@ -153,14 +153,6 @@ HELP: tuple= { $description "Low-level tuple equality test. User code should use " { $link = } " instead." } { $warning "This word is in the " { $vocab-link "classes.tuple.private" } " vocabulary because it does not do any type checking. Passing values which are not tuples can result in memory corruption." } ; -HELP: removed-slots -{ $values { "class" tuple-class } { "newslots" "a sequence of strings" } { "seq" "a sequence of strings" } } -{ $description "Outputs the sequence of existing tuple slot names not in " { $snippet "newslots" } "." } ; - -HELP: forget-removed-slots -{ $values { "class" tuple-class } { "slots" "a sequence of strings" } } -{ $description "Forgets accessor words for existing tuple slots which are not in " { $snippet "newslots" } "." } ; - HELP: tuple { $class-description "The class of tuples. This class is further partitioned into disjoint subclasses; each tuple shape defined by " { $link POSTPONE: TUPLE: } " is a new class." $nl diff --git a/core/classes/tuple/tuple-tests.factor b/core/classes/tuple/tuple-tests.factor index ff34c25416..735f328a67 100755 --- a/core/classes/tuple/tuple-tests.factor +++ b/core/classes/tuple/tuple-tests.factor @@ -511,3 +511,34 @@ USE: vocabs define-tuple-class ] with-compilation-unit ] unit-test + +[ "USE: words T{ word }" eval ] [ [ no-method? ] is? ] must-fail-with + +! Accessors not being forgotten... +[ [ ] ] [ + "IN: classes.tuple.tests TUPLE: forget-accessors-test x y z ;" + + "forget-accessors-test" parse-stream +] unit-test + +[ t ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test + +: accessor-exists? ( class name -- ? ) + >r "forget-accessors-test" "classes.tuple.tests" lookup r> + ">>" append "accessors" lookup method >boolean ; + +[ t ] [ "x" accessor-exists? ] unit-test +[ t ] [ "y" accessor-exists? ] unit-test +[ t ] [ "z" accessor-exists? ] unit-test + +[ [ ] ] [ + "IN: classes.tuple.tests GENERIC: forget-accessors-test" + + "forget-accessors-test" parse-stream +] unit-test + +[ f ] [ "forget-accessors-test" "classes.tuple.tests" lookup class? ] unit-test + +[ f ] [ "x" accessor-exists? ] unit-test +[ f ] [ "y" accessor-exists? ] unit-test +[ f ] [ "z" accessor-exists? ] unit-test diff --git a/core/classes/tuple/tuple.factor b/core/classes/tuple/tuple.factor index bbc221b85d..ac1a7b8849 100755 --- a/core/classes/tuple/tuple.factor +++ b/core/classes/tuple/tuple.factor @@ -19,7 +19,7 @@ ERROR: no-tuple-class class ; GENERIC: tuple-layout ( object -- layout ) -M: class tuple-layout "layout" word-prop ; +M: tuple-class tuple-layout "layout" word-prop ; M: tuple tuple-layout 1 slot ; @@ -40,7 +40,9 @@ PRIVATE> [ drop ] [ no-tuple-class ] if ; : tuple>array ( tuple -- array ) - prepare-tuple>array >r copy-tuple-slots r> layout-class prefix ; + prepare-tuple>array + >r copy-tuple-slots r> + layout-class prefix ; : tuple-slots ( tuple -- array ) prepare-tuple>array drop copy-tuple-slots ; @@ -120,15 +122,6 @@ PRIVATE> : define-tuple-layout ( class -- ) dup make-tuple-layout "layout" set-word-prop ; -: removed-slots ( class newslots -- seq ) - swap slot-names seq-diff ; - -: forget-removed-slots ( class slots -- ) - dupd removed-slots [ - [ reader-word forget-method ] - [ writer-word forget-method ] 2bi - ] with each ; - : all-slot-names ( class -- slots ) superclasses [ slot-names ] map concat \ class prefix ; @@ -189,9 +182,8 @@ M: tuple-class update-class tri ] each-subclass ] - [ nip forget-removed-slots ] [ define-new-tuple-class ] - 3tri ; + 3bi ; : tuple-class-unchanged? ( class superclass slots -- ? ) rot tuck [ superclass = ] [ slot-names = ] 2bi* and ; @@ -213,7 +205,19 @@ M: tuple-class define-tuple-class dup [ construct-boa throw ] curry define ; M: tuple-class reset-class - { "metaclass" "superclass" "slots" "layout" } reset-props ; + [ + dup "slot-names" word-prop [ + [ reader-word forget-method ] + [ writer-word forget-method ] 2bi + ] with each + ] [ + { + "metaclass" + "superclass" + "layout" + "slots" + } reset-props + ] bi ; M: tuple clone (clone) dup delegate clone over set-delegate ; @@ -228,12 +232,6 @@ M: tuple hashcode* ] 2curry reduce ] recursive-hashcode ; -M: object construct-empty ( class -- tuple ) - tuple-layout ; - -M: object construct-boa ( ... class -- tuple ) - tuple-layout ; - ! Deprecated M: object get-slots ( obj slots -- ... ) [ execute ] with each ; @@ -241,10 +239,6 @@ M: object get-slots ( obj slots -- ... ) M: object set-slots ( ... obj slots -- ) get-slots ; -M: object construct ( ... slots class -- tuple ) - construct-empty [ swap set-slots ] keep ; - -: delegates ( obj -- seq ) - [ dup ] [ [ delegate ] keep ] [ ] unfold nip ; +: delegates ( obj -- seq ) [ delegate ] follow ; : is? ( obj quot -- ? ) >r delegates r> contains? ; inline diff --git a/core/compiler/compiler-docs.factor b/core/compiler/compiler-docs.factor index 3520104e1f..341d56f1d5 100755 --- a/core/compiler/compiler-docs.factor +++ b/core/compiler/compiler-docs.factor @@ -2,14 +2,21 @@ USING: generator help.markup help.syntax words io parser assocs words.private sequences compiler.units ; IN: compiler +HELP: enable-compiler +{ $description "Enables the optimizing compiler." } ; + +HELP: disable-compiler +{ $description "Enables the optimizing compiler." } ; + ARTICLE: "compiler-usage" "Calling the optimizing compiler" -"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly." -$nl -"The main entry point to the optimizing compiler:" +"Normally, new word definitions are recompiled automatically. This can be changed:" +{ $subsection disable-compiler } +{ $subsection enable-compiler } +"The optimizing compiler can be called directly, although this should not be necessary under normal circumstances:" { $subsection optimized-recompile-hook } "Removing a word's optimized definition:" { $subsection decompile } -"These words are not usually used directly. Instead, use " { $link "compilation-units" } "." ; +"Higher-level words can be found in " { $link "compilation-units" } "." ; ARTICLE: "compiler" "Optimizing compiler" "Factor is a fully compiled language implementation with two distinct compilers:" diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 111d84cde0..a0599f79a1 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -56,5 +56,11 @@ IN: compiler compiled get >alist ] with-scope ; +: enable-compiler ( -- ) + [ optimized-recompile-hook ] recompile-hook set-global ; + +: disable-compiler ( -- ) + [ default-recompile-hook ] recompile-hook set-global ; + : recompile-all ( -- ) forget-errors all-words compile ; diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index ebbce4d7e2..3dc28139ea 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -4,7 +4,7 @@ compiler.units words ; TUPLE: combination-1 ; -M: combination-1 perform-combination 2drop [ ] ; +M: combination-1 perform-combination drop [ ] define ; M: combination-1 make-default-method 2drop [ "No method" throw ] ; diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index fd313d8165..524835f461 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -21,19 +21,6 @@ M: word class-of drop "word" ; [ "Hello world" ] [ 4 foobar foobar ] unit-test [ "Goodbye cruel world" ] [ 4 foobar ] unit-test -GENERIC: bool>str ( x -- y ) -M: general-t bool>str drop "true" ; -M: f bool>str drop "false" ; - -: str>bool - H{ - { "true" t } - { "false" f } - } at ; - -[ t ] [ t bool>str str>bool ] unit-test -[ f ] [ f bool>str str>bool ] unit-test - ! Testing unions UNION: funnies quotation float complex ; @@ -51,16 +38,6 @@ M: very-funny gooey sq ; [ 0.25 ] [ 0.5 gooey ] unit-test -DEFER: complement-test -FORGET: complement-test -GENERIC: complement-test ( x -- y ) - -M: f complement-test drop "f" ; -M: general-t complement-test drop "general-t" ; - -[ "general-t" ] [ 5 complement-test ] unit-test -[ "f" ] [ f complement-test ] unit-test - GENERIC: empty-method-test ( x -- y ) M: object empty-method-test ; TUPLE: for-arguments-sake ; diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 2ec285146e..b0099f770c 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -6,16 +6,7 @@ classes.algebra quotations arrays vocabs effects ; IN: generic ! Method combination protocol -GENERIC: perform-combination ( word combination -- quot ) - -M: object perform-combination - #! We delay the invalid method combination error for a - #! reason. If we call forget-vocab on a vocabulary which - #! defines a method combination, a generic using this - #! method combination, and a method on the generic, and the - #! method combination is forgotten first, then forgetting - #! the method will throw an error. We don't want that. - nip [ "Invalid method combination" throw ] curry [ ] like ; +GENERIC: perform-combination ( word combination -- ) GENERIC: make-default-method ( generic combination -- method ) @@ -38,6 +29,18 @@ PREDICATE: method-spec < pair : order ( generic -- seq ) "methods" word-prop keys sort-classes ; +: next-method-class ( class generic -- class/f ) + order [ class< ] with subset reverse dup length 1 = + [ drop f ] [ second ] if ; + +: next-method ( class generic -- class/f ) + [ next-method-class ] keep method ; + +GENERIC: next-method-quot ( class generic -- quot ) + +: (call-next-method) ( class generic -- ) + next-method-quot call ; + TUPLE: check-method class generic ; : check-method ( class generic -- class generic ) diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 2fda2c9621..46208744f0 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -12,9 +12,9 @@ PREDICATE: math-class < class number bootstrap-word class< ] if ; -: last/first ( seq -- pair ) dup peek swap first 2array ; +: last/first ( seq -- pair ) [ peek ] [ first ] bi 2array ; -: math-precedence ( class -- n ) +: math-precedence ( class -- pair ) { { [ dup null class< ] [ drop { -1 -1 } ] } { [ dup math-class? ] [ class-types last/first ] } diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor index 510d5ef732..40e749f473 100644 --- a/core/generic/standard/engines/tuple/tuple.factor +++ b/core/generic/standard/engines/tuple/tuple.factor @@ -15,7 +15,7 @@ C: trivial-tuple-dispatch-engine TUPLE: tuple-dispatch-engine echelons ; : push-echelon ( class method assoc -- ) - >r swap dup tuple-layout layout-echelon r> + >r swap dup "layout" word-prop layout-echelon r> [ ?set-at ] change-at ; : echelon-sort ( assoc -- assoc' ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 0d29bdecd5..2b2dbd2b2d 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,6 +8,10 @@ generic.standard.engines.tag generic.standard.engines.predicate generic.standard.engines.tuple accessors ; IN: generic.standard +GENERIC: dispatch# ( word -- n ) + +M: word dispatch# "combination" word-prop dispatch# ; + : unpickers { [ nip ] @@ -101,7 +105,7 @@ PREDICATE: simple-generic < standard-generic T{ standard-combination f 0 } define-generic ; : with-standard ( combination quot -- quot' ) - >r #>> (dispatch#) r> with-variable ; + >r #>> (dispatch#) r> with-variable ; inline M: standard-generic mangle-method drop 1quotation ; @@ -112,6 +116,27 @@ M: standard-combination make-default-method M: standard-combination perform-combination [ drop ] [ [ single-combination ] with-standard ] 2bi define ; +M: standard-combination dispatch# #>> ; + +ERROR: inconsistent-next-method object class generic ; + +ERROR: no-next-method class generic ; + +M: standard-generic next-method-quot + [ + [ + [ [ instance? ] curry ] + [ dispatch# (picker) ] bi* prepend % + ] + [ + 2dup next-method + [ 2nip 1quotation ] + [ [ no-next-method ] 2curry ] if* , + ] + [ [ inconsistent-next-method ] 2curry , ] + 2tri + ] [ ] make ; + TUPLE: hook-combination var ; C: hook-combination @@ -124,6 +149,8 @@ PREDICATE: hook-generic < generic dip var>> [ get ] curry prepend ] with-variable ; inline +M: hook-combination dispatch# drop 0 ; + M: hook-generic mangle-method drop 1quotation [ drop ] prepend ; @@ -133,14 +160,6 @@ M: hook-combination make-default-method M: hook-combination perform-combination [ drop ] [ [ single-combination ] with-hook ] 2bi define ; -GENERIC: dispatch# ( word -- n ) - -M: word dispatch# "combination" word-prop dispatch# ; - -M: standard-combination dispatch# #>> ; - -M: hook-combination dispatch# drop 0 ; - M: simple-generic definer drop \ GENERIC: f ; M: standard-generic definer drop \ GENERIC# f ; diff --git a/core/inference/class/class-tests.factor b/core/inference/class/class-tests.factor index 7d18aaa489..b54dbe256a 100755 --- a/core/inference/class/class-tests.factor +++ b/core/inference/class/class-tests.factor @@ -21,7 +21,7 @@ GENERIC: mynot ( x -- y ) M: f mynot drop t ; -M: general-t mynot drop f ; +M: object mynot drop f ; GENERIC: detect-f ( x -- y ) @@ -297,3 +297,15 @@ cell-bits 32 = [ [ t ] [ [ { vector } declare nth-unsafe ] \ nth-unsafe inlined? ] unit-test + +[ t ] [ + [ + dup integer? [ + dup fixnum? [ + 1 + + ] [ + 2 + + ] if + ] when + ] \ + inlined? +] unit-test diff --git a/core/inference/class/class.factor b/core/inference/class/class.factor index 4aac98ce41..8269952409 100755 --- a/core/inference/class/class.factor +++ b/core/inference/class/class.factor @@ -176,9 +176,18 @@ M: pair constraint-satisfied? : predicate-constraints ( class #call -- ) [ - 0 `input class, - general-t 0 `output class, - ] set-constraints ; + ! If word outputs true, input is an instance of class + [ + 0 `input class, + \ f class-not 0 `output class, + ] set-constraints + ] [ + ! If word outputs false, input is not an instance of class + [ + class-not 0 `input class, + \ f 0 `output class, + ] set-constraints + ] 2bi ; : compute-constraints ( #call -- ) dup node-param "constraints" word-prop [ @@ -209,7 +218,7 @@ M: #push infer-classes-before M: #if child-constraints [ - general-t 0 `input class, + \ f class-not 0 `input class, f 0 `input literal, ] make-constraints ; diff --git a/core/inference/dataflow/dataflow.factor b/core/inference/dataflow/dataflow.factor index 7fa2fbbcd3..01c0a9c5f4 100755 --- a/core/inference/dataflow/dataflow.factor +++ b/core/inference/dataflow/dataflow.factor @@ -9,15 +9,13 @@ IN: inference.dataflow : \ counter ; ! Literal value -TUPLE: value literal uid recursion ; +TUPLE: value < identity-tuple literal uid recursion ; : ( obj -- value ) recursive-state get value construct-boa ; M: value hashcode* nip value-uid ; -M: value equal? 2drop f ; - ! Result of curry TUPLE: curried obj quot ; @@ -30,13 +28,12 @@ C: composed UNION: special curried composed ; -TUPLE: node param +TUPLE: node < identity-tuple +param in-d out-d in-r out-r classes literals intervals history successor children ; -M: node equal? 2drop f ; - M: node hashcode* drop node hashcode* ; GENERIC: flatten-curry ( value -- ) diff --git a/core/inference/transforms/transforms-tests.factor b/core/inference/transforms/transforms-tests.factor index cb8024d3c5..3fc8f37b4f 100755 --- a/core/inference/transforms/transforms-tests.factor +++ b/core/inference/transforms/transforms-tests.factor @@ -1,6 +1,7 @@ IN: inference.transforms.tests USING: sequences inference.transforms tools.test math kernel -quotations inference accessors combinators words arrays ; +quotations inference accessors combinators words arrays +classes ; : compose-n-quot >quotation ; : compose-n compose-n-quot call ; @@ -56,3 +57,5 @@ C: color [ 16 -3 1/6 ] [ 4 3 6 spread-test ] unit-test [ 16 -3 1/6 ] [ 4 3 6 \ spread-test word-def call ] unit-test + +[ fixnum instance? ] must-infer diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index 06c2a8f476..d95ff9c3bc 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -3,7 +3,7 @@ USING: arrays kernel words sequences generic math namespaces quotations assocs combinators math.bitfields inference.backend inference.dataflow inference.state classes.tuple.private effects -inspector hashtables ; +inspector hashtables classes generic ; IN: inference.transforms : pop-literals ( n -- rstate seq ) @@ -98,3 +98,11 @@ M: duplicated-slots-error summary \ construct-empty 1 1 make-call-node ] if ] "infer" set-word-prop + +\ instance? [ + [ +inlined+ depends-on ] [ "predicate" word-prop ] bi +] 1 define-transform + +\ (call-next-method) [ + [ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi +] 2 define-transform diff --git a/core/kernel/kernel-docs.factor b/core/kernel/kernel-docs.factor index 2df5e69998..53618d4628 100755 --- a/core/kernel/kernel-docs.factor +++ b/core/kernel/kernel-docs.factor @@ -250,8 +250,9 @@ $nl { $subsection eq? } "Value comparison:" { $subsection = } -"Generic words for custom value comparison methods:" +"Custom value comparison methods:" { $subsection equal? } +{ $subsection identity-tuple } "Some types of objects also have an intrinsic order allowing sorting using " { $link natural-sort } ":" { $subsection <=> } { $subsection compare } @@ -377,10 +378,13 @@ HELP: equal? } $nl "If a class defines a custom equality comparison test, it should also define a compatible method for the " { $link hashcode* } " generic word." -} +} ; + +HELP: identity-tuple +{ $class-description "A class defining an " { $link equal? } " method which always returns f." } { $examples - "To define a tuple class such that two instances are only equal if they are both the same instance, we can add a method to " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:" - { $code "TUPLE: foo ;" "M: foo equal? 2drop f ;" } + "To define a tuple class such that two instances are only equal if they are both the same instance, inherit from the " { $link identity-tuple } " class. This class defines a method on " { $link equal? } " which always returns " { $link f } ". Since " { $link = } " handles the case where the two objects are " { $link eq? } ", this method will never be called with two " { $link eq? } " objects, so such a definition is valid:" + { $code "TUPLE: foo < identity-tuple ;" } "By calling " { $link = } " on instances of " { $snippet "foo" } " we get the results we expect:" { $unchecked-example "T{ foo } dup = ." "t" } { $unchecked-example "T{ foo } dup clone = ." "f" } @@ -665,6 +669,11 @@ HELP: bi@ "[ p ] bi@" ">r p r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] bi@" + "[ p ] [ p ] bi*" + } } ; HELP: 2bi@ @@ -676,6 +685,11 @@ HELP: 2bi@ "[ p ] 2bi@" ">r >r p r> r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] 2bi@" + "[ p ] [ p ] 2bi*" + } } ; HELP: tri@ @@ -687,6 +701,11 @@ HELP: tri@ "[ p ] tri@" ">r >r p r> p r> p" } + "The following two lines are also equivalent:" + { $code + "[ p ] tri@" + "[ p ] [ p ] [ p ] tri*" + } } ; HELP: if ( cond true false -- ) @@ -785,19 +804,6 @@ HELP: null "The canonical empty class with no instances." } ; -HELP: general-t -{ $class-description - "The class of all objects not equal to " { $link f } "." -} -{ $examples - "Here is an implementation of " { $link if } " using generic words:" - { $code - "GENERIC# my-if 2 ( ? true false -- )" - "M: f my-if 2nip call ;" - "M: general-t my-if drop nip call ;" - } -} ; - HELP: most { $values { "x" object } { "y" object } { "quot" "a quotation with stack effect " { $snippet "( x y -- ? )" } } { "z" "either " { $snippet "x" } " or " { $snippet "y" } } } { $description "If the quotation yields a true value when applied to " { $snippet "x" } " and " { $snippet "y" } ", outputs " { $snippet "x" } ", otherwise outputs " { $snippet "y" } "." } ; diff --git a/core/kernel/kernel.factor b/core/kernel/kernel.factor index ae775ec116..1935c89431 100755 --- a/core/kernel/kernel.factor +++ b/core/kernel/kernel.factor @@ -1,6 +1,6 @@ ! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel.private slots.private ; +USING: kernel.private slots.private classes.tuple.private ; IN: kernel ! Stack stuff @@ -114,12 +114,6 @@ DEFER: if [ 2nip call ] if ; inline ! Object protocol -GENERIC: delegate ( obj -- delegate ) - -M: object delegate drop f ; - -GENERIC: set-delegate ( delegate tuple -- ) - GENERIC: hashcode* ( depth obj -- code ) M: object hashcode* 2drop 0 ; @@ -130,6 +124,10 @@ GENERIC: equal? ( obj1 obj2 -- ? ) M: object equal? 2drop f ; +TUPLE: identity-tuple ; + +M: identity-tuple equal? 2drop f ; + : = ( obj1 obj2 -- ? ) 2dup eq? [ 2drop t ] [ equal? ] if ; inline @@ -142,18 +140,11 @@ M: object clone ; M: callstack clone (clone) ; ! Tuple construction -GENERIC# get-slots 1 ( tuple slots -- ... ) +: construct-empty ( class -- tuple ) + tuple-layout ; -GENERIC# set-slots 1 ( ... tuple slots -- ) - -GENERIC: construct-empty ( class -- tuple ) - -GENERIC: construct ( ... slots class -- tuple ) inline - -GENERIC: construct-boa ( ... class -- tuple ) - -: construct-delegate ( delegate class -- tuple ) - >r { set-delegate } r> construct ; inline +: construct-boa ( ... class -- tuple ) + tuple-layout ; ! Quotation building : 2curry ( obj1 obj2 quot -- curry ) @@ -201,3 +192,20 @@ GENERIC: construct-boa ( ... class -- tuple ) : do-primitive ( number -- ) "Improper primitive call" throw ; PRIVATE> + +! Deprecated +GENERIC: delegate ( obj -- delegate ) + +M: object delegate drop f ; + +GENERIC: set-delegate ( delegate tuple -- ) + +GENERIC# get-slots 1 ( tuple slots -- ... ) + +GENERIC# set-slots 1 ( ... tuple slots -- ) + +: construct ( ... slots class -- tuple ) + construct-empty [ swap set-slots ] keep ; inline + +: construct-delegate ( delegate class -- tuple ) + >r { set-delegate } r> construct ; inline diff --git a/core/optimizer/control/control.factor b/core/optimizer/control/control.factor index c108e3b1a7..11228c879a 100755 --- a/core/optimizer/control/control.factor +++ b/core/optimizer/control/control.factor @@ -154,7 +154,7 @@ SYMBOL: potential-loops ] [ node-class { { [ dup null class< ] [ drop f f ] } - { [ dup general-t class< ] [ drop t t ] } + { [ dup \ f class-not class< ] [ drop t t ] } { [ dup \ f class< ] [ drop f t ] } { [ t ] [ drop f f ] } } cond diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 1f3df92421..81f53b5ace 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -70,12 +70,20 @@ DEFER: (flat-length) ] if ; ! Partial dispatch of math-generic words +: normalize-math-class ( class -- class' ) + { fixnum bignum ratio float complex } + [ class< ] with find nip object or ; + : math-both-known? ( word left right -- ? ) math-class-max swap specific-method ; : inline-math-method ( #call word -- node ) - over node-input-classes first2 3dup math-both-known? - [ math-method f splice-quot ] [ 2drop 2drop t ] if ; + over node-input-classes + [ first normalize-math-class ] + [ second normalize-math-class ] bi + 3dup math-both-known? + [ math-method f splice-quot ] + [ 2drop 2drop t ] if ; : inline-method ( #call -- node ) dup node-param { diff --git a/core/optimizer/known-words/known-words.factor b/core/optimizer/known-words/known-words.factor index a4782078ee..2bce2dc94c 100755 --- a/core/optimizer/known-words/known-words.factor +++ b/core/optimizer/known-words/known-words.factor @@ -75,7 +75,7 @@ sequences.private combinators ; dup node-in-d second dup value? [ swap [ value-literal 0 `input literal, - general-t 0 `output class, + \ f class-not 0 `output class, ] set-constraints ] [ 2drop diff --git a/core/optimizer/math/math.factor b/core/optimizer/math/math.factor index abe48ec272..4ec4bfeb36 100755 --- a/core/optimizer/math/math.factor +++ b/core/optimizer/math/math.factor @@ -269,7 +269,7 @@ generic.standard system ; : comparison-constraints ( node true false -- ) >r >r dup node set intervals dup [ 2dup - r> general-t (comparison-constraints) + r> \ f class-not (comparison-constraints) r> \ f (comparison-constraints) ] [ r> r> 2drop 2drop diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 58c68a3614..2a481d413d 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -365,7 +365,17 @@ ERROR: bad-number ; : (:) CREATE-WORD parse-definition ; -: (M:) CREATE-METHOD parse-definition ; +SYMBOL: current-class +SYMBOL: current-generic + +: (M:) + CREATE-METHOD + [ + [ "method-class" word-prop current-class set ] + [ "method-generic" word-prop current-generic set ] + [ ] tri + parse-definition + ] with-scope ; : scan-object ( -- object ) scan-word dup parsing? diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 27b63ec26f..0f384b159d 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -57,8 +57,6 @@ unit-test [ ] [ \ integer see ] unit-test -[ ] [ \ general-t see ] unit-test - [ ] [ \ generic see ] unit-test [ ] [ \ duplex-stream see ] unit-test diff --git a/core/sequences/sequences.factor b/core/sequences/sequences.factor index ca46066861..01a1cb9b6a 100755 --- a/core/sequences/sequences.factor +++ b/core/sequences/sequences.factor @@ -416,6 +416,9 @@ PRIVATE> swap >r [ push ] curry compose r> while ] keep { } like ; inline +: follow ( obj quot -- seq ) + >r [ dup ] r> [ keep ] curry [ ] unfold nip ; inline + : index ( obj seq -- n ) [ = ] with find drop ; diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index bd349953df..b242e65de5 100755 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -243,7 +243,7 @@ HELP: flushable HELP: t { $syntax "t" } { $values { "t" "the canonical truth value" } } -{ $description "The canonical instance of " { $link general-t } ". It is just a symbol." } ; +{ $class-description "The canonical truth value, which is an instance of itself." } ; HELP: f { $syntax "f" } diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 19fdf0e45f..df135d0c1c 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -185,4 +185,10 @@ IN: bootstrap.syntax [ \ >> parse-until >quotation ] with-compilation-unit call ] define-syntax + + "call-next-method" [ + current-class get literalize parsed + current-generic get literalize parsed + \ (call-next-method) parsed + ] define-syntax ] with-compilation-unit diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index a6a5a014a7..8ef5f6f508 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -6,13 +6,11 @@ IN: vocabs SYMBOL: dictionary -TUPLE: vocab +TUPLE: vocab < identity-tuple name words main help source-loaded? docs-loaded? ; -M: vocab equal? 2drop f ; - : ( name -- vocab ) H{ } clone { set-vocab-name set-vocab-words } @@ -92,10 +90,6 @@ TUPLE: vocab-link name ; : ( name -- vocab-link ) vocab-link construct-boa ; -M: vocab-link equal? - over vocab-link? - [ [ vocab-link-name ] bi@ = ] [ 2drop f ] if ; - M: vocab-link hashcode* vocab-link-name hashcode* ; diff --git a/core/words/words.factor b/core/words/words.factor index a45e1627e9..1232a97ddc 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -173,7 +173,7 @@ GENERIC: subwords ( word -- seq ) M: word subwords drop f ; : reset-generic ( word -- ) - dup subwords [ forget ] each + dup subwords forget-all dup reset-word { "methods" "combination" "default-method" } reset-props ; diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 79382091ab..20c5bb92c9 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -6,7 +6,7 @@ init threads continuations math io.encodings io.streams.duplex io.nonblocking accessors ; IN: io.launcher -TUPLE: process +TUPLE: process < identity-tuple command detached @@ -65,8 +65,6 @@ M: object register-process drop ; V{ } clone over processes get set-at register-process ; -M: process equal? 2drop f ; - M: process hashcode* process-handle hashcode* ; : pass-environment? ( process -- ? ) diff --git a/extra/io/sockets/impl/impl.factor b/extra/io/sockets/impl/impl.factor index 8480fcd856..74a84c48ff 100755 --- a/extra/io/sockets/impl/impl.factor +++ b/extra/io/sockets/impl/impl.factor @@ -96,14 +96,13 @@ M: inet6 parse-sockaddr M: f parse-sockaddr nip ; : addrinfo>addrspec ( addrinfo -- addrspec ) - dup addrinfo-addr - swap addrinfo-family addrspec-of-family + [ addrinfo-addr ] [ addrinfo-family addrspec-of-family ] bi parse-sockaddr ; : parse-addrinfo-list ( addrinfo -- seq ) - [ dup ] - [ dup addrinfo-next swap addrinfo>addrspec ] - [ ] unfold nip [ ] subset ; + [ addrinfo-next ] follow + [ addrinfo>addrspec ] map + [ ] subset ; : prepare-resolve-host ( host serv passive? -- host' serv' flags ) #! If the port is a number, we resolve for 'http' then diff --git a/extra/models/models.factor b/extra/models/models.factor index fd84dd248f..ffb9b1127a 100755 --- a/extra/models/models.factor +++ b/extra/models/models.factor @@ -4,13 +4,12 @@ USING: generic kernel math sequences arrays assocs alarms calendar ; IN: models -TUPLE: model value connections dependencies ref locked? ; +TUPLE: model < identity-tuple +value connections dependencies ref locked? ; : ( value -- model ) V{ } clone V{ } clone 0 f model construct-boa ; -M: model equal? 2drop f ; - M: model hashcode* drop model hashcode* ; : add-dependency ( dep model -- ) diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 1963f5670a..1c83bc9713 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -27,9 +27,8 @@ DEFER: freetype \ freetype get-global expired? [ init-freetype ] when \ freetype get-global ; -TUPLE: font ascent descent height handle widths ; - -M: font equal? 2drop f ; +TUPLE: font < identity-tuple +ascent descent height handle widths ; M: font hashcode* drop font hashcode* ; diff --git a/extra/ui/gadgets/gadgets.factor b/extra/ui/gadgets/gadgets.factor index ddcaa4b979..c4f11f2e87 100755 --- a/extra/ui/gadgets/gadgets.factor +++ b/extra/ui/gadgets/gadgets.factor @@ -44,14 +44,12 @@ M: array rect-dim drop { 0 0 } ; : rect-union ( rect1 rect2 -- newrect ) (rect-union) ; -TUPLE: gadget +TUPLE: gadget < identity-tuple pref-dim parent children orientation focus visible? root? clipped? layout-state graft-state graft-node interior boundary model ; -M: gadget equal? 2drop f ; - M: gadget hashcode* drop gadget hashcode* ; M: gadget model-changed 2drop ; @@ -354,7 +352,7 @@ SYMBOL: in-layout? swap [ over (add-gadget) ] each relayout ; : parents ( gadget -- seq ) - [ dup ] [ [ gadget-parent ] keep ] [ ] unfold nip ; + [ gadget-parent ] follow ; : each-parent ( gadget quot -- ? ) >r parents r> all? ; inline @@ -401,7 +399,7 @@ M: f request-focus-on 2drop ; dup focusable-child swap request-focus-on ; : focus-path ( world -- seq ) - [ dup ] [ [ gadget-focus ] keep ] [ ] unfold nip ; + [ gadget-parent ] follow ; : make-gadget ( quot gadget -- gadget ) [ \ make-gadget rot with-variable ] keep ; inline diff --git a/extra/ui/gadgets/worlds/worlds.factor b/extra/ui/gadgets/worlds/worlds.factor index a44b553858..8ee64b58be 100755 --- a/extra/ui/gadgets/worlds/worlds.factor +++ b/extra/ui/gadgets/worlds/worlds.factor @@ -5,7 +5,7 @@ namespaces opengl sequences io combinators math.vectors ui.gadgets ui.gestures ui.render ui.backend inspector ; IN: ui.gadgets.worlds -TUPLE: world +TUPLE: world < identity-tuple active? focused? glass title status @@ -46,8 +46,6 @@ M: world request-focus-on ( child gadget -- ) t over set-gadget-root? dup request-focus ; -M: world equal? 2drop f ; - M: world hashcode* drop world hashcode* ; M: world pref-dim*