effects: Add support for :type as standalone, unnamed types. ( :float -- ) pprints as ( _: float -- ), and ( :( a -- b ) -- ) works, etc. :union{ foo bar } pprints as object but could be improved if the effects parser uses the prettyprinter somehow.

Move ?execute-parsing to parser to avoid circularity.
locals-and-roots
Doug Coleman 2016-05-12 16:24:04 -07:00
parent 7d66c331db
commit 3fa9ad91f6
4 changed files with 25 additions and 9 deletions

View File

@ -1,5 +1,5 @@
USING: accessors effects effects.parser eval kernel prettyprint
sequences tools.test ;
sequences tools.test math ;
IN: effects.tests
{ t } [ { "a" } { "a" } <effect> { "a" "b" } { "a" "b" } <effect> effect<= ] unit-test
@ -54,3 +54,7 @@ IN: effects.tests
{ ( -- x ) } [ ( c -- d ) curry-effect ] unit-test
{ ( -- x x ) } [ ( -- d ) curry-effect ] unit-test
{ ( x -- ) } [ ( a b -- ) curry-effect ] unit-test
! test unnamed types
{ ( _: fixnum -- _: float ) } [ ( :fixnum -- :float ) ] unit-test
{ ( _: union{ fixnum bignum } -- ) } [ ( :union{ fixnum bignum } -- ) ] unit-test

View File

@ -1,8 +1,8 @@
! Copyright (C) 2008, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays combinators continuations effects kernel
lexer make namespaces parser sequences sets splitting
vocabs.parser words ;
USING: accessors arrays combinators continuations effects
kernel lexer make namespaces parser sequences sets
splitting vocabs.parser words ;
IN: effects.parser
DEFER: parse-effect
@ -19,6 +19,7 @@ SYMBOL: effect-var
: effect-opener? ( token -- token ? ) dup { f "(" "--" } member? ; inline
: effect-closer? ( token -- token ? ) dup ")" sequence= ; inline
: row-variable? ( token -- token' ? ) ".." ?head ; inline
: standalone-type? ( token -- token' ? ) ":" ?head ; inline
: parse-effect-var ( first? var name -- var )
nip
@ -27,6 +28,14 @@ SYMBOL: effect-var
: parse-effect-value ( token -- value )
":" ?tail [ scan-object 2array ] when ;
ERROR: bad-standalone-effect obj ;
: parse-standalone-type ( obj -- var )
parse-datum
dup parsing-word? [
?execute-parsing dup length 1 =
[ first ] [ bad-standalone-effect ] if
] when "_" swap 2array ;
PRIVATE>
: parse-effect-token ( first? var end -- var more? )
@ -35,7 +44,10 @@ PRIVATE>
{ [ effect-opener? ] [ bad-effect ] }
{ [ effect-closer? ] [ stack-effect-omits-dashes ] }
{ [ row-variable? ] [ parse-effect-var t ] }
[ [ drop ] 2dip parse-effect-value , t ]
[
[ drop ] 2dip standalone-type?
[ parse-standalone-type ] [ parse-effect-value ] if , t
]
} cond ;
: parse-effect-tokens ( end -- var tokens )

View File

@ -40,10 +40,6 @@ ERROR: bad-method-effect ;
: check-method-effect ( effect -- )
last-word generic-effect method-effect= [ bad-method-effect ] unless ;
: ?execute-parsing ( word/number -- seq )
dup parsing-word?
[ V{ } clone swap execute-parsing ] [ 1array ] if ;
: parse-method-definition ( -- quot )
scan-datum {
{ \ ( [ ")" parse-effect check-method-effect parse-definition ] }

View File

@ -98,6 +98,10 @@ ERROR: staging-violation word ;
dup changed-definitions get in? [ staging-violation ] when
(execute-parsing) ;
: ?execute-parsing ( word/number -- seq )
dup parsing-word?
[ V{ } clone swap execute-parsing ] [ 1array ] if ;
: scan-object ( -- object )
scan-datum
dup parsing-word? [