fix bootstrap failure, other cleanups

library/alien/c-types.factor

@@ -26,13 +26,11 @@ SYMBOL: c-types
     c-type [ "width" get ] bind ;
 
 : define-c-type ( quot name -- )
-    >r <c-type> swap extend r> c-types get set-hash ; inline
+    >r <c-type> swap extend r> c-types get set-hash ;
 
-: <c-object> ( size -- byte-array )
-    cell / ceiling <byte-array> ;
+: <c-object> ( size -- c-ptr ) cell / ceiling <byte-array> ;
 
-: <c-array> ( n size -- byte-array )
-    * cell / ceiling <byte-array> ;
+: <c-array> ( n size -- c-ptr ) * <c-object> ;
 
 : define-pointer ( type -- )
     "void*" c-type swap "*" append c-types get set-hash ;

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 ;

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

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

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
 

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

library/test/prettyprint.factor

@@ -58,12 +58,3 @@ unit-test
 [ ] [ \ pprinter see ] unit-test
 
 [ "ALIEN: 1234" ] [ 1234 <alien> unparse ] unit-test
-
-[ "{\n    5 5 5 5 5 5 5 5 5 5\n}" ]
-[
-    [
-        4 tab-size set
-        23 margin set
-        10 5 <repeated> >vector unparse
-    ] with-scope
-] unit-test

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

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 ;

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 )