- reader syntax for arrays, byte arrays, displaced aliens\r
- out of memory error when printing global namespace\r
- removing unneeded #label\r
+- pprint trailing space regression\r
\r
+ ui:\r
\r
! 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
#! 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
TUPLE: no-method object generic ;
-: no-method ( object generic -- ) <no-method> throw ;
+: no-method ( object generic -- ) <no-method> throw ; inline
: catchstack ( -- cs ) 6 getenv ;
: set-catchstack ( cs -- ) 6 setenv ;
TUPLE: no-math-method left right generic ;
: no-math-method ( left right generic -- )
- 3dup <no-math-method> throw ;
+ 3dup <no-math-method> throw ; inline
: applicable-method ( generic class -- quot )
over "methods" word-prop hash [ ] [
#! 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 )
! 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
- <inference-error> throw ;
+ <inference-error> throw ; inline
M: inference-error error. ( error -- )
"! Inference error:" print
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:
d-in get length object <repeated> >list
meta-d get length object <repeated> >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
#! 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.
: with-infer ( quot -- )
[
inferring-base-case off
+ [ no-base-case ] base-case-continuation set
f init-inference
call
check-return
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 [ <literal> ] 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
node,
] "infer" set-word-prop
+\ r> [ [ ] [ object ] ] "infer-effect" set-word-prop
+
\ r> [
\ r> #call
0 1 pick node-inputs
] "infer" set-word-prop
\ drop [ 1 #drop node, pop-d drop ] "infer" set-word-prop
+\ drop [ [ object ] [ ] ] "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
-! 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
-\ <no-method> [ [ 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
+! 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
\ 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
\ 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
\ 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
nip consume/produce
] [
inferring-base-case get [
- 2drop terminate
+ t base-case-continuation get call
] [
car base-case
] ifte
! 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 - ;
IN: temporary
+USING: alien strings ;
USE: compiler
USE: test
USE: math
[ 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
[ [ [ ] [ 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
#! 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 -- ? )