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

hide typed's private parts

db4
Joe Groff 2009-10-16 22:03:14 -05:00
parent fb79aec97e
commit 551b1aca8f
1 changed files with 10 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
extra/typed/typed.factor
View File

@ -10,6 +10,12 @@ ERROR: type-mismatch-error word expected-types ;
ERROR: input-mismatch-error < type-mismatch-error ; ERROR: input-mismatch-error < type-mismatch-error ;
ERROR: output-mismatch-error < type-mismatch-error ; ERROR: output-mismatch-error < type-mismatch-error ;
PREDICATE: typed-gensym < word "typed-gensym" word-prop ;
PREDICATE: typed-standard-word < word "typed-word" word-prop ;
PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
<PRIVATE
: unboxable-tuple-class? ( type -- ? ) : unboxable-tuple-class? ( type -- ? )
{ {
[ all-slots empty? not ] [ all-slots empty? not ]
@ -93,9 +99,7 @@ MACRO: (typed) ( word def effect -- quot )
dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
] 2bi ; ] 2bi ;
PREDICATE: typed-gensym < word "typed-gensym" word-prop ; : <typed-gensym> ( parent-word -- word )
: typed-gensym ( parent-word -- word )
[ name>> "( typed " " )" surround f <word> dup ] [ name>> "( typed " " )" surround f <word> dup ]
[ "typed-gensym" set-word-prop ] bi ; [ "typed-gensym" set-word-prop ] bi ;
@ -103,16 +107,13 @@ PREDICATE: typed-gensym < word "typed-gensym" word-prop ;
[ effect-in-types unboxed-types [ "in" swap 2array ] map ] [ effect-in-types unboxed-types [ "in" swap 2array ] map ]
[ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ; [ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ;
PREDICATE: typed-standard-word < word "typed-word" word-prop ;
PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
M: typed-gensym stack-effect M: typed-gensym stack-effect
call-next-method unboxed-effect ; call-next-method unboxed-effect ;
M: typed-gensym crossref? M: typed-gensym crossref?
"typed-gensym" word-prop crossref? ; "typed-gensym" word-prop crossref? ;
: define-typed-gensym ( word def effect -- gensym ) : define-typed-gensym ( word def effect -- gensym )
[ 2drop typed-gensym dup ] [ 2drop <typed-gensym> dup ]
[ [ (typed) ] 3curry ] [ [ (typed) ] 3curry ]
[ 2nip ] 3tri define-declared ; [ 2nip ] 3tri define-declared ;
@ -136,6 +137,8 @@ MACRO: typed ( quot word effect -- quot' )
[ effect-out-types typed-stack-effect? ] [ effect-out-types typed-stack-effect? ]
} 1|| [ (typed-def) ] [ drop nip ] if ; } 1|| [ (typed-def) ] [ drop nip ] if ;
PRIVATE>
: define-typed ( word def effect -- ) : define-typed ( word def effect -- )
[ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ] [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
[ drop "typed-def" set-word-prop ] [ drop "typed-def" set-word-prop ]