From ea830a4f14cdf19bfecf9692329ca46e34e4fee2 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Tue, 30 Aug 2005 22:12:21 +0000 Subject: [PATCH] various inference fixes; cond compiles now --- TODO.FACTOR.txt | 1 + library/collections/sequences-epilogue.factor | 6 +- library/errors.factor | 2 +- library/generic/math-combination.factor | 2 +- library/inference/branches.factor | 12 ++- library/inference/inference.factor | 36 ++++---- library/inference/known-words.factor | 92 ++++++++----------- library/inference/words.factor | 2 +- library/syntax/parse-numbers.factor | 2 +- library/test/compiler/ifte.factor | 30 ++++++ library/test/inference.factor | 8 +- library/tools/jedit.factor | 11 +-- 12 files changed, 111 insertions(+), 93 deletions(-) diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index cd64d841d0..54c76e0fac 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -1,6 +1,7 @@ - reader syntax for arrays, byte arrays, displaced aliens - out of memory error when printing global namespace - removing unneeded #label +- pprint trailing space regression + ui: diff --git a/library/collections/sequences-epilogue.factor b/library/collections/sequences-epilogue.factor index e4008c9005..b1c8bfe731 100644 --- a/library/collections/sequences-epilogue.factor +++ b/library/collections/sequences-epilogue.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: sequences -USING: generic kernel kernel-internals lists math strings +USING: errors generic kernel kernel-internals lists math strings vectors words ; ! Combinators @@ -234,12 +234,14 @@ IN: kernel #! Push the number of elements on the datastack. datastack length ; +: no-cond "cond fall-through" throw ; inline + : cond ( conditions -- ) #! Conditions is a sequence of quotation pairs. #! { { [ X ] [ Y ] } { [ Z ] [ T ] } } #! => X [ Y ] [ Z [ T ] [ ] ifte ] ifte #! The last condition should be a catch-all 't'. - [ first call ] find nip second call ; + [ first call ] find nip [ second call ] [ no-cond ] ifte ; : with-datastack ( stack word -- stack ) datastack >r >r set-datastack r> execute diff --git a/library/errors.factor b/library/errors.factor index 787a2c5b3b..142d431916 100644 --- a/library/errors.factor +++ b/library/errors.factor @@ -9,7 +9,7 @@ IN: errors TUPLE: no-method object generic ; -: no-method ( object generic -- ) throw ; +: no-method ( object generic -- ) throw ; inline : catchstack ( -- cs ) 6 getenv ; : set-catchstack ( cs -- ) 6 setenv ; diff --git a/library/generic/math-combination.factor b/library/generic/math-combination.factor index c447b785ab..8c3d7410af 100644 --- a/library/generic/math-combination.factor +++ b/library/generic/math-combination.factor @@ -31,7 +31,7 @@ math namespaces sequences words ; TUPLE: no-math-method left right generic ; : no-math-method ( left right generic -- ) - 3dup throw ; + 3dup throw ; inline : applicable-method ( generic class -- quot ) over "methods" word-prop hash [ ] [ diff --git a/library/inference/branches.factor b/library/inference/branches.factor index 532e7b5569..ca443c326d 100644 --- a/library/inference/branches.factor +++ b/library/inference/branches.factor @@ -74,10 +74,14 @@ namespaces parser prettyprint sequences strings vectors words ; #! meta-d, meta-r, d-in. They are set to f if #! terminate was called. [ - copy-inference - dup value-recursion recursive-state set - literal-value dup infer-quot handle-terminator - active? [ #values node, ] when + [ + base-case-continuation set + copy-inference + dup value-recursion recursive-state set + dup literal-value infer-quot + active? [ #values node, ] when + f + ] callcc1 [ terminate ] when drop ] make-hash ; : (infer-branches) ( branchlist -- list ) diff --git a/library/inference/inference.factor b/library/inference/inference.factor index a138a5b3e0..f5d7740481 100644 --- a/library/inference/inference.factor +++ b/library/inference/inference.factor @@ -7,11 +7,15 @@ namespaces parser prettyprint sequences strings vectors words ; ! This variable takes a boolean value. SYMBOL: inferring-base-case +! Called when a recursive call during base case inference is +! found. Either tries to infer another branch, or gives up. +SYMBOL: base-case-continuation + TUPLE: inference-error message rstate data-stack call-stack ; : inference-error ( msg -- ) recursive-state get meta-d get meta-r get - throw ; + throw ; inline M: inference-error error. ( error -- ) "! Inference error:" print @@ -22,10 +26,9 @@ M: inference-error error. ( error -- ) M: value literal-value ( value -- ) { "A literal value was expected where a computed value was found.\n" - "This means that an attempt was made to compile a word that\n" - "applies 'call' or 'execute' to a value that is not known\n" - "at compile time. The value might become known if the word\n" - "is marked 'inline'. See the handbook for details." + "This means the word you are inferring applies 'call' or 'execute'\n" + "to a value that is not known at compile time.\n" + "See the handbook for details." } concat inference-error ; ! Word properties that affect inference: @@ -63,6 +66,13 @@ SYMBOL: d-in d-in get length object >list meta-d get length object >list 2list ; +: no-base-case ( word -- ) + { + "The base case of a recursive word could not be inferred.\n" + "This means the word calls itself in every control flow path.\n" + "See the handbook for details." + } concat inference-error ; + : init-inference ( recursive-state -- ) init-interpreter { } clone d-in set @@ -89,25 +99,14 @@ M: wrapper apply-object wrapped apply-literal ; #! Ignore this branch's stack effect. meta-d off meta-r off d-in off ; -: terminator? ( obj -- ? ) - #! Does it throw an error? - dup word? [ "terminator" word-prop ] [ drop f ] ifte ; - -: handle-terminator ( quot -- ) - #! If the quotation throws an error, do not count its stack - #! effect. - [ terminator? ] contains? [ terminate ] when ; - : infer-quot ( quot -- ) #! Recursive calls to this word are made for nested #! quotations. [ active? [ apply-object t ] [ drop f ] ifte ] all? drop ; : infer-quot-value ( rstate quot -- ) - recursive-state get >r - swap recursive-state set - dup infer-quot handle-terminator - r> recursive-state set ; + recursive-state get >r swap recursive-state set + infer-quot r> recursive-state set ; : check-return ( -- ) #! Raise an error if word leaves values on return stack. @@ -120,6 +119,7 @@ M: wrapper apply-object wrapped apply-literal ; : with-infer ( quot -- ) [ inferring-base-case off + [ no-base-case ] base-case-continuation set f init-inference call check-return diff --git a/library/inference/known-words.factor b/library/inference/known-words.factor index da53231ff5..e57cbcaaea 100644 --- a/library/inference/known-words.factor +++ b/library/inference/known-words.factor @@ -4,25 +4,42 @@ io-internals kernel kernel-internals lists math math-internals memory parser sequences strings vectors words prettyprint ; ! Primitive combinators +\ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop + \ call [ pop-literal infer-quot-value ] "infer" set-word-prop +\ execute [ [ word ] [ ] ] "infer-effect" set-word-prop + \ execute [ pop-literal unit infer-quot-value ] "infer" set-word-prop +\ ifte [ [ object general-list general-list ] [ ] ] "infer-effect" set-word-prop + \ ifte [ 2 #drop node, pop-d pop-d swap 2vector #ifte pop-d drop infer-branches ] "infer" set-word-prop +\ cond [ [ object ] [ ] ] "infer-effect" set-word-prop + +\ cond [ + pop-literal [ 2unseq cons ] map + [ no-cond ] swap alist>quot infer-quot-value +] "infer" set-word-prop + +\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop + \ dispatch [ pop-literal nip [ ] map #dispatch pop-d drop infer-branches ] "infer" set-word-prop ! Stack manipulation +\ >r [ [ object ] [ ] ] "infer-effect" set-word-prop + \ >r [ \ >r #call 1 0 pick node-inputs @@ -31,6 +48,8 @@ memory parser sequences strings vectors words prettyprint ; node, ] "infer" set-word-prop +\ r> [ [ ] [ object ] ] "infer-effect" set-word-prop + \ r> [ \ r> #call 0 1 pick node-inputs @@ -40,57 +59,25 @@ memory parser sequences strings vectors words prettyprint ; ] "infer" set-word-prop \ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop -\ dup [ \ dup infer-shuffle ] "infer" set-word-prop -\ swap [ \ swap infer-shuffle ] "infer" set-word-prop -\ over [ \ over infer-shuffle ] "infer" set-word-prop -\ pick [ \ pick infer-shuffle ] "infer" set-word-prop +\ drop [ [ object ] [ ] ] "infer-effect" set-word-prop -! These hacks will go away soon -\ delegate [ [ object ] [ object ] ] "infer-effect" set-word-prop -\ no-method t "terminator" set-word-prop -\ no-method [ [ object word ] [ ] ] "infer-effect" set-word-prop -\ [ [ object object ] [ tuple ] ] "infer-effect" set-word-prop -\ set-no-method-generic [ [ object tuple ] [ ] ] "infer-effect" set-word-prop -\ set-no-method-object [ [ object tuple ] [ ] ] "infer-effect" set-word-prop -\ no-math-method t "terminator" set-word-prop -\ not-a-number t "terminator" set-word-prop -\ inference-error t "terminator" set-word-prop -\ throw t "terminator" set-word-prop -\ = [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop -\ hash-contained? [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop -\ gcd [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop -\ car [ [ general-list ] [ object ] ] "infer-effect" set-word-prop -\ cdr [ [ general-list ] [ object ] ] "infer-effect" set-word-prop -\ < [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop -\ <= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop -\ > [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop -\ >= [ [ real real ] [ boolean ] ] "infer-effect" set-word-prop -\ number= [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop -\ + [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ - [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ * [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ / [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ /i [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ /f [ [ number number ] [ number ] ] "infer-effect" set-word-prop -\ mod [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop -\ /mod [ [ integer integer ] [ integer integer ] ] "infer-effect" set-word-prop -\ bitand [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop -\ bitor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop -\ bitxor [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop -\ shift [ [ integer integer ] [ integer ] ] "infer-effect" set-word-prop -\ bitnot [ [ integer ] [ integer ] ] "infer-effect" set-word-prop -\ real [ [ number ] [ real ] ] "infer-effect" set-word-prop -\ imaginary [ [ number ] [ real ] ] "infer-effect" set-word-prop +\ dup [ \ dup infer-shuffle ] "infer" set-word-prop +\ dup [ [ object ] [ object object ] ] "infer-effect" set-word-prop + +\ swap [ \ swap infer-shuffle ] "infer" set-word-prop +\ swap [ [ object object ] [ object object ] ] "infer-effect" set-word-prop + +\ over [ \ over infer-shuffle ] "infer" set-word-prop +\ over [ [ object object ] [ object object object ] ] "infer-effect" set-word-prop + +\ pick [ \ pick infer-shuffle ] "infer" set-word-prop +\ pick [ [ object object object ] [ object object object object ] ] "infer-effect" set-word-prop + +! Non-standard control flow +\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop +\ throw [ terminate ] "infer" set-word-prop ! Stack effects for all primitives -\ execute [ [ word ] [ ] ] "infer-effect" set-word-prop - -\ call [ [ general-list ] [ ] ] "infer-effect" set-word-prop - -\ ifte [ [ object general-list general-list ] [ ] ] "infer-effect" set-word-prop - -\ dispatch [ [ fixnum vector ] [ ] ] "infer-effect" set-word-prop - \ cons [ [ object object ] [ cons ] ] "infer-effect" set-word-prop \ cons t "foldable" set-word-prop \ cons t "flushable" set-word-prop @@ -371,13 +358,6 @@ memory parser sequences strings vectors words prettyprint ; \ update-xt [ [ word ] [ ] ] "infer-effect" set-word-prop \ compiled? [ [ word ] [ boolean ] ] "infer-effect" set-word-prop -\ drop [ [ object ] [ ] ] "infer-effect" set-word-prop -\ dup [ [ object ] [ object object ] ] "infer-effect" set-word-prop -\ swap [ [ object object ] [ object object ] ] "infer-effect" set-word-prop -\ over [ [ object object ] [ object object object ] ] "infer-effect" set-word-prop -\ pick [ [ object object object ] [ object object object object ] ] "infer-effect" set-word-prop -\ >r [ [ object ] [ ] ] "infer-effect" set-word-prop -\ r> [ [ ] [ object ] ] "infer-effect" set-word-prop \ eq? [ [ object object ] [ boolean ] ] "infer-effect" set-word-prop \ eq? t "flushable" set-word-prop @@ -395,6 +375,7 @@ memory parser sequences strings vectors words prettyprint ; \ os-env [ [ string ] [ object ] ] "infer-effect" set-word-prop \ millis [ [ ] [ integer ] ] "infer-effect" set-word-prop \ (random-int) [ [ ] [ integer ] ] "infer-effect" set-word-prop + \ type [ [ object ] [ fixnum ] ] "infer-effect" set-word-prop \ type t "flushable" set-word-prop \ type t "foldable" set-word-prop @@ -484,7 +465,6 @@ memory parser sequences strings vectors words prettyprint ; \ alien-c-string t "flushable" set-word-prop \ set-alien-c-string [ [ string c-ptr integer ] [ ] ] "infer-effect" set-word-prop -\ throw [ [ object ] [ ] ] "infer-effect" set-word-prop \ string>memory [ [ string integer ] [ ] ] "infer-effect" set-word-prop \ memory>string [ [ integer integer ] [ string ] ] "infer-effect" set-word-prop \ alien-address [ [ alien ] [ integer ] ] "infer-effect" set-word-prop diff --git a/library/inference/words.factor b/library/inference/words.factor index 8182918f29..daa1ff052c 100644 --- a/library/inference/words.factor +++ b/library/inference/words.factor @@ -112,7 +112,7 @@ M: symbol apply-object ( word -- ) nip consume/produce ] [ inferring-base-case get [ - 2drop terminate + t base-case-continuation get call ] [ car base-case ] ifte diff --git a/library/syntax/parse-numbers.factor b/library/syntax/parse-numbers.factor index 87d0ef3123..91d19cf68b 100644 --- a/library/syntax/parse-numbers.factor +++ b/library/syntax/parse-numbers.factor @@ -5,7 +5,7 @@ USING: errors generic kernel math namespaces sequences strings ; ! Number parsing -: not-a-number "Not a number" throw ; +: not-a-number "Not a number" throw ; inline GENERIC: digit> ( ch -- n ) M: digit digit> CHAR: 0 - ; diff --git a/library/test/compiler/ifte.factor b/library/test/compiler/ifte.factor index 06914b6f38..59624a1513 100644 --- a/library/test/compiler/ifte.factor +++ b/library/test/compiler/ifte.factor @@ -1,4 +1,5 @@ IN: temporary +USING: alien strings ; USE: compiler USE: test USE: math @@ -94,3 +95,32 @@ DEFER: countdown-b [ 3 ] [ f dummy-unless-3 ] unit-test [ 4 ] [ 4 dummy-unless-3 ] unit-test + +[ "even" ] [ + [ + 2 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond + ] compile-1 +] unit-test + +[ "odd" ] [ + [ + 3 { + { [ dup 2 mod 0 = ] [ drop "even" ] } + { [ dup 2 mod 1 = ] [ drop "odd" ] } + } cond + ] compile-1 +] unit-test + +[ "neither" ] [ + [ + 3 { + { [ dup string? ] [ drop "string" ] } + { [ dup float? ] [ drop "float" ] } + { [ dup alien? ] [ drop "alien" ] } + { [ t ] [ drop "neither" ] } + } cond + ] compile-1 +] unit-test diff --git a/library/test/inference.factor b/library/test/inference.factor index ae2928cdc3..1573a6ea01 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -155,9 +155,11 @@ DEFER: agent [ [ [ ] [ object object ] ] ] [ [ [ drop ] 0 agent ] infer ] unit-test -! : no-base-case dup [ no-base-case ] [ no-base-case ] ifte ; -! -! [ [ no-base-case ] infer simple-effect ] unit-test-fails +: no-base-case-1 dup [ no-base-case-1 ] [ no-base-case-1 ] ifte ; +[ [ no-base-case-1 ] infer ] unit-test-fails + +: no-base-case-2 no-base-case-2 ; +[ [ no-base-case-2 ] infer ] unit-test-fails [ { 2 1 } ] [ [ 2vector ] infer simple-effect ] unit-test [ { 3 1 } ] [ [ 3vector ] infer simple-effect ] unit-test diff --git a/library/tools/jedit.factor b/library/tools/jedit.factor index ead715d2d4..033d95b297 100644 --- a/library/tools/jedit.factor +++ b/library/tools/jedit.factor @@ -76,12 +76,11 @@ sequences strings unparser vectors words ; #! required word info. dup [ [ - "vocabulary" - "name" - "stack-effect" - ] [ - dupd word-prop - ] map >r definer r> cons + dup definer , + dup word-vocabulary , + dup word-name , + "stack-effect" word-prop , + ] [ ] make ] when ; : completions ( str pred -- list | pred: str word -- ? )