steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Working on call-next-method, and identity-tuple

db4
Slava Pestov 2008-04-02 21:27:49 -05:00
parent 93ebbfb7e4
commit 5346e1899f
43 changed files with 279 additions and 195 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
core/bootstrap/compiler/compiler.factor
View File

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

1
core/bootstrap/image/image.factor
View File

@ -444,7 +444,6 @@ PRIVATE>
"resource:/core/bootstrap/stage1.factor" run-file
build-image
write-image
\ word-props target-word
] with-scope ;
: make-images ( -- )

25
core/bootstrap/primitives.factor
View File

@ -159,17 +159,24 @@ num-types get f <array> 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

1
core/bootstrap/syntax.factor
View File

@ -66,6 +66,7 @@ IN: bootstrap.syntax
"CS{"
"<<"
">>"
"call-next-method"
} [ "syntax" create drop ] each
"t" "syntax" lookup define-symbol

4
core/classes/algebra/algebra-tests.factor
View File

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

1
core/classes/classes-docs.factor
View File

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

9
core/classes/classes-tests.factor
View File

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

5
core/classes/classes.factor
View File

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

8
core/classes/tuple/tuple-docs.factor
View File

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

31
core/classes/tuple/tuple-tests.factor
View File

@ -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 ;"
<string-reader>
"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"
<string-reader>
"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

44
core/classes/tuple/tuple.factor
View File

@ -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 <tuple> ;
M: object construct-boa ( ... class -- tuple )
tuple-layout <tuple-boa> ;
! 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 -- )
<reversed> 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

15
core/compiler/compiler-docs.factor
View File

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

6
core/compiler/compiler.factor
View File

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

2
core/definitions/definitions-tests.factor
View File

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

23
core/generic/generic-tests.factor
View File

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

23
core/generic/generic.factor
View File

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

4
core/generic/math/math.factor
View File

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

2
core/generic/standard/engines/tuple/tuple.factor
View File

@ -15,7 +15,7 @@ C: <trivial-tuple-dispatch-engine> 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' )

37
core/generic/standard/standard.factor
View File

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

14
core/inference/class/class-tests.factor
View File

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

17
core/inference/class/class.factor
View File

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

9
core/inference/dataflow/dataflow.factor
View File

@ -9,15 +9,13 @@ IN: inference.dataflow
: <computed> \ <computed> counter ;
! Literal value
TUPLE: value literal uid recursion ;
TUPLE: value < identity-tuple literal uid recursion ;
: <value> ( obj -- value )
<computed> 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> 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 -- )

5
core/inference/transforms/transforms-tests.factor
View File

@ -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 <repetition> >quotation ;
: compose-n compose-n-quot call ;
@ -56,3 +57,5 @@ C: <color> 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

10
core/inference/transforms/transforms.factor
View File

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

40
core/kernel/kernel-docs.factor
View File

@ -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" } "." } ;

44
core/kernel/kernel.factor
View File

@ -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 <tuple> ;
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 <tuple-boa> ;
! 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

2
core/optimizer/control/control.factor
View File

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

12
core/optimizer/inlining/inlining.factor
View File

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

2
core/optimizer/known-words/known-words.factor
View File

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

2
core/optimizer/math/math.factor
View File

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

12
core/parser/parser.factor
View File

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

2
core/prettyprint/prettyprint-tests.factor
View File

@ -57,8 +57,6 @@ unit-test
[ ] [ \ integer see ] unit-test
[ ] [ \ general-t see ] unit-test
[ ] [ \ generic see ] unit-test
[ ] [ \ duplex-stream see ] unit-test

3
core/sequences/sequences.factor
View File

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

2
core/syntax/syntax-docs.factor
View File

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

6
core/syntax/syntax.factor
View File

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

8
core/vocabs/vocabs.factor
View File

@ -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 ;
: <vocab> ( name -- vocab )
H{ } clone
{ set-vocab-name set-vocab-words }
@ -92,10 +90,6 @@ TUPLE: vocab-link name ;
: <vocab-link> ( 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* ;

2
core/words/words.factor
View File

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

4
extra/io/launcher/launcher.factor
View File

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

9
extra/io/sockets/impl/impl.factor
View File

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

5
extra/models/models.factor
View File

@ -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? ;
: <model> ( 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 -- )

5
extra/ui/freetype/freetype.factor
View File

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

8
extra/ui/gadgets/gadgets.factor
View File

@ -44,14 +44,12 @@ M: array rect-dim drop { 0 0 } ;
: rect-union ( rect1 rect2 -- newrect )
(rect-union) <extent-rect> ;
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

4
extra/ui/gadgets/worlds/worlds.factor
View File

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