#! Words containing call sites with inferred type 'class'
#! which inlined a method on 'generic'
generic-call-sites-of swap '[
- nip _ 2dup [ classoid? ] both?
+ nip _ 2dup [ valid-classoid? ] both?
[ classes-intersect? ] [ 2drop f ] if
] assoc-filter keys ;
?effect-height 0 < [ end-group ] when ;
! Atoms
-: word-name* ( word -- str )
- name>> "( no name )" or ;
+GENERIC: word-name* ( obj -- str )
+
+M: maybe word-name*
+ class>> word-name* "maybe: " prepend ;
+
+M: word word-name* ( word -- str )
+ [ name>> "( no name )" or ] [ record-vocab ] bi ;
: pprint-word ( word -- )
- [ record-vocab ]
- [ [ word-name* ] [ word-style ] bi styled-text ] bi ;
+ [ word-name* ] [ word-style ] bi styled-text ;
+
+GENERIC: pprint-class ( obj -- )
+
+M: maybe pprint-class pprint* ;
+
+M: class pprint-class \ f or pprint-word ;
: pprint-prefix ( word quot -- )
<block swap pprint-word call block> ; inline
[ pprint-word ] [ ?start-group ] [ ?end-group ] tri ;
M: method pprint*
- [
- [
- [ "M\\ " % "method-class" word-prop word-name* % ]
- [ " " % "method-generic" word-prop word-name* % ] bi
- ] "" make
- ] [ word-style ] bi styled-text ;
+ <block
+ [ \ M\ pprint-word "method-class" word-prop pprint-class ]
+ [ "method-generic" word-prop pprint-word ] bi
+ block> ;
M: real pprint*
number-base get {
TUPLE: bob a b ;
[ "maybe: bob\n" ] [ [ maybe: bob . ] with-string-writer ] unit-test
[ "maybe: word\n" ] [ [ maybe: word . ] with-string-writer ] unit-test
+
+
+TUPLE: har a ;
+GENERIC: harhar ( obj -- obj )
+M: maybe: har harhar ;
+M: integer harhar M\ integer harhar drop ;
+[
+"""USING: prettyprint.tests ;
+M: maybe: har harhar ;
+
+USING: kernel math prettyprint.tests ;
+M: integer harhar M\\ integer harhar drop ;\n"""
+] [
+ [ \ harhar see-methods ] with-string-writer
+] unit-test
USING: arrays generic hashtables io kernel math assocs
namespaces make sequences strings io.styles vectors words
prettyprint.config splitting classes continuations
-accessors sets vocabs.parser combinators vocabs ;
+accessors sets vocabs.parser combinators vocabs
+classes.maybe ;
FROM: namespaces => set ;
IN: prettyprint.sections
dup pprinter-in get dup [ vocab-name ] when =
[ drop ] [ pprinter-use get conjoin ] if ;
+GENERIC: vocabulary-name ( obj -- string )
+
+M: word vocabulary-name
+ vocabulary>> ;
+
+M: maybe vocabulary-name
+ class>> vocabulary>> ;
+
: record-vocab ( word -- )
- vocabulary>> {
+ vocabulary-name {
{ f [ ] }
{ "syntax" [ ] }
[ (record-vocab) ]
M: method synopsis*
[ definer. ]
- [ "method-class" word-prop pprint-word ]
+ [ "method-class" word-prop pprint-class ]
[ "method-generic" word-prop pprint-word ] tri ;
M: mixin-instance synopsis*
M: depends-on-class-predicate satisfied?
{
- [ [ class1>> classoid? ] [ class2>> classoid? ] bi and ]
+ [ [ class1>> valid-classoid? ] [ class2>> valid-classoid? ] bi and ]
[ [ [ class1>> ] [ class2>> ] bi evaluate-class-predicate ] [ result>> ] bi eq? ]
} 1&& ;
M: depends-on-instance-predicate satisfied?
{
- [ class>> classoid? ]
+ [ class>> valid-classoid? ]
[ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
} 1&& ;
M: depends-on-next-method satisfied?
{
- [ class>> classoid? ]
+ [ class>> valid-classoid? ]
[ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
} 1&& ;
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel classes classes.private combinators accessors
-sequences arrays vectors assocs namespaces words sorting layouts
-math hashtables kernel.private sets math.order ;
+USING: accessors arrays assocs classes classes.private
+combinators kernel math math.order namespaces sequences sorting
+vectors words ;
FROM: classes => members ;
RENAME: members sets => set-members
IN: classes.algebra
GENERIC: classoid? ( obj -- ? )
M: word classoid? class? ;
-M: anonymous-union classoid? members>> [ classoid? ] all? ;
-M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;
-M: anonymous-complement classoid? class>> classoid? ;
+M: anonymous-union classoid? drop t ;
+M: anonymous-intersection classoid? drop t ;
+M: anonymous-complement classoid? drop t ;
+
+GENERIC: valid-classoid? ( obj -- ? )
+
+M: word valid-classoid? class? ;
+M: anonymous-union valid-classoid? members>> [ valid-classoid? ] all? ;
+M: anonymous-intersection valid-classoid? participants>> [ valid-classoid? ] all? ;
+M: anonymous-complement valid-classoid? class>> valid-classoid? ;
: class<= ( first second -- ? )
class<=-cache get [ (class<=) ] 2cache ;
[ topological-sort-failed ] unless* ;
: sort-classes ( seq -- newseq )
- [ name>> ] sort-with >vector
+ [ class-name ] sort-with >vector
[ dup empty? not ]
[ dup largest-class [ swap remove-nth! ] dip ]
produce nip ;
! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors classes classes.private classes.algebra
-classes.algebra.private words kernel kernel.private namespaces
-sequences math math.private combinators assocs quotations ;
+USING: classes classes.algebra.private classes.private kernel
+kernel.private namespaces sequences words ;
IN: classes.builtin
SYMBOL: builtins
SYMBOL: implementors-map
+GENERIC: class-name ( class -- string )
+
+M: class class-name name>> ;
+
GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )
--- /dev/null
+! Copyright (C) 2011 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: classes.maybe eval generic.single kernel tools.test
+math classes accessors slots classes.algebra ;
+IN: classes.maybe.tests
+
+[ t ] [ 3 maybe: integer instance? ] unit-test
+[ t ] [ f maybe: integer instance? ] unit-test
+[ f ] [ 3.0 maybe: integer instance? ] unit-test
+
+TUPLE: maybe-integer-container { something maybe: integer } ;
+
+[ f ] [ maybe-integer-container new something>> ] unit-test
+[ 3 ] [ maybe-integer-container new 3 >>something something>> ] unit-test
+[ maybe-integer-container new 3.0 >>something ] [ bad-slot-value? ] must-fail-with
+
+TUPLE: self-pointer { next maybe: self-pointer } ;
+
+[ T{ self-pointer { next T{ self-pointer } } } ]
+[ self-pointer new self-pointer new >>next ] unit-test
+
+[ t ] [ f maybe: f instance? ] unit-test
+
+PREDICATE: natural < maybe: integer
+ 0 > ;
+
+[ f ] [ -1 natural? ] unit-test
+[ f ] [ 0 natural? ] unit-test
+[ t ] [ 1 natural? ] unit-test
+
+[ "USE: math maybe: maybe: integer" eval( -- obj ) ] [ error>> bad-slot-value? ] must-fail-with
+
+INTERSECTION: only-f maybe: integer POSTPONE: f ;
+
+[ t ] [ f only-f instance? ] unit-test
+[ f ] [ t only-f instance? ] unit-test
+[ f ] [ 30 only-f instance? ] unit-test
+
+UNION: ?integer-float maybe: integer maybe: float ;
+
+[ t ] [ 30 ?integer-float instance? ] unit-test
+[ t ] [ 30.0 ?integer-float instance? ] unit-test
+[ t ] [ f ?integer-float instance? ] unit-test
+[ f ] [ t ?integer-float instance? ] unit-test
+
+TUPLE: foo ;
+GENERIC: lol ( obj -- string )
+M: maybe: foo lol drop "lol" ;
+
+[ "lol" ] [ foo new lol ] unit-test
+[ "lol" ] [ f lol ] unit-test
+[ 3 lol ] [ no-method? ] must-fail-with
+
+TUPLE: foo2 a ;
+GENERIC: lol2 ( obj -- string )
+M: maybe: foo lol2 drop "lol2" ;
+M: f lol2 drop "lol22" ;
+
+[ "lol2" ] [ foo new lol2 ] unit-test
+[ "lol22" ] [ f lol2 ] unit-test
+[ 3 lol2 ] [ no-method? ] must-fail-with
+
+[ t ] [ \ + <maybe> classoid? ] unit-test
+[ f ] [ \ + <maybe> valid-classoid? ] unit-test
! Copyright (C) 2011 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors classes classes.algebra
-classes.algebra.private classes.private effects generic
-kernel sequences words classes.union classes.union.private ;
+classes.algebra.private classes.private classes.union.private
+effects kernel words ;
IN: classes.maybe
TUPLE: maybe { class word initial: object read-only } ;
M: maybe instance?
over [ class>> instance? ] [ 2drop t ] if ;
-M: maybe normalize-class
+: maybe-class-or ( maybe -- classoid )
class>> \ f class-or ;
+M: maybe normalize-class
+ maybe-class-or ;
+
M: maybe classoid? drop t ;
+M: maybe valid-classoid? class>> valid-classoid? ;
+
M: maybe rank-class drop 6 ;
M: maybe (flatten-class)
- class>> (flatten-class) ;
+ maybe-class-or (flatten-class) ;
M: maybe effect>type ;
-M: maybe method-word-name
- [ class>> name>> ] [ name>> ] bi* "=>" glue ;
-
M: maybe union-of-builtins?
class>> union-of-builtins? ;
+M: maybe class-name
+ class>> name>> ;
[ ] [ "IN: classes.union.tests USE: vectors UNION: fast-union-1 vector ;" eval( -- ) ] unit-test
[ f ] [ "fast-union-2?" "classes.union.tests" lookup-word def>> \ fixnum-bitand swap member? ] unit-test
-
-! Test maybe
-
-[ t ] [ 3 maybe: integer instance? ] unit-test
-[ t ] [ f maybe: integer instance? ] unit-test
-[ f ] [ 3.0 maybe: integer instance? ] unit-test
-
-TUPLE: maybe-integer-container { something maybe: integer } ;
-
-[ f ] [ maybe-integer-container new something>> ] unit-test
-[ 3 ] [ maybe-integer-container new 3 >>something something>> ] unit-test
-[ maybe-integer-container new 3.0 >>something ] [ bad-slot-value? ] must-fail-with
-
-TUPLE: self-pointer { next maybe: self-pointer } ;
-
-[ T{ self-pointer { next T{ self-pointer } } } ]
-[ self-pointer new self-pointer new >>next ] unit-test
-
-[ t ] [ f maybe: f instance? ] unit-test
-
-PREDICATE: natural < maybe: integer
- 0 > ;
-
-[ f ] [ -1 natural? ] unit-test
-[ f ] [ 0 natural? ] unit-test
-[ t ] [ 1 natural? ] unit-test
-
-[ "USE: math maybe: maybe: integer" eval( -- obj ) ] [ error>> bad-slot-value? ] must-fail-with
-
-INTERSECTION: only-f maybe: integer POSTPONE: f ;
-
-[ t ] [ f only-f instance? ] unit-test
-[ f ] [ t only-f instance? ] unit-test
-[ f ] [ 30 only-f instance? ] unit-test
-
-UNION: ?integer-float maybe: integer maybe: float ;
-
-[ t ] [ 30 ?integer-float instance? ] unit-test
-[ t ] [ 30.0 ?integer-float instance? ] unit-test
-[ t ] [ f ?integer-float instance? ] unit-test
-[ f ] [ t ?integer-float instance? ] unit-test
USING: accessors words kernel sequences namespaces make assocs
hashtables definitions kernel.private classes classes.private
classes.algebra quotations arrays vocabs effects combinators
-sets ;
+sets classes.maybe ;
FROM: namespaces => set ;
IN: generic
M: class method-word-name ( class generic -- string )
[ name>> ] bi@ "=>" glue ;
+M: maybe method-word-name
+ [ class>> name>> ] [ name>> ] bi* "=>" glue ;
+
M: method parent-word
"method-generic" word-prop ;
[ method-word-name f <word> ] [ method-word-props ] 2bi
>>props ;
+GENERIC: implementor-class ( obj -- class )
+
+M: maybe implementor-class class>> ;
+
+M: class implementor-class ;
+
: with-implementors ( class generic quot -- )
- [ swap implementors-map get at ] dip call ; inline
+ [ swap implementor-class implementors-map get at ] dip call ; inline
: reveal-method ( method class generic -- )
[ [ conjoin ] with-implementors ]
{ $errors "Throws an error if the token is not a number or end of file is reached." }
$parsing-note ;
-HELP: parse-step
+HELP: parse-until-step
{ $values { "accum" vector } { "end" word } { "?" "a boolean" } }
{ $description "Parses a token. If the token is a number or an ordinary word, it is added to the accumulator. If it is a parsing word, calls the parsing word with the accumulator on the stack. Outputs " { $link f } " if " { $snippet "end" } " is encountered, " { $link t } " otherwise." }
$parsing-note ;
V{ } clone swap execute-parsing first
] when ;
-ERROR: classoid-expected word ;
-
: scan-class ( -- class )
- scan-object \ f or
- dup classoid? [ classoid-expected ] unless ;
+ scan-object \ f or ;
-: parse-step ( accum end -- accum ? )
+: parse-until-step ( accum end -- accum ? )
(scan-datum) {
{ [ 2dup eq? ] [ 2drop f ] }
{ [ dup not ] [ drop unexpected-eof t ] }
} cond ;
: (parse-until) ( accum end -- accum )
- [ parse-step ] keep swap [ (parse-until) ] [ drop ] if ;
+ [ parse-until-step ] keep swap [ (parse-until) ] [ drop ] if ;
: parse-until ( end -- vec )
100 <vector> swap (parse-until) ;
projects / factor.git / commitdiff