From 2b87eaa1b57da4ba99b3b2d602cb2a1c97fad9a7 Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sun, 27 Nov 2011 16:21:20 -0800 Subject: [PATCH] generalizations: Refactor stack-checker so that smart combinators can be used with curry and compose. --- basis/combinators/smart/smart-tests.factor | 2 + basis/combinators/smart/smart.factor | 83 +++++++++++++------ .../call-effect/call-effect.factor | 11 +-- basis/generalizations/generalizations.factor | 31 +++---- basis/locals/locals-tests.factor | 8 +- .../known-words/known-words.factor | 2 + .../stack-checker/stack-checker-tests.factor | 10 +++ basis/stack-checker/stack-checker.factor | 4 - core/effects/effects-tests.factor | 5 ++ core/effects/effects.factor | 5 ++ 10 files changed, 110 insertions(+), 51 deletions(-) diff --git a/basis/combinators/smart/smart-tests.factor b/basis/combinators/smart/smart-tests.factor index 8933c4bb39..a322b7bd0b 100644 --- a/basis/combinators/smart/smart-tests.factor +++ b/basis/combinators/smart/smart-tests.factor @@ -76,3 +76,5 @@ IN: combinators.smart.tests [ -1 ] [ 1 2 [ + odd? ] [ - ] smart-when* ] unit-test [ ] [ 2 2 [ + odd? ] [ ] smart-unless* ] unit-test + +! [ [ ] [ call ] curry output>array ] infer diff --git a/basis/combinators/smart/smart.factor b/basis/combinators/smart/smart.factor index a350d0a72b..efdb1b9e05 100644 --- a/basis/combinators/smart/smart.factor +++ b/basis/combinators/smart/smart.factor @@ -1,41 +1,74 @@ -! Copyright (C) 2009 Doug Coleman. +! Copyright (C) 2009, 2011 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors fry generalizations sequences.generalizations -kernel macros math.order stack-checker math sequences ; +USING: accessors arrays effects fry generalizations kernel +macros math math.order sequences sequences.generalizations +stack-checker stack-checker.backend stack-checker.errors +stack-checker.values stack-checker.visitor words ; IN: combinators.smart -MACRO: drop-outputs ( quot -- quot' ) - dup outputs '[ @ _ ndrop ] ; +GENERIC: infer-known* ( known -- effect ) -MACRO: keep-inputs ( quot -- quot' ) - dup inputs '[ _ _ nkeep ] ; +: infer-known ( value -- effect ) + known dup (literal-value?) [ + (literal) [ infer-literal-quot ] with-infer drop + ] [ infer-known* ] if ; -MACRO: output>sequence ( quot exemplar -- newquot ) - [ dup outputs ] dip - '[ @ _ _ nsequence ] ; +: inputs/outputs ( quot -- in out ) + infer [ in>> ] [ out>> ] bi [ length ] bi@ ; -MACRO: output>array ( quot -- newquot ) - '[ _ { } output>sequence ] ; +: inputs ( quot -- n ) inputs/outputs drop ; inline -MACRO: input> ] [ out>> ] bi [ length apply-object ] bi@ +] "special" set-word-prop + +M: curried infer-known* + quot>> infer-known curry-effect ; + +M: composed infer-known* + [ quot1>> ] [ quot2>> ] bi + [ infer-known ] bi@ compose-effects ; + +M: declared-effect infer-known* + known>> infer-known* ; + +M: input-parameter infer-known* \ inputs/outputs unknown-macro-input ; + +M: object infer-known* \ inputs/outputs bad-macro-input ; + +: drop-outputs ( quot -- ) + [ call ] [ outputs ndrop ] bi ; inline + +: keep-inputs ( quot -- ) + [ ] [ inputs ] bi nkeep ; inline + +: output>sequence ( quot exemplar -- ) + [ [ call ] [ outputs ] bi ] dip nsequence ; inline + +: output>array ( quot -- ) + { } output>sequence ; inline + +: input> length ] [ out>> length ] [ terminated?>> ] tri - pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if - [ [ "x" ] bi@ ] dip ; +M: effect curry-effect* curry-effect ; M: curry cached-effect - quot>> cached-effect curry-effect ; + quot>> cached-effect curry-effect* ; : compose-effects* ( effect1 effect2 -- effect' ) { diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor index 2c6a9f1a21..99d57eded8 100644 --- a/basis/generalizations/generalizations.factor +++ b/basis/generalizations/generalizations.factor @@ -10,6 +10,9 @@ IN: generalizations ALIAS: n*quot (n*quot) +MACRO: quot*n ( n -- ) + [ call ] '[ _ cleave ] ; + : repeat ( n obj quot -- ) swapd times ; inline >> @@ -23,8 +26,8 @@ MACRO: npick ( n -- ) MACRO: nover ( n -- ) dup 1 + '[ _ npick ] n*quot ; -MACRO: ndup ( n -- ) - dup '[ _ npick ] n*quot ; +: ndup ( n -- ) + [ '[ _ npick ] ] keep quot*n ; inline MACRO: dupn ( n -- ) [ [ drop ] ] @@ -36,23 +39,23 @@ MACRO: nrot ( n -- ) MACRO: -nrot ( n -- ) 1 - [ ] [ '[ swap _ dip ] ] repeat ; -MACRO: ndrop ( n -- ) - [ drop ] n*quot ; +: ndrop ( n -- ) + [ drop ] swap quot*n ; inline -MACRO: nnip ( n -- ) - '[ [ _ ndrop ] dip ] ; +: nnip ( n -- ) + '[ _ ndrop ] dip ; inline -MACRO: ndip ( n -- ) - [ [ dip ] curry ] n*quot [ call ] compose ; +: ndip ( n -- ) + [ [ dip ] curry ] swap quot*n call ; inline -MACRO: nkeep ( n -- ) - dup '[ [ _ ndup ] dip _ ndip ] ; +: nkeep ( n -- ) + dup '[ [ _ ndup ] dip _ ndip ] call ; inline -MACRO: ncurry ( n -- ) - [ curry ] n*quot ; +: ncurry ( n -- ) + [ curry ] swap quot*n ; inline -MACRO: nwith ( n -- ) - [ with ] n*quot ; +: nwith ( n -- ) + [ with ] swap quot*n ; inline MACRO: nbi ( n -- ) '[ [ _ nkeep ] dip call ] ; diff --git a/basis/locals/locals-tests.factor b/basis/locals/locals-tests.factor index b340d5ebac..a39bc658ea 100644 --- a/basis/locals/locals-tests.factor +++ b/basis/locals/locals-tests.factor @@ -2,7 +2,8 @@ USING: locals math sequences tools.test hashtables words kernel namespaces arrays strings prettyprint io.streams.string parser accessors generic eval combinators combinators.short-circuit combinators.short-circuit.smart math.order math.functions -definitions compiler.units fry lexer words.symbol see multiline ; +definitions compiler.units fry lexer words.symbol see multiline +combinators.smart ; IN: locals.tests :: foo ( a b -- a a ) a a ; @@ -491,3 +492,8 @@ M: integer ed's-bug neg ; ! multiple bind [ 3 1 2 ] [ [let 1 2 3 :> ( a b c ) c a b ] ] unit-test + +! Test smart combinators and locals interaction +:: smart-combinator-locals ( a b c -- seq ) [ a b c ] output>array ; + +[ { 1 2 3 } ] [ 1 2 3 smart-combinator-locals ] unit-test diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index 43885afc3f..99a5e7ace8 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -40,6 +40,7 @@ IN: stack-checker.known-words : infer-shuffle-word ( word -- ) "shuffle" word-prop infer-shuffle ; +! This is a hack for combinators combinators.short-circuit.smart. : infer-local-reader ( word -- ) ( -- value ) apply-word/effect ; @@ -89,6 +90,7 @@ IN: stack-checker.known-words \ declare [ infer-declare ] "special" set-word-prop +! Call GENERIC: infer-call* ( value known -- ) : (infer-call) ( value -- ) dup known infer-call* ; diff --git a/basis/stack-checker/stack-checker-tests.factor b/basis/stack-checker/stack-checker-tests.factor index d56e702517..a050a259f6 100644 --- a/basis/stack-checker/stack-checker-tests.factor +++ b/basis/stack-checker/stack-checker-tests.factor @@ -529,3 +529,13 @@ USING: alien.c-types alien ; [ [ drop drop ] [ f f f ] poly-input-output ] must-infer [ [ drop drop drop ] [ f f ] poly-input-output ] must-infer +! Check that 'inputs' and 'outputs' work at compile-time + +: inputs-test0 ( -- n ) + [ 5 + ] inputs ; + +: inputs-test1 ( x -- n ) + [ + ] curry inputs ; + +[ 1 ] [ inputs-test0 ] unit-test +[ 1 ] [ 10 inputs-test1 ] unit-test diff --git a/basis/stack-checker/stack-checker.factor b/basis/stack-checker/stack-checker.factor index beb5026a2b..9c016f037a 100644 --- a/basis/stack-checker/stack-checker.factor +++ b/basis/stack-checker/stack-checker.factor @@ -16,7 +16,3 @@ M: callable infer ( quot -- effect ) : infer. ( quot -- ) #! Safe to call from inference transforms. infer effect>string print ; - -: inputs ( quot -- n ) infer in>> length ; - -: outputs ( quot -- n ) infer out>> length ; diff --git a/core/effects/effects-tests.factor b/core/effects/effects-tests.factor index 5f4a299ac8..890bbb7e4e 100644 --- a/core/effects/effects-tests.factor +++ b/core/effects/effects-tests.factor @@ -49,3 +49,8 @@ IN: effects.tests [ "( ..a: integer b c -- d )" eval( -- effect ) ] [ error>> row-variable-can't-have-type? ] must-fail-with + +! test curry-effect +[ ( -- x ) ] [ ( c -- d ) curry-effect ] unit-test +[ ( -- x x ) ] [ ( -- d ) curry-effect ] unit-test +[ ( x -- ) ] [ ( a b -- ) curry-effect ] unit-test diff --git a/core/effects/effects.factor b/core/effects/effects.factor index ffc59e21a1..785a5d21f2 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -120,3 +120,8 @@ M: effect clone [ [ "x" ] bi@ ] dip ] if ; inline + +: curry-effect ( effect -- effect' ) + [ in>> length ] [ out>> length ] [ terminated?>> ] tri + pick 0 = [ [ 1 + ] dip ] [ [ 1 - ] 2dip ] if + [ [ "x" ] bi@ ] dip ;