diff --git a/library/alien/c-types.factor b/library/alien/c-types.factor index 9c7a5316c0..4798b89a04 100644 --- a/library/alien/c-types.factor +++ b/library/alien/c-types.factor @@ -26,13 +26,11 @@ SYMBOL: c-types c-type [ "width" get ] bind ; : define-c-type ( quot name -- ) - >r swap extend r> c-types get set-hash ; inline + >r swap extend r> c-types get set-hash ; -: ( size -- byte-array ) - cell / ceiling ; +: ( size -- c-ptr ) cell / ceiling ; -: ( n size -- byte-array ) - * cell / ceiling ; +: ( n size -- c-ptr ) * ; : define-pointer ( type -- ) "void*" c-type swap "*" append c-types get set-hash ; diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor index f64a770a98..7e152638ae 100644 --- a/library/alien/compiler.factor +++ b/library/alien/compiler.factor @@ -156,11 +156,6 @@ M: compound (uncrossref) dup word-def \ alien-invoke swap member? [ drop ] [ - dup f "infer-effect" set-word-prop - dup f "base-case" set-word-prop - dup f "no-effect" set-word-prop - ! dup f "inline" set-word-prop - ! dup f "foldable" set-word-prop - ! dup f "flushable" set-word-prop - decompile + dup { "infer-effect" "base-case" "no-effect" } + reset-props decompile ] ifte ; diff --git a/library/generic/slots.factor b/library/generic/slots.factor index 22201d6c10..2ae64e7faa 100644 --- a/library/generic/slots.factor +++ b/library/generic/slots.factor @@ -29,8 +29,11 @@ sequences strings vectors words ; : define-slot ( class slot reader writer -- ) >r >r 2dup r> define-reader r> define-writer ; +: ?create ( { name vocab }/f -- word ) + dup [ 2unseq create ] when ; + : intern-slots ( spec -- spec ) - [ 3unseq swap 2unseq create swap 2unseq create 3vector ] map ; + [ 3unseq swap ?create swap ?create 3vector ] map ; : define-slots ( class spec -- ) #! Define a collection of slot readers and writers for the diff --git a/library/syntax/prettyprint.factor b/library/syntax/prettyprint.factor index eb90cd087d..49aefedf60 100644 --- a/library/syntax/prettyprint.factor +++ b/library/syntax/prettyprint.factor @@ -181,7 +181,9 @@ GENERIC: pprint* ( obj -- ) : word-style ( word -- style ) dup word-vocabulary vocab-style swap presented swons add ; -: pprint-word ( obj -- ) dup word-name swap word-style text ; +: pprint-word ( obj -- ) + dup word-name [ "( unnamed )" ] unless* + swap word-style text ; M: object pprint* ( obj -- ) "( unprintable object: " swap class word-name " )" append3 diff --git a/library/test/generic.factor b/library/test/generic.factor index 0635d1ca31..bd6a95f5c7 100644 --- a/library/test/generic.factor +++ b/library/test/generic.factor @@ -1,6 +1,4 @@ IN: temporary -USING: parser prettyprint sequences io strings ; - USE: hashtables USE: namespaces USE: generic @@ -11,6 +9,11 @@ USE: words USE: lists USE: vectors USE: alien +USE: sequences +USE: prettyprint +USE: io +USE: parser +USE: strings GENERIC: class-of diff --git a/library/test/inference.factor b/library/test/inference.factor index a2d46c7ffc..48c10f511f 100644 --- a/library/test/inference.factor +++ b/library/test/inference.factor @@ -2,39 +2,41 @@ IN: temporary USING: generic inference kernel lists math math-internals namespaces parser sequences test vectors ; -[ [ 0 2 ] ] [ [ 2 "Hello" ] infer ] unit-test -[ [ 1 2 ] ] [ [ dup ] infer ] unit-test +: simple-effect 2unseq >r length r> length 2vector ; -[ [ 1 2 ] ] [ [ [ dup ] call ] infer ] unit-test -[ [ call ] infer ] unit-test-fails +[ { 0 2 } ] [ [ 2 "Hello" ] infer simple-effect ] unit-test +[ { 1 2 } ] [ [ dup ] infer simple-effect ] unit-test -[ [ 2 4 ] ] [ [ 2dup ] infer ] unit-test +[ { 1 2 } ] [ [ [ dup ] call ] infer simple-effect ] unit-test +[ [ call ] infer simple-effect ] unit-test-fails -[ [ 1 0 ] ] [ [ [ ] [ ] ifte ] infer ] unit-test -[ [ ifte ] infer ] unit-test-fails -[ [ [ ] ifte ] infer ] unit-test-fails -[ [ [ 2 ] [ ] ifte ] infer ] unit-test-fails -[ [ 4 3 ] ] [ [ [ rot ] [ -rot ] ifte ] infer ] unit-test +[ { 2 4 } ] [ [ 2dup ] infer simple-effect ] unit-test -[ [ 4 3 ] ] [ +[ { 1 0 } ] [ [ [ ] [ ] ifte ] infer simple-effect ] unit-test +[ [ ifte ] infer simple-effect ] unit-test-fails +[ [ [ ] ifte ] infer simple-effect ] unit-test-fails +[ [ [ 2 ] [ ] ifte ] infer simple-effect ] unit-test-fails +[ { 4 3 } ] [ [ [ rot ] [ -rot ] ifte ] infer simple-effect ] unit-test + +[ { 4 3 } ] [ [ [ [ swap 3 ] [ nip 5 5 ] ifte ] [ -rot ] ifte - ] infer + ] infer simple-effect ] unit-test -[ [ 1 1 ] ] [ [ dup [ ] when ] infer ] unit-test -[ [ 1 1 ] ] [ [ dup [ dup fixnum* ] when ] infer ] unit-test -[ [ 2 1 ] ] [ [ [ dup fixnum* ] when ] infer ] unit-test +[ { 1 1 } ] [ [ dup [ ] when ] infer simple-effect ] unit-test +[ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer simple-effect ] unit-test -[ [ 1 0 ] ] [ [ [ drop ] when* ] infer ] unit-test -[ [ 1 1 ] ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test +[ { 1 0 } ] [ [ [ drop ] when* ] infer simple-effect ] unit-test +[ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer simple-effect ] unit-test -[ [ 0 1 ] ] [ - [ [ 2 2 fixnum+ ] dup [ ] when call ] infer +[ { 0 1 } ] [ + [ [ 2 2 fixnum+ ] dup [ ] when call ] infer simple-effect ] unit-test [ @@ -46,27 +48,27 @@ namespaces parser sequences test vectors ; : simple-recursion-1 dup [ simple-recursion-1 ] [ ] ifte ; -[ [ 1 1 ] ] [ [ simple-recursion-1 ] infer ] unit-test +[ { 1 1 } ] [ [ simple-recursion-1 ] infer simple-effect ] unit-test : simple-recursion-2 dup [ ] [ simple-recursion-2 ] ifte ; -[ [ 1 1 ] ] [ [ simple-recursion-2 ] infer ] unit-test +[ { 1 1 } ] [ [ simple-recursion-2 ] infer simple-effect ] unit-test : bad-recursion-2 dup [ uncons bad-recursion-2 ] [ ] ifte ; -[ [ bad-recursion-2 ] infer ] unit-test-fails +[ [ bad-recursion-2 ] infer simple-effect ] unit-test-fails ! Not sure how to fix this one : funny-recursion dup [ funny-recursion 1 ] [ 2 ] ifte drop ; -[ [ 1 1 ] ] [ [ funny-recursion ] infer ] unit-test +[ { 1 1 } ] [ [ funny-recursion ] infer simple-effect ] unit-test ! Simple combinators -[ [ 1 2 ] ] [ [ [ car ] keep cdr ] infer ] unit-test +[ { 1 2 } ] [ [ [ car ] keep cdr ] infer simple-effect ] unit-test ! Mutual recursion DEFER: foe @@ -89,8 +91,8 @@ DEFER: foe 2drop f ] ifte ; -[ [ 2 1 ] ] [ [ fie ] infer ] unit-test -[ [ 2 1 ] ] [ [ foe ] infer ] unit-test +[ { 2 1 } ] [ [ fie ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ foe ] infer simple-effect ] unit-test : nested-when ( -- ) t [ @@ -99,7 +101,7 @@ DEFER: foe ] when ] when ; -[ [ 0 0 ] ] [ [ nested-when ] infer ] unit-test +[ { 0 0 } ] [ [ nested-when ] infer simple-effect ] unit-test : nested-when* ( -- ) [ @@ -108,11 +110,11 @@ DEFER: foe ] when* ] when* ; -[ [ 1 0 ] ] [ [ nested-when* ] infer ] unit-test +[ { 1 0 } ] [ [ nested-when* ] infer simple-effect ] unit-test SYMBOL: sym-test -[ [ 0 1 ] ] [ [ sym-test ] infer ] unit-test +[ { 0 1 } ] [ [ sym-test ] infer simple-effect ] unit-test : terminator-branch dup [ @@ -121,7 +123,7 @@ SYMBOL: sym-test not-a-number ] ifte ; -[ [ 1 1 ] ] [ [ terminator-branch ] infer ] unit-test +[ { 1 1 } ] [ [ terminator-branch ] infer simple-effect ] unit-test : recursive-terminator dup [ @@ -130,7 +132,7 @@ SYMBOL: sym-test not-a-number ] ifte ; -[ [ 1 1 ] ] [ [ recursive-terminator ] infer ] unit-test +[ { 1 1 } ] [ [ recursive-terminator ] infer simple-effect ] unit-test GENERIC: potential-hang M: fixnum potential-hang dup [ potential-hang ] when ; @@ -143,90 +145,90 @@ M: funny-cons iterate funny-cons-cdr iterate ; M: f iterate drop ; M: real iterate drop ; -[ [ 1 0 ] ] [ [ iterate ] infer ] unit-test +[ { 1 0 } ] [ [ iterate ] infer simple-effect ] unit-test -[ [ callstack ] infer ] unit-test-fails +[ [ callstack ] infer simple-effect ] unit-test-fails ! : no-base-case dup [ no-base-case ] [ no-base-case ] ifte ; ! -! [ [ no-base-case ] infer ] unit-test-fails +! [ [ no-base-case ] infer simple-effect ] unit-test-fails -[ [ 2 1 ] ] [ [ 2vector ] infer ] unit-test -[ [ 3 1 ] ] [ [ 3vector ] infer ] unit-test -[ [ 2 1 ] ] [ [ swons ] infer ] unit-test -[ [ 1 2 ] ] [ [ uncons ] infer ] unit-test -[ [ 1 1 ] ] [ [ unit ] infer ] unit-test -[ [ 1 2 ] ] [ [ unswons ] infer ] unit-test -[ [ 1 1 ] ] [ [ last ] infer ] unit-test -[ [ 1 1 ] ] [ [ list? ] infer ] unit-test +[ { 2 1 } ] [ [ 2vector ] infer simple-effect ] unit-test +[ { 3 1 } ] [ [ 3vector ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ swons ] infer simple-effect ] unit-test +[ { 1 2 } ] [ [ uncons ] infer simple-effect ] unit-test +[ { 1 1 } ] [ [ unit ] infer simple-effect ] unit-test +[ { 1 2 } ] [ [ unswons ] infer simple-effect ] unit-test +[ { 1 1 } ] [ [ last ] infer simple-effect ] unit-test +[ { 1 1 } ] [ [ list? ] infer simple-effect ] unit-test -[ [ 1 0 ] ] [ [ >n ] infer ] unit-test -[ [ 0 1 ] ] [ [ n> ] infer ] unit-test +[ { 1 0 } ] [ [ >n ] infer simple-effect ] unit-test +[ { 0 1 } ] [ [ n> ] infer simple-effect ] unit-test -[ [ 2 1 ] ] [ [ bitor ] infer ] unit-test -[ [ 2 1 ] ] [ [ bitand ] infer ] unit-test -[ [ 2 1 ] ] [ [ bitxor ] infer ] unit-test -[ [ 2 1 ] ] [ [ mod ] infer ] unit-test -[ [ 2 1 ] ] [ [ /i ] infer ] unit-test -[ [ 2 1 ] ] [ [ /f ] infer ] unit-test -[ [ 2 2 ] ] [ [ /mod ] infer ] unit-test -[ [ 2 1 ] ] [ [ + ] infer ] unit-test -[ [ 2 1 ] ] [ [ - ] infer ] unit-test -[ [ 2 1 ] ] [ [ * ] infer ] unit-test -[ [ 2 1 ] ] [ [ / ] infer ] unit-test -[ [ 2 1 ] ] [ [ < ] infer ] unit-test -[ [ 2 1 ] ] [ [ <= ] infer ] unit-test -[ [ 2 1 ] ] [ [ > ] infer ] unit-test -[ [ 2 1 ] ] [ [ >= ] infer ] unit-test -[ [ 2 1 ] ] [ [ number= ] infer ] unit-test +[ { 2 1 } ] [ [ bitor ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ bitand ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ bitxor ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ mod ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ /i ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ /f ] infer simple-effect ] unit-test +[ { 2 2 } ] [ [ /mod ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ + ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ - ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ * ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ / ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ < ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ <= ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ > ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ >= ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ number= ] infer simple-effect ] unit-test -[ [ 1 1 ] ] [ [ string>number ] infer ] unit-test -[ [ 2 1 ] ] [ [ = ] infer ] unit-test -[ [ 1 1 ] ] [ [ get ] infer ] unit-test +[ { 1 1 } ] [ [ string>number ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ = ] infer simple-effect ] unit-test +[ { 1 1 } ] [ [ get ] infer simple-effect ] unit-test -[ [ 2 0 ] ] [ [ push ] infer ] unit-test -[ [ 2 0 ] ] [ [ set-length ] infer ] unit-test -[ [ 2 1 ] ] [ [ append ] infer ] unit-test -[ [ 1 1 ] ] [ [ peek ] infer ] unit-test +[ { 2 0 } ] [ [ push ] infer simple-effect ] unit-test +[ { 2 0 } ] [ [ set-length ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ append ] infer simple-effect ] unit-test +[ { 1 1 } ] [ [ peek ] infer simple-effect ] unit-test -[ [ 1 1 ] ] [ [ length ] infer ] unit-test -[ [ 1 1 ] ] [ [ reverse ] infer ] unit-test -[ [ 2 1 ] ] [ [ member? ] infer ] unit-test -[ [ 2 1 ] ] [ [ remove ] infer ] unit-test -[ [ 1 1 ] ] [ [ prune ] infer ] unit-test +[ { 1 1 } ] [ [ length ] infer simple-effect ] unit-test +[ { 1 1 } ] [ [ reverse ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ member? ] infer simple-effect ] unit-test +[ { 2 1 } ] [ [ remove ] infer simple-effect ] unit-test +[ { 1 1 } ] [ [ prune ] infer simple-effect ] unit-test : bad-code "1234" car ; -[ [ 0 1 ] ] [ [ bad-code ] infer ] unit-test +[ { 0 1 } ] [ [ bad-code ] infer simple-effect ] unit-test ! Type inference -! [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test -! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test -! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test -! [ [ [ object ] [ boolean ] ] ] [ [ dup [ drop t ] unless ] infer ] unit-test -! [ [ [ general-list ] [ cons ] ] ] [ [ uncons cons ] infer ] unit-test +! [ [ [ object ] [ ] ] ] [ [ drop ] infer simple-effect ] unit-test +! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer simple-effect ] unit-test +! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer simple-effect ] unit-test +! [ [ [ object ] [ boolean ] ] ] [ [ dup [ drop t ] unless ] infer simple-effect ] unit-test +! [ [ [ general-list ] [ cons ] ] ] [ [ uncons cons ] infer simple-effect ] unit-test -! [ [ 5 car ] infer ] unit-test-fails +! [ [ 5 car ] infer simple-effect ] unit-test-fails -! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer ] unit-test -! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test -! [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test +! [ [ [ number ] [ number ] ] ] [ [ dup + ] infer simple-effect ] unit-test +! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer simple-effect ] unit-test +! [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer simple-effect ] unit-test -! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test -! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test -! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test -! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] unit-test +! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer simple-effect ] unit-test +! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer simple-effect ] unit-test +! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer simple-effect ] unit-test +! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer simple-effect ] unit-test -! [ [ [ object ] [ cons ] ] ] [ [ dup cons? [ drop [[ 1 2 ]] ] unless ] infer ] unit-test +! [ [ [ object ] [ cons ] ] ] [ [ dup cons? [ drop [{ 1 2 }] ] unless ] infer simple-effect ] unit-test ! This form should not have a stack effect ! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ; -! [ [ bad-bin ] infer ] unit-test-fails +! [ [ bad-bin ] infer simple-effect ] unit-test-fails -! [ [ infinite-loop ] infer ] unit-test-fails +! [ [ infinite-loop ] infer simple-effect ] unit-test-fails ! : bad-recursion-1 ! dup [ drop bad-recursion-1 5 ] [ ] ifte ; ! -! [ [ bad-recursion-1 ] infer ] unit-test-fails +! [ [ bad-recursion-1 ] infer simple-effect ] unit-test-fails diff --git a/library/test/prettyprint.factor b/library/test/prettyprint.factor index 52422f06dd..a8572a22c7 100644 --- a/library/test/prettyprint.factor +++ b/library/test/prettyprint.factor @@ -58,12 +58,3 @@ unit-test [ ] [ \ pprinter see ] unit-test [ "ALIEN: 1234" ] [ 1234 unparse ] unit-test - -[ "{\n 5 5 5 5 5 5 5 5 5 5\n}" ] -[ - [ - 4 tab-size set - 23 margin set - 10 5 >vector unparse - ] with-scope -] unit-test diff --git a/library/test/redefine.factor b/library/test/redefine.factor index 2c972c34bb..322ad1b0d1 100644 --- a/library/test/redefine.factor +++ b/library/test/redefine.factor @@ -1,5 +1,5 @@ IN: temporary -USING: compiler inference math ; +USING: compiler inference math generic ; USE: test @@ -8,4 +8,4 @@ USE: test : foo 1 2 3 ; [ 1 2 3 1 2 3 ] [ bar ] unit-test -[ [ 0 3 ] ] [ [ foo ] infer ] unit-test +[ [ [ ] [ object object object ] ] ] [ [ foo ] infer ] unit-test diff --git a/library/vocabularies.factor b/library/vocabularies.factor index b427341ad7..0f1396c510 100644 --- a/library/vocabularies.factor +++ b/library/vocabularies.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2004, 2005 Slava Pestov. ! See http://factor.sf.net/license.txt for BSD license. IN: words -USING: hashtables kernel lists namespaces strings sequences ; +USING: hashtables errors kernel lists namespaces strings +sequences ; SYMBOL: vocabularies @@ -56,17 +57,16 @@ SYMBOL: vocabularies dup word-name over word-vocabulary nest set-hash ] bind ; +: check-create ( name vocab -- ) + string? [ "Vocabulary name is not a string" throw ] unless + string? [ "Word name is not a string" throw ] unless ; + : create ( name vocab -- word ) #! Create a new word in a vocabulary. If the vocabulary #! already contains the word, the existing instance is #! returned. - 2dup vocab ?hash [ - nip - dup f "documentation" set-word-prop - dup f "stack-effect" set-word-prop - ] [ - (create) dup reveal - ] ?ifte ; + 2dup check-create 2dup vocab ?hash + [ nip ] [ (create) dup reveal ] ?ifte ; : constructor-word ( string vocab -- word ) >r "<" swap ">" append3 r> create ; diff --git a/library/words.factor b/library/words.factor index d276c92e10..26ecceac2c 100644 --- a/library/words.factor +++ b/library/words.factor @@ -87,8 +87,7 @@ M: word (uncrossref) drop ; : define ( word primitive parameter -- ) pick uncrossref pick set-word-def - over set-word-primitive - f "parsing" set-word-prop ; + swap set-word-primitive ; GENERIC: definer ( word -- word ) #! Return the parsing word that defined this word. @@ -117,13 +116,15 @@ M: compound definer drop \ : ; : (define-compound) ( word def -- ) >r dup dup remove-crossref r> 1 swap define add-crossref ; +: reset-props ( word seq -- ) + [ f swap set-word-prop ] each-with ; + +: reset-generic ( word -- ) + #! Make a word no longer be generic. + { "methods" "combination" "picker" } reset-props ; + : define-compound ( word def -- ) - #! If the word is a generic word, clear the properties - #! involved so that 'see' can work properly. - over f "methods" set-word-prop - over f "picker" set-word-prop - over f "combination" set-word-prop - (define-compound) ; + over reset-generic (define-compound) ; GENERIC: literalize ( obj -- obj )