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

Rename class to class-of

Doug Coleman 2011-10-24 06:47:42 -05:00
parent a7f6982354
commit 96da8df16e
32 changed files with 70 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/bootstrap/compiler/compiler.factor
View File

@ -94,7 +94,7 @@ gc
{ {
member-eq? split harvest sift cut cut-slice start index clone member-eq? split harvest sift cut cut-slice start index clone
set-at reverse push-all class number>string string>number set-at reverse push-all class-of number>string string>number
like clone-like like clone-like
} compile-unoptimized } compile-unoptimized

6
basis/bootstrap/image/image.factor
View File

@ -48,7 +48,7 @@ M: eql-wrapper hashcode* obj>> hashcode* ;
GENERIC: (eql?) ( obj1 obj2 -- ? ) GENERIC: (eql?) ( obj1 obj2 -- ? )
: eql? ( obj1 obj2 -- ? ) : eql? ( obj1 obj2 -- ? )
{ [ [ class ] bi@ = ] [ (eql?) ] } 2&& ; { [ [ class-of ] bi@ = ] [ (eql?) ] } 2&& ;
M: fixnum (eql?) eq? ; M: fixnum (eql?) eq? ;
@ -440,11 +440,11 @@ ERROR: tuple-removed class ;
: (emit-tuple) ( tuple -- pointer ) : (emit-tuple) ( tuple -- pointer )
[ tuple-slots ] [ tuple-slots ]
[ class transfer-word require-tuple-layout ] bi prefix [ ' ] map [ class-of transfer-word require-tuple-layout ] bi prefix [ ' ] map
tuple [ emit-seq ] emit-object ; tuple [ emit-seq ] emit-object ;
: emit-tuple ( tuple -- pointer ) : emit-tuple ( tuple -- pointer )
dup class name>> "tombstone" = dup class-of name>> "tombstone" =
[ [ (emit-tuple) ] cache-eql-object ] [ [ (emit-tuple) ] cache-eql-object ]
[ [ (emit-tuple) ] cache-eq-object ] [ [ (emit-tuple) ] cache-eq-object ]
if ; if ;

18
basis/classes/struct/prettyprint/prettyprint.factor
View File

