fix bootstrap failure, other cleanups

diff --git a/library/alien/c-types.factor b/library/alien/c-types.factor
index 9c7a5316c0ef5f00b25d05575721ce45c84e7c12..4798b89a04596ede16abab3ff2d68e535ffc0651 100644 (file)
--- 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 <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 ;

diff --git a/library/alien/compiler.factor b/library/alien/compiler.factor
index f64a770a98b09fd642cf23135531972faaaa2eba..7e152638ae1ed5532ad218d2b8885202642dbae8 100644 (file)
--- 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 22201d6c10949c1cd1c2caa5855f603ed281654b..2ae64e7faa8b772fd503c1a14c19f05675ee25a8 100644 (file)
--- 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 eb90cd087dc686e962b7a1751c4a2f3537ef39b4..49aefedf60eae10c472a89ad74f462b6579da842 100644 (file)
--- 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 0635d1ca31c2b5bbfaa32cd71119667f6c430773..bd6a95f5c72ba74195034dce4f6d4da5aeb36f78 100644 (file)
--- 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 a2d46c7ffca0e4e01d37db1e15c117e42b0d54fd..48c10f511f292addfda3f0c20341085083adf337 100644 (file)
--- 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
-
-[ [ 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
-
-[ [ 1 0 ] ] [ [ >n ] infer ] unit-test
-[ [ 0 1 ] ] [ [ n> ] infer ] 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
-
-[ [ 1 1 ] ] [ [ string>number ] infer ] unit-test
-[ [ 2 1 ] ] [ [ = ] infer ] unit-test
-[ [ 1 1 ] ] [ [ get ] infer ] 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
-
-[ [ 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
+! [ [ no-base-case ] infer simple-effect ] unit-test-fails
+
+[ { 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 simple-effect ] unit-test
+[ { 0 1 } ] [ [ n> ] infer simple-effect ] 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 simple-effect ] unit-test
+[ { 2 1 } ] [ [ = ] infer simple-effect ] unit-test
+[ { 1 1 } ] [ [ get ] infer simple-effect ] 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 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 52422f06dd97153278e0060addbf57caeb10c88f..a8572a22c75c18a2f66b3080a62eaf808f4a2fdc 100644 (file)
--- a/library/test/prettyprint.factor
+++ b/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

diff --git a/library/test/redefine.factor b/library/test/redefine.factor
index 2c972c34bbaf87bdd385593e717d222686aae04d..322ad1b0d14803c52e1f049a7c6a24d5de4f54c6 100644 (file)
--- 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 b427341ad78f93ddbb677bcaa309994ba653fdd7..0f1396c5104f7e378aa20f1bd9de7eff69938fd0 100644 (file)
--- 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 d276c92e10888aad32b72301b7db33c60134f147..26ecceac2c036961776f9e1f227eaf8a2ec54189 100644 (file)
--- 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 )