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

classes: Make methods dispatch on maybes. Fix a couple bugs in the implementation of maybe. classoid? is now a dumb test if an object could be a well-formed classoid; valid-classoid? tests for well-formedness. Move maybe tests. Make pprint* work better on methods.

db4
Doug Coleman 2011-11-22 14:47:52 -08:00
parent fac17c10ba
commit cab0369fec
15 changed files with 159 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/compiler/compiler.factor
View File

@ -151,7 +151,7 @@ M: optimizing-compiler update-call-sites ( class generic -- words )
#! 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 ;

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

@ -23,12 +23,22 @@ M: effect pprint* effect>string text ;
?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
@ -40,12 +50,10 @@ M: word pprint*
[ 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 {

15
basis/prettyprint/prettyprint-tests.factor
View File

@ -391,3 +391,18 @@ TUPLE: final-tuple ; final
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

13
basis/prettyprint/sections/sections.factor
View File

@ -3,7 +3,8 @@
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
@ -24,8 +25,16 @@ TUPLE: pprinter last-newline line-count indent ;
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) ]

2
basis/see/see.factor
View File

@ -81,7 +81,7 @@ M: hook-generic synopsis*
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*

6
basis/stack-checker/dependencies/dependencies.factor
View File

@ -78,7 +78,7 @@ TUPLE: depends-on-class-predicate class1 class2 result ;
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&& ;
@ -89,7 +89,7 @@ TUPLE: depends-on-instance-predicate object class result ;
M: depends-on-instance-predicate satisfied?
{
[ class>> classoid? ]
[ class>> valid-classoid? ]
[ [ [ object>> ] [ class>> ] bi instance? ] [ result>> ] bi eq? ]
} 1&& ;
@ -101,7 +101,7 @@ TUPLE: depends-on-next-method class generic next-method ;
M: depends-on-next-method satisfied?
{
[ class>> classoid? ]
[ class>> valid-classoid? ]
[ [ [ class>> ] [ generic>> ] bi next-method ] [ next-method>> ] bi eq? ]
} 1&& ;

21
core/classes/algebra/algebra.factor
View File

@ -1,8 +1,8 @@
! 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
@ -55,9 +55,16 @@ PRIVATE>
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 ;
@ -255,7 +262,7 @@ ERROR: topological-sort-failed ;
[ 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 ;

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

@ -1,8 +1,7 @@
! 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

4
core/classes/classes.factor
View File

@ -40,6 +40,10 @@ SYMBOL: update-map
SYMBOL: implementors-map
GENERIC: class-name ( class -- string )
M: class class-name name>> ;
GENERIC: rank-class ( class -- n )
GENERIC: reset-class ( class -- )

64
core/classes/maybe/maybe-tests.factor Normal file
View File

@ -0,0 +1,64 @@
! 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

18
core/classes/maybe/maybe.factor
View File

@ -1,8 +1,8 @@
! 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 } ;
@ -12,21 +12,25 @@ C: <maybe> maybe
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>> ;

41
core/classes/union/union-tests.factor
View File

@ -107,44 +107,3 @@ M: a-union test-generic ;
[ ] [ "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

13
core/generic/generic.factor
View File

@ -3,7 +3,7 @@
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
@ -112,6 +112,9 @@ GENERIC# method-word-name 1 ( class generic -- string )
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 ;
@ -129,8 +132,14 @@ M: method crossref?
[ 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 ]

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

@ -197,7 +197,7 @@ HELP: scan-number
{ $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 ;

9
core/parser/parser.factor
View File

@ -100,13 +100,10 @@ ERROR: staging-violation word ;
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 ] }
@ -116,7 +113,7 @@ ERROR: classoid-expected word ;
} 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) ;