@ -19,7 +19,7 @@ IN: classes.struct.prettyprint
} cond ; } cond ;
: struct>assoc ( struct -- assoc ) : struct>assoc ( struct -- assoc )
[ class struct-slots ] [ struct-slot-values ] bi zip ; [ class-of struct-slots ] [ struct-slot-values ] bi zip ;
: pprint-struct-slot ( slot -- ) : pprint-struct-slot ( slot -- )
<flow \ { pprint-word <flow \ { pprint-word
@ -39,13 +39,13 @@ IN: classes.struct.prettyprint
: pprint-struct ( struct -- ) : pprint-struct ( struct -- )
[ [
[ \ S{ ] dip [ \ S{ ] dip
[ class ] [ class-of ]
[ struct>assoc [ [ name>> ] dip ] assoc-map ] bi [ struct>assoc [ [ name>> ] dip ] assoc-map ] bi
\ } (pprint-tuple) \ } (pprint-tuple)
] ?pprint-tuple ; ] ?pprint-tuple ;
: pprint-struct-pointer ( struct -- ) : pprint-struct-pointer ( struct -- )
\ S@ [ [ class pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ; \ S@ [ [ class-of pprint-word ] [ >c-ptr pprint* ] bi ] pprint-prefix ;
PRIVATE> PRIVATE>
@ -58,7 +58,7 @@ M: struct pprint-delims
drop \ S{ \ } ; drop \ S{ \ } ;
M: struct >pprint-sequence M: struct >pprint-sequence
[ class ] [ struct-slot-values ] bi class-slot-sequence ; [ class-of ] [ struct-slot-values ] bi class-slot-sequence ;
M: struct pprint* M: struct pprint*
[ pprint-struct ] [ pprint-struct ]
@ -66,7 +66,7 @@ M: struct pprint*
M: struct summary M: struct summary
[ [
dup class name>> % dup class-of name>> %
" struct of " % " struct of " %
byte-length # byte-length #
" bytes " % " bytes " %
@ -76,19 +76,19 @@ TUPLE: struct-mirror { object read-only } ;
C: <struct-mirror> struct-mirror C: <struct-mirror> struct-mirror
: get-struct-slot ( struct slot -- value present? ) : get-struct-slot ( struct slot -- value present? )
over class struct-slots slot-named over class-of struct-slots slot-named
[ name>> reader-word execute( struct -- value ) t ] [ name>> reader-word execute( struct -- value ) t ]
[ drop f f ] if* ; [ drop f f ] if* ;
: set-struct-slot ( value struct slot -- ) : set-struct-slot ( value struct slot -- )
over class struct-slots slot-named over class-of struct-slots slot-named
[ name>> writer-word execute( value struct -- ) ] [ name>> writer-word execute( value struct -- ) ]
[ 2drop ] if* ; [ 2drop ] if* ;
: reset-struct-slot ( struct slot -- ) : reset-struct-slot ( struct slot -- )
over class struct-slots slot-named over class-of struct-slots slot-named
[ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ] [ [ initial>> swap ] [ name>> writer-word ] bi execute( value struct -- ) ]
[ drop ] if* ; [ drop ] if* ;
: reset-struct-slots ( struct -- ) : reset-struct-slots ( struct -- )
dup class struct-prototype dup class-of struct-prototype
dup byte-length memcpy ; dup byte-length memcpy ;
M: struct-mirror at* M: struct-mirror at*

4
basis/classes/struct/struct.factor
View File

@ -52,7 +52,7 @@ M: struct >c-ptr
M: struct equal? M: struct equal?
over struct? [ over struct? [
2dup [ class ] bi@ = [ 2dup [ class-of ] bi@ = [
2dup [ >c-ptr ] both? 2dup [ >c-ptr ] both?
[ [ >c-ptr ] [ binary-object ] bi* memory= ] [ [ >c-ptr ] [ binary-object ] bi* memory= ]
[ [ >c-ptr not ] both? ] [ [ >c-ptr not ] both? ]
@ -247,7 +247,7 @@ M: struct-bit-slot-spec compute-slot-offset
PRIVATE> PRIVATE>
M: struct byte-length class "struct-size" word-prop ; foldable M: struct byte-length class-of "struct-size" word-prop ; foldable
M: struct binary-zero? binary-object uchar <c-direct-array> [ 0 = ] all? ; inline M: struct binary-zero? binary-object uchar <c-direct-array> [ 0 = ] all? ; inline
! class definition ! class definition

4
basis/compiler/cfg/stacks/uninitialized/uninitialized.factor
View File

@ -39,13 +39,13 @@ M: ##inc-r visit-insn n>> rs-loc handle-inc ;
ERROR: uninitialized-peek insn ; ERROR: uninitialized-peek insn ;
: visit-peek ( ##peek -- ) : visit-peek ( ##peek -- )
dup loc>> [ n>> ] [ class get ] bi ?nth 0 = dup loc>> [ n>> ] [ class-of get ] bi ?nth 0 =
[ uninitialized-peek ] [ drop ] if ; inline [ uninitialized-peek ] [ drop ] if ; inline
M: ##peek visit-insn visit-peek ; M: ##peek visit-insn visit-peek ;
: visit-replace ( ##replace -- ) : visit-replace ( ##replace -- )
loc>> [ n>> ] [ class get ] bi loc>> [ n>> ] [ class-of get ] bi
2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ; 2dup length < [ [ 1 ] 2dip set-nth ] [ 2drop ] if ;
M: ##replace visit-insn visit-replace ; M: ##replace visit-insn visit-replace ;

2
basis/compiler/codegen/codegen.factor
View File

@ -77,7 +77,7 @@ M: ##dispatch generate-insn
[ lookup-label resolve-label ] [ lookup-label resolve-label ]
[ [
instructions>> [ instructions>> [
[ class insn-counts get inc-at ] [ class-of insn-counts get inc-at ]
[ generate-insn ] [ generate-insn ]
bi bi
] each ] each

2
basis/compiler/tree/escape-analysis/check/check.factor
View File

@ -18,7 +18,7 @@ GENERIC: run-escape-analysis* ( node -- ? )
{ [ unbox-inputs? ] [ [ run-escape-analysis* ] any? ] } 1|| ; { [ unbox-inputs? ] [ [ run-escape-analysis* ] any? ] } 1|| ;
M: #push run-escape-analysis* M: #push run-escape-analysis*
literal>> class immutable-tuple-class? ; literal>> class-of immutable-tuple-class? ;
M: #call run-escape-analysis* M: #call run-escape-analysis*
immutable-tuple-boa? ; immutable-tuple-boa? ;

2
basis/compiler/tree/escape-analysis/simple/simple.factor
View File

@ -39,7 +39,7 @@ DEFER: record-literal-allocation
: object-slots ( object -- slots/f ) : object-slots ( object -- slots/f )
{ {
{ [ dup class immutable-tuple-class? ] [ tuple-slots ] } { [ dup class-of immutable-tuple-class? ] [ tuple-slots ] }
[ drop f ] [ drop f ]
} cond ; } cond ;

6
basis/compiler/tree/propagation/info/info.factor
View File

@ -57,7 +57,7 @@ CONSTANT: object-info T{ value-info f object full-interval }
DEFER: <literal-info> DEFER: <literal-info>
: tuple-slot-infos ( tuple -- slots ) : tuple-slot-infos ( tuple -- slots )
[ tuple-slots ] [ class all-slots ] bi [ tuple-slots ] [ class-of all-slots ] bi
[ read-only>> [ <literal-info> ] [ drop f ] if ] 2map [ read-only>> [ <literal-info> ] [ drop f ] if ] 2map
f prefix ; f prefix ;
@ -66,7 +66,7 @@ UNION: fixed-length array byte-array string ;
: literal-class ( obj -- class ) : literal-class ( obj -- class )
#! Handle forgotten tuples and singleton classes properly #! Handle forgotten tuples and singleton classes properly
dup singleton-class? [ dup singleton-class? [
class dup class? [ class-of dup class? [
drop tuple drop tuple
] unless ] unless
] unless ; ] unless ;
@ -75,7 +75,7 @@ UNION: fixed-length array byte-array string ;
"slots" word-prop length 1 - f <array> swap prefix ; "slots" word-prop length 1 - f <array> swap prefix ;
: slots-with-length ( seq -- slots ) : slots-with-length ( seq -- slots )
[ length <literal-info> ] [ class ] bi (slots-with-length) ; [ length <literal-info> ] [ class-of ] bi (slots-with-length) ;
: init-literal-info ( info -- info ) : init-literal-info ( info -- info )
empty-interval >>interval empty-interval >>interval

2
basis/compiler/tree/propagation/slots/slots.factor
View File

@ -60,7 +60,7 @@ IN: compiler.tree.propagation.slots
#! heap would use the old layout since instances are updated #! heap would use the old layout since instances are updated
#! immediately after compilation. #! immediately after compilation.
{ {
[ class read-only-slot? ] [ class-of read-only-slot? ]
[ nip layout-up-to-date? ] [ nip layout-up-to-date? ]
[ swap slot <literal-info> ] [ swap slot <literal-info> ]
} 2&& ; } 2&& ;

6
basis/debugger/debugger.factor
View File

@ -17,7 +17,7 @@ GENERIC: error-help ( error -- topic )
M: object error-help drop f ; M: object error-help drop f ;
M: tuple error-help class ; M: tuple error-help class-of ;
M: source-file-error error-help error>> error-help ; M: source-file-error error-help error>> error-help ;
@ -89,7 +89,7 @@ M: string error. print ;
: type-check-error. ( obj -- ) : type-check-error. ( obj -- )
"Type check error" print "Type check error" print
"Object: " write dup fourth short. "Object: " write dup fourth short.
"Object type: " write dup fourth class . "Object type: " write dup fourth class-of .
"Expected type: " write third type>class . ; "Expected type: " write third type>class . ;
: divide-by-zero-error. ( obj -- ) : divide-by-zero-error. ( obj -- )
@ -176,7 +176,7 @@ M: no-method error.
"Generic word " write "Generic word " write
dup generic>> pprint dup generic>> pprint
" does not define a method for the " write " does not define a method for the " write
dup object>> class pprint dup object>> class-of pprint
" class." print " class." print
"Dispatching on object: " write object>> short. ; "Dispatching on object: " write object>> short. ;

2
basis/hints/hints.factor
View File

@ -18,7 +18,7 @@ GENERIC: specializer-declaration ( spec -- class )
M: class specializer-declaration ; M: class specializer-declaration ;
M: object specializer-declaration class ; M: object specializer-declaration class-of ;
: specializer ( word -- specializer ) : specializer ( word -- specializer )
"specializer" word-prop ; "specializer" word-prop ;

4
basis/io/sockets/sockets.factor
View File

@ -288,8 +288,8 @@ HOOK: (receive-unsafe) io-backend ( n buf datagram -- size addrspec )
ERROR: invalid-port object ; ERROR: invalid-port object ;
: check-port ( packet addrspec port -- packet addrspec port ) : check-port ( packet addrspec port -- packet addrspec port )
2dup addr>> [ class ] bi@ assert= 2dup addr>> [ class-of ] bi@ assert=
pick class byte-array assert= ; pick class-of byte-array assert= ;
: check-connectionless-port ( port -- port ) : check-connectionless-port ( port -- port )
dup { [ datagram-port? ] [ raw-port? ] } 1|| [ invalid-port ] unless ; dup { [ datagram-port? ] [ raw-port? ] } 1|| [ invalid-port ] unless ;

2
basis/locals/rewrite/sugar/sugar.factor
View File

@ -66,7 +66,7 @@ M: hashtable rewrite-element
M: tuple rewrite-element M: tuple rewrite-element
dup rewrite-literal? [ dup rewrite-literal? [
[ tuple-slots rewrite-elements ] [ class ] bi '[ _ boa ] % [ tuple-slots rewrite-elements ] [ class-of ] bi '[ _ boa ] %
] [ , ] if ; ] [ , ] if ;
M: quotation rewrite-element rewrite-sugar* ; M: quotation rewrite-element rewrite-sugar* ;

2
basis/mirrors/mirrors.factor
View File

@ -10,7 +10,7 @@ TUPLE: mirror { object read-only } ;
C: <mirror> mirror C: <mirror> mirror
: object-slots ( mirror -- slots ) object>> class all-slots ; inline : object-slots ( mirror -- slots ) object>> class-of all-slots ; inline
M: mirror at* M: mirror at*
[ nip object>> ] [ object-slots slot-named ] 2bi [ nip object>> ] [ object-slots slot-named ] 2bi

2
basis/peg/peg.factor
View File

@ -12,7 +12,7 @@ TUPLE: parse-result remaining ast ;
TUPLE: parse-error position messages ; TUPLE: parse-error position messages ;
TUPLE: parser peg compiled id ; TUPLE: parser peg compiled id ;
M: parser equal? { [ [ class ] bi@ = ] [ [ id>> ] bi@ = ] } 2&& ; M: parser equal? { [ [ class-of ] bi@ = ] [ [ id>> ] bi@ = ] } 2&& ;
M: parser hashcode* id>> hashcode* ; M: parser hashcode* id>> hashcode* ;
C: <parse-result> parse-result C: <parse-result> parse-result

8
basis/prettyprint/backend/backend.factor
View File

@ -117,7 +117,7 @@ M: pathname pprint*
: check-recursion ( obj quot -- ) : check-recursion ( obj quot -- )
nesting-limit? [ nesting-limit? [
drop drop
[ class name>> "~" dup surround ] keep present-text [ class-of name>> "~" dup surround ] keep present-text
] [ ] [
over recursion-check get member-eq? [ over recursion-check get member-eq? [
drop "~circularity~" swap present-text drop "~circularity~" swap present-text
@ -133,7 +133,7 @@ M: pathname pprint*
[ [ name>> ] dip ] assoc-map ; [ [ name>> ] dip ] assoc-map ;
: tuple>assoc ( tuple -- assoc ) : tuple>assoc ( tuple -- assoc )
[ class all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ; [ class-of all-slots ] [ tuple-slots ] bi zip filter-tuple-assoc ;
: pprint-slot-value ( name value -- ) : pprint-slot-value ( name value -- )
<flow \ { pprint-word <flow \ { pprint-word
@ -152,7 +152,7 @@ M: pathname pprint*
[ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline [ boa-tuples? get [ pprint-object ] ] dip [ check-recursion ] curry if ; inline
: pprint-tuple ( tuple -- ) : pprint-tuple ( tuple -- )
[ [ \ T{ ] dip [ class ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ; [ [ \ T{ ] dip [ class-of ] [ tuple>assoc ] bi \ } (pprint-tuple) ] ?pprint-tuple ;
M: tuple pprint* M: tuple pprint*
pprint-tuple ; pprint-tuple ;
@ -203,7 +203,7 @@ M: hash-set >pprint-sequence members ;
[ 1array ] [ [ f 2array ] dip append ] if-empty ; [ 1array ] [ [ f 2array ] dip append ] if-empty ;
M: tuple >pprint-sequence M: tuple >pprint-sequence
[ class ] [ tuple-slots ] bi class-slot-sequence ; [ class-of ] [ tuple-slots ] bi class-slot-sequence ;
M: object pprint-narrow? drop f ; M: object pprint-narrow? drop f ;
M: byte-vector pprint-narrow? drop f ; M: byte-vector pprint-narrow? drop f ;

6
basis/summary/summary.factor
View File

@ -7,13 +7,13 @@ IN: summary
GENERIC: summary ( object -- string ) GENERIC: summary ( object -- string )
: object-summary ( object -- string ) : object-summary ( object -- string )
class name>> ; class-of name>> ;
M: object summary object-summary ; M: object summary object-summary ;
M: sequence summary M: sequence summary
[ [
dup class name>> % dup class-of name>> %
" with " % " with " %
length # length #
" elements" % " elements" %
@ -21,7 +21,7 @@ M: sequence summary
M: assoc summary M: assoc summary
[ [
dup class name>> % dup class-of name>> %
" with " % " with " %
assoc-size # assoc-size #
" entries" % " entries" %

2
basis/tools/destructors/destructors.factor
View File

@ -8,7 +8,7 @@ IN: tools.destructors
<PRIVATE <PRIVATE
: class-tally ( assoc -- assoc' ) : class-tally ( assoc -- assoc' )
H{ } clone [ [ keys ] dip '[ dup class _ push-at ] each ] keep ; H{ } clone [ [ keys ] dip '[ dup class-of _ push-at ] each ] keep ;
: (disposables.) ( assoc -- ) : (disposables.) ( assoc -- )
class-tally >alist [ first2 [ length ] keep 3array ] map [ second ] sort-with class-tally >alist [ first2 [ length ] keep 3array ] map [ second ] sort-with

4
basis/tools/memory/memory.factor
View File

@ -72,8 +72,8 @@ PRIVATE>
<PRIVATE <PRIVATE
: heap-stat-step ( obj counts sizes -- ) : heap-stat-step ( obj counts sizes -- )
[ [ class ] dip inc-at ] [ [ class-of ] dip inc-at ]
[ [ [ size ] [ class ] bi ] dip at+ ] bi-curry* bi ; [ [ [ size ] [ class-of ] bi ] dip at+ ] bi-curry* bi ;
PRIVATE> PRIVATE>

2
basis/ui/gadgets/buttons/buttons.factor
View File

@ -248,7 +248,7 @@ PRIVATE>
1 >>fill 1 >>fill
{ 5 5 } >>gap { 5 5 } >>gap
swap swap
[ [ "toolbar" ] dip class command-map commands>> ] [ [ "toolbar" ] dip class-of command-map commands>> ]
[ '[ [ _ ] 2dip <command-button> add-gadget ] ] [ '[ [ _ ] 2dip <command-button> add-gadget ] ]
bi assoc-each ; bi assoc-each ;

2
basis/ui/gestures/gestures.factor
View File

@ -10,7 +10,7 @@ FROM: sets => members ;
IN: ui.gestures IN: ui.gestures
: get-gesture-handler ( gesture gadget -- quot ) : get-gesture-handler ( gesture gadget -- quot )
class superclasses [ "gestures" word-prop ] map assoc-stack ; class-of superclasses [ "gestures" word-prop ] map assoc-stack ;
GENERIC: handle-gesture ( gesture gadget -- ? ) GENERIC: handle-gesture ( gesture gadget -- ? )

2
basis/ui/pixel-formats/pixel-formats.factor
View File

@ -77,7 +77,7 @@ M: object >PFA
M: word >PFA M: word >PFA
TABLE at [ { } ] unless* ; TABLE at [ { } ] unless* ;
M: pixel-format-attribute >PFA M: pixel-format-attribute >PFA
dup class TABLE at dup class-of TABLE at
[ swap value>> suffix ] [ swap value>> suffix ]
[ drop { } ] if* ; [ drop { } ] if* ;

2
basis/ui/tools/browser/browser.factor
View File

@ -97,7 +97,7 @@ M: browser-gadget focusable-child* search-field>> ;
: error-help-window ( error -- ) : error-help-window ( error -- )
{ {
[ error-help ] [ error-help ]
[ dup tuple? [ class ] [ drop "errors" ] if ] [ dup tuple? [ class-of ] [ drop "errors" ] if ]
} 1|| (browser-window) ; } 1|| (browser-window) ;
\ browser-window H{ { +nullary+ t } } define-command \ browser-window H{ { +nullary+ t } } define-command

4
basis/ui/tools/common/common.factor
View File

@ -12,11 +12,11 @@ tool-dims [ H{ } clone ] initialize
TUPLE: tool < track ; TUPLE: tool < track ;
M: tool pref-dim* M: tool pref-dim*
{ [ class tool-dims get at ] [ call-next-method ] } 1|| ; { [ class-of tool-dims get at ] [ call-next-method ] } 1|| ;
M: tool layout* M: tool layout*
[ call-next-method ] [ call-next-method ]
[ [ dim>> ] [ class ] bi tool-dims get set-at ] [ [ dim>> ] [ class-of ] bi tool-dims get set-at ]
bi ; bi ;
: set-tool-dim ( dim class -- ) tool-dims get set-at ; : set-tool-dim ( dim class -- ) tool-dims get set-at ;

2
basis/ui/tools/inspector/inspector.factor
View File

@ -33,7 +33,7 @@ M: inspector-renderer column-titles
[ [
[ [
[ "Class:" write ] with-cell [ "Class:" write ] with-cell
[ class pprint ] with-cell [ class-of pprint ] with-cell
] with-row ] with-row
] ]
[ [

2
core/classes/builtin/builtin.factor
View File

@ -16,7 +16,7 @@ PREDICATE: builtin-class < class
: bootstrap-type>class ( n -- class ) builtins get nth ; : bootstrap-type>class ( n -- class ) builtins get nth ;
M: object class tag type>class ; inline M: object class-of tag type>class ; inline
M: builtin-class rank-class drop 0 ; M: builtin-class rank-class drop 0 ;

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

@ -33,7 +33,7 @@ $nl
"Classes themselves form a class:" "Classes themselves form a class:"
{ $subsections class? } { $subsections class? }
"You can ask an object for its class:" "You can ask an object for its class:"
{ $subsections class } { $subsections class-of }
"Testing if an object is an instance of a class:" "Testing if an object is an instance of a class:"
{ $subsections instance? } { $subsections instance? }
"You can ask a class for its superclass:" "You can ask a class for its superclass:"
@ -71,11 +71,11 @@ $nl
ABOUT: "classes" ABOUT: "classes"
HELP: class HELP: class-of
{ $values { "object" object } { "class" class } } { $values { "object" object } { "class" class } }
{ $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." } { $description "Outputs an object's canonical class. While an object may be an instance of more than one class, the canonical class is either its built-in class, or if the object is a tuple, its tuple class." }
{ $class-description "The class of all class words." } { $class-description "The class of all class words." }
{ $examples { $example "USING: classes prettyprint ;" "1.0 class ." "float" } { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class ." "point" } } ; { $examples { $example "USING: classes prettyprint ;" "1.0 class-of ." "float" } { $example "USING: classes prettyprint ;" "IN: scratchpad" "TUPLE: point x y z ;\nT{ point f 1 2 3 } class-of ." "point" } } ;
HELP: classes HELP: classes
{ $values { "seq" "a sequence of class words" } } { $values { "seq" "a sequence of class words" } }

2
core/classes/classes.factor
View File

@ -224,6 +224,6 @@ M: class metaclass-changed
M: class forget* ( class -- ) M: class forget* ( class -- )
[ call-next-method ] [ forget-class ] bi ; [ call-next-method ] [ forget-class ] bi ;
GENERIC: class ( object -- class ) GENERIC: class-of ( object -- class )
GENERIC: instance? ( object class -- ? ) flushable GENERIC: instance? ( object class -- ? ) flushable

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

@ -67,7 +67,7 @@ C: <predicate-test> predicate-test
[ t ] [ <predicate-test> predicate-test? ] unit-test [ t ] [ <predicate-test> predicate-test? ] unit-test
PREDICATE: silly-pred < tuple PREDICATE: silly-pred < tuple
class \ rect = ; class-of \ rect = ;
GENERIC: area ( obj -- n ) GENERIC: area ( obj -- n )
M: silly-pred area dup w>> swap h>> * ; M: silly-pred area dup w>> swap h>> * ;
@ -218,7 +218,7 @@ C: <laptop> laptop
[ t ] [ "laptop" get tuple? ] unit-test [ t ] [ "laptop" get tuple? ] unit-test
: test-laptop-slot-values ( -- ) : test-laptop-slot-values ( -- )
[ laptop ] [ "laptop" get class ] unit-test [ laptop ] [ "laptop" get class-of ] unit-test
[ "Pentium" ] [ "laptop" get cpu>> ] unit-test [ "Pentium" ] [ "laptop" get cpu>> ] unit-test
[ 128 ] [ "laptop" get ram>> ] unit-test [ 128 ] [ "laptop" get ram>> ] unit-test
[ t ] [ "laptop" get battery>> 3 hours = ] unit-test ; [ t ] [ "laptop" get battery>> 3 hours = ] unit-test ;
@ -245,7 +245,7 @@ C: <server> server
[ t ] [ "server" get tuple? ] unit-test [ t ] [ "server" get tuple? ] unit-test
: test-server-slot-values ( -- ) : test-server-slot-values ( -- )
[ server ] [ "server" get class ] unit-test [ server ] [ "server" get class-of ] unit-test
[ "PowerPC" ] [ "server" get cpu>> ] unit-test [ "PowerPC" ] [ "server" get cpu>> ] unit-test
[ 64 ] [ "server" get ram>> ] unit-test [ 64 ] [ "server" get ram>> ] unit-test
[ "1U" ] [ "server" get rackmount>> ] unit-test ; [ "1U" ] [ "server" get rackmount>> ] unit-test ;
@ -539,23 +539,23 @@ must-fail-with
! Check bignum coercer ! Check bignum coercer
TUPLE: bignum-coercer { n bignum initial: $[ 0 >bignum ] } ; TUPLE: bignum-coercer { n bignum initial: $[ 0 >bignum ] } ;
[ 13 bignum ] [ 13.5 bignum-coercer boa n>> dup class ] unit-test [ 13 bignum ] [ 13.5 bignum-coercer boa n>> dup class-of ] unit-test
[ 13 bignum ] [ bignum-coercer new 13.5 >>n n>> dup class ] unit-test [ 13 bignum ] [ bignum-coercer new 13.5 >>n n>> dup class-of ] unit-test
! Check float coercer ! Check float coercer
TUPLE: float-coercer { n float } ; TUPLE: float-coercer { n float } ;
[ 13.0 float ] [ 13 float-coercer boa n>> dup class ] unit-test [ 13.0 float ] [ 13 float-coercer boa n>> dup class-of ] unit-test
[ 13.0 float ] [ float-coercer new 13 >>n n>> dup class ] unit-test [ 13.0 float ] [ float-coercer new 13 >>n n>> dup class-of ] unit-test
! Check integer coercer ! Check integer coercer
TUPLE: integer-coercer { n integer } ; TUPLE: integer-coercer { n integer } ;
[ 13 fixnum ] [ 13.5 integer-coercer boa n>> dup class ] unit-test [ 13 fixnum ] [ 13.5 integer-coercer boa n>> dup class-of ] unit-test
[ 13 fixnum ] [ integer-coercer new 13.5 >>n n>> dup class ] unit-test [ 13 fixnum ] [ integer-coercer new 13.5 >>n n>> dup class-of ] unit-test
: foo ( a b -- c ) declared-types boa ; : foo ( a b -- c ) declared-types boa ;
@ -610,7 +610,7 @@ T{ reshape-test f "hi" } "tuple" set
TUPLE: boa-coercer-test { x array-capacity } ; TUPLE: boa-coercer-test { x array-capacity } ;
[ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class ] unit-test [ fixnum ] [ 0 >bignum boa-coercer-test boa x>> class-of ] unit-test
[ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test [ T{ boa-coercer-test f 0 } ] [ T{ boa-coercer-test } ] unit-test

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

@ -27,14 +27,14 @@ PREDICATE: immutable-tuple-class < tuple-class
: layout-of ( tuple -- layout ) : layout-of ( tuple -- layout )
1 slot { array } declare ; inline 1 slot { array } declare ; inline
M: tuple class layout-of 2 slot { word } declare ; inline M: tuple class-of layout-of 2 slot { word } declare ; inline
: tuple-size ( tuple -- size ) : tuple-size ( tuple -- size )
layout-of 3 slot { fixnum } declare ; inline layout-of 3 slot { fixnum } declare ; inline
: layout-up-to-date? ( object -- ? ) : layout-up-to-date? ( object -- ? )
dup tuple? dup tuple?
[ [ layout-of ] [ class tuple-layout ] bi eq? ] [ drop t ] if ; [ [ layout-of ] [ class-of tuple-layout ] bi eq? ] [ drop t ] if ;
: check-tuple ( object -- tuple ) : check-tuple ( object -- tuple )
dup tuple? [ not-a-tuple ] unless ; inline dup tuple? [ not-a-tuple ] unless ; inline
@ -196,7 +196,7 @@ SYMBOL: outdated-tuples
: outdated-tuple? ( tuple assoc -- ? ) : outdated-tuple? ( tuple assoc -- ? )
[ [ layout-of ] dip key? ] [ [ layout-of ] dip key? ]
[ drop class "forgotten" word-prop not ] [ drop class-of "forgotten" word-prop not ]
2bi and ; 2bi and ;
: update-tuples ( -- ) : update-tuples ( -- )
@ -356,7 +356,7 @@ M: tuple equal? over tuple? [ tuple= ] [ 2drop f ] if ;
: tuple-hashcode ( depth obj -- hash ) : tuple-hashcode ( depth obj -- hash )
[ [
[ drop 1000003 ] dip [ drop 1000003 ] dip
[ class hashcode ] [ tuple-size ] bi [ class-of hashcode ] [ tuple-size ] bi
[ dup fixnum+fast 82520 fixnum+fast ] [ iota ] bi [ dup fixnum+fast 82520 fixnum+fast ] [ iota ] bi
] 2keep [ ] 2keep [
swapd array-nth hashcode* >fixnum rot fixnum-bitxor swapd array-nth hashcode* >fixnum rot fixnum-bitxor

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

@ -88,7 +88,7 @@ SYMBOL: generic-word
swap [ [ tag-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ; swap [ [ tag-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;
: tuple-dispatch-entry ( class picker -- quot ) : tuple-dispatch-entry ( class picker -- quot )
[ 1quotation [ { tuple } declare class ] [ eq? ] surround ] dip prepend ; [ 1quotation [ { tuple } declare class-of ] [ eq? ] surround ] dip prepend ;
: tuple-dispatch ( picker alist -- alist' ) : tuple-dispatch ( picker alist -- alist' )
swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ; swap [ [ tuple-dispatch-entry ] curry dip ] curry assoc-map math-alist>quot ;