steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

fix bootstrap failure, other cleanups

cvs
Slava Pestov 2005-08-22 03:35:50 +00:00
parent 1743df1bd4
commit 4a6900af6a
10 changed files with 128 additions and 133 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
library/alien/c-types.factor
View File

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

9
library/alien/compiler.factor
View File

@ -156,11 +156,6 @@ M: compound (uncrossref)
dup word-def \ alien-invoke swap member? [ dup word-def \ alien-invoke swap member? [
drop drop
] [ ] [
dup f "infer-effect" set-word-prop dup { "infer-effect" "base-case" "no-effect" }
dup f "base-case" set-word-prop reset-props decompile
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
] ifte ; ] ifte ;

5
library/generic/slots.factor
View File

@ -29,8 +29,11 @@ sequences strings vectors words ;
: define-slot ( class slot reader writer -- ) : define-slot ( class slot reader writer -- )
>r >r 2dup r> define-reader r> define-writer ; >r >r 2dup r> define-reader r> define-writer ;
: ?create ( { name vocab }/f -- word )
dup [ 2unseq create ] when ;
: intern-slots ( spec -- spec ) : 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-slots ( class spec -- )
#! Define a collection of slot readers and writers for the #! Define a collection of slot readers and writers for the

4
library/syntax/prettyprint.factor
View File

@ -181,7 +181,9 @@ GENERIC: pprint* ( obj -- )
: word-style ( word -- style ) : word-style ( word -- style )
dup word-vocabulary vocab-style swap presented swons add ; 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 -- ) M: object pprint* ( obj -- )
"( unprintable object: " swap class word-name " )" append3 "( unprintable object: " swap class word-name " )" append3

7
library/test/generic.factor
View File

@ -1,6 +1,4 @@
IN: temporary IN: temporary
USING: parser prettyprint sequences io strings ;
USE: hashtables USE: hashtables
USE: namespaces USE: namespaces
USE: generic USE: generic
@ -11,6 +9,11 @@ USE: words
USE: lists USE: lists
USE: vectors USE: vectors
USE: alien USE: alien
USE: sequences
USE: prettyprint
USE: io
USE: parser
USE: strings
GENERIC: class-of GENERIC: class-of

182
library/test/inference.factor
View File

@ -2,39 +2,41 @@ IN: temporary
USING: generic inference kernel lists math math-internals USING: generic inference kernel lists math math-internals
namespaces parser sequences test vectors ; namespaces parser sequences test vectors ;
[ [ 0 2 ] ] [ [ 2 "Hello" ] infer ] unit-test : simple-effect 2unseq >r length r> length 2vector ;
[ [ 1 2 ] ] [ [ dup ] infer ] unit-test
[ [ 1 2 ] ] [ [ [ dup ] call ] infer ] unit-test [ { 0 2 } ] [ [ 2 "Hello" ] infer simple-effect ] unit-test
[ [ call ] infer ] unit-test-fails [ { 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 [ { 2 4 } ] [ [ 2dup ] infer simple-effect ] 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
[ [ 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 [ swap 3 ] [ nip 5 5 ] ifte
] [ ] [
-rot -rot
] ifte ] ifte
] infer ] infer simple-effect
] unit-test ] unit-test
[ [ 1 1 ] ] [ [ dup [ ] when ] infer ] unit-test [ { 1 1 } ] [ [ dup [ ] when ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ dup [ dup fixnum* ] when ] infer ] unit-test [ { 1 1 } ] [ [ dup [ dup fixnum* ] when ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ [ dup fixnum* ] when ] infer ] unit-test [ { 2 1 } ] [ [ [ dup fixnum* ] when ] infer simple-effect ] unit-test
[ [ 1 0 ] ] [ [ [ drop ] when* ] infer ] unit-test [ { 1 0 } ] [ [ [ drop ] when* ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ [ { { [ ] } } ] unless* ] infer ] unit-test [ { 1 1 } ] [ [ [ { { [ ] } } ] unless* ] infer simple-effect ] unit-test
[ [ 0 1 ] ] [ [ { 0 1 } ] [
[ [ 2 2 fixnum+ ] dup [ ] when call ] infer [ [ 2 2 fixnum+ ] dup [ ] when call ] infer simple-effect
] unit-test ] unit-test
[ [
@ -46,27 +48,27 @@ namespaces parser sequences test vectors ;
: simple-recursion-1 : simple-recursion-1
dup [ simple-recursion-1 ] [ ] ifte ; 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 : simple-recursion-2
dup [ ] [ simple-recursion-2 ] ifte ; 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 : bad-recursion-2
dup [ uncons bad-recursion-2 ] [ ] ifte ; 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 ! Not sure how to fix this one
: funny-recursion : funny-recursion
dup [ funny-recursion 1 ] [ 2 ] ifte drop ; 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 ! Simple combinators
[ [ 1 2 ] ] [ [ [ car ] keep cdr ] infer ] unit-test [ { 1 2 } ] [ [ [ car ] keep cdr ] infer simple-effect ] unit-test
! Mutual recursion ! Mutual recursion
DEFER: foe DEFER: foe
@ -89,8 +91,8 @@ DEFER: foe
2drop f 2drop f
] ifte ; ] ifte ;
[ [ 2 1 ] ] [ [ fie ] infer ] unit-test [ { 2 1 } ] [ [ fie ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ foe ] infer ] unit-test [ { 2 1 } ] [ [ foe ] infer simple-effect ] unit-test
: nested-when ( -- ) : nested-when ( -- )
t [ t [
@ -99,7 +101,7 @@ DEFER: foe
] when ] when
] when ; ] when ;
[ [ 0 0 ] ] [ [ nested-when ] infer ] unit-test [ { 0 0 } ] [ [ nested-when ] infer simple-effect ] unit-test
: nested-when* ( -- ) : nested-when* ( -- )
[ [
@ -108,11 +110,11 @@ DEFER: foe
] when* ] when*
] when* ; ] when* ;
[ [ 1 0 ] ] [ [ nested-when* ] infer ] unit-test [ { 1 0 } ] [ [ nested-when* ] infer simple-effect ] unit-test
SYMBOL: sym-test SYMBOL: sym-test
[ [ 0 1 ] ] [ [ sym-test ] infer ] unit-test [ { 0 1 } ] [ [ sym-test ] infer simple-effect ] unit-test
: terminator-branch : terminator-branch
dup [ dup [
@ -121,7 +123,7 @@ SYMBOL: sym-test
not-a-number not-a-number
] ifte ; ] ifte ;
[ [ 1 1 ] ] [ [ terminator-branch ] infer ] unit-test [ { 1 1 } ] [ [ terminator-branch ] infer simple-effect ] unit-test
: recursive-terminator : recursive-terminator
dup [ dup [
@ -130,7 +132,7 @@ SYMBOL: sym-test
not-a-number not-a-number
] ifte ; ] ifte ;
[ [ 1 1 ] ] [ [ recursive-terminator ] infer ] unit-test [ { 1 1 } ] [ [ recursive-terminator ] infer simple-effect ] unit-test
GENERIC: potential-hang GENERIC: potential-hang
M: fixnum potential-hang dup [ potential-hang ] when ; 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: f iterate drop ;
M: real 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 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 [ { 2 1 } ] [ [ 2vector ] infer simple-effect ] unit-test
[ [ 3 1 ] ] [ [ 3vector ] infer ] unit-test [ { 3 1 } ] [ [ 3vector ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ swons ] infer ] unit-test [ { 2 1 } ] [ [ swons ] infer simple-effect ] unit-test
[ [ 1 2 ] ] [ [ uncons ] infer ] unit-test [ { 1 2 } ] [ [ uncons ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ unit ] infer ] unit-test [ { 1 1 } ] [ [ unit ] infer simple-effect ] unit-test
[ [ 1 2 ] ] [ [ unswons ] infer ] unit-test [ { 1 2 } ] [ [ unswons ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ last ] infer ] unit-test [ { 1 1 } ] [ [ last ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ list? ] infer ] unit-test [ { 1 1 } ] [ [ list? ] infer simple-effect ] unit-test
[ [ 1 0 ] ] [ [ >n ] infer ] unit-test [ { 1 0 } ] [ [ >n ] infer simple-effect ] unit-test
[ [ 0 1 ] ] [ [ n> ] infer ] unit-test [ { 0 1 } ] [ [ n> ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ bitor ] infer ] unit-test [ { 2 1 } ] [ [ bitor ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ bitand ] infer ] unit-test [ { 2 1 } ] [ [ bitand ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ bitxor ] infer ] unit-test [ { 2 1 } ] [ [ bitxor ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ mod ] infer ] unit-test [ { 2 1 } ] [ [ mod ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ /i ] infer ] unit-test [ { 2 1 } ] [ [ /i ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ /f ] infer ] unit-test [ { 2 1 } ] [ [ /f ] infer simple-effect ] unit-test
[ [ 2 2 ] ] [ [ /mod ] infer ] unit-test [ { 2 2 } ] [ [ /mod ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ + ] infer ] unit-test [ { 2 1 } ] [ [ + ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ - ] infer ] unit-test [ { 2 1 } ] [ [ - ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ * ] infer ] unit-test [ { 2 1 } ] [ [ * ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ / ] infer ] unit-test [ { 2 1 } ] [ [ / ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ < ] infer ] unit-test [ { 2 1 } ] [ [ < ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ <= ] infer ] unit-test [ { 2 1 } ] [ [ <= ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ > ] infer ] unit-test [ { 2 1 } ] [ [ > ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ >= ] infer ] unit-test [ { 2 1 } ] [ [ >= ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ number= ] infer ] unit-test [ { 2 1 } ] [ [ number= ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ string>number ] infer ] unit-test [ { 1 1 } ] [ [ string>number ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ = ] infer ] unit-test [ { 2 1 } ] [ [ = ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ get ] infer ] unit-test [ { 1 1 } ] [ [ get ] infer simple-effect ] unit-test
[ [ 2 0 ] ] [ [ push ] infer ] unit-test [ { 2 0 } ] [ [ push ] infer simple-effect ] unit-test
[ [ 2 0 ] ] [ [ set-length ] infer ] unit-test [ { 2 0 } ] [ [ set-length ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ append ] infer ] unit-test [ { 2 1 } ] [ [ append ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ peek ] infer ] unit-test [ { 1 1 } ] [ [ peek ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ length ] infer ] unit-test [ { 1 1 } ] [ [ length ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ reverse ] infer ] unit-test [ { 1 1 } ] [ [ reverse ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ member? ] infer ] unit-test [ { 2 1 } ] [ [ member? ] infer simple-effect ] unit-test
[ [ 2 1 ] ] [ [ remove ] infer ] unit-test [ { 2 1 } ] [ [ remove ] infer simple-effect ] unit-test
[ [ 1 1 ] ] [ [ prune ] infer ] unit-test [ { 1 1 } ] [ [ prune ] infer simple-effect ] unit-test
: bad-code "1234" car ; : bad-code "1234" car ;
[ [ 0 1 ] ] [ [ bad-code ] infer ] unit-test [ { 0 1 } ] [ [ bad-code ] infer simple-effect ] unit-test
! Type inference ! Type inference
! [ [ [ object ] [ ] ] ] [ [ drop ] infer ] unit-test ! [ [ [ object ] [ ] ] ] [ [ drop ] infer simple-effect ] unit-test
! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer ] unit-test ! [ [ [ object ] [ object object ] ] ] [ [ dup ] infer simple-effect ] unit-test
! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer ] unit-test ! [ [ [ object object ] [ cons ] ] ] [ [ cons ] infer simple-effect ] unit-test
! [ [ [ object ] [ boolean ] ] ] [ [ dup [ drop t ] unless ] infer ] unit-test ! [ [ [ object ] [ boolean ] ] ] [ [ dup [ drop t ] unless ] infer simple-effect ] unit-test
! [ [ [ general-list ] [ cons ] ] ] [ [ uncons cons ] infer ] 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 ] ] ] [ [ dup + ] infer simple-effect ] unit-test
! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer ] unit-test ! [ [ [ number number number ] [ number ] ] ] [ [ digit+ ] infer simple-effect ] unit-test
! [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer ] unit-test ! [ [ [ number ] [ real real ] ] ] [ [ >rect ] infer simple-effect ] unit-test
! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer ] unit-test ! [ [ [ ] [ POSTPONE: t ] ] ] [ [ f not ] infer simple-effect ] unit-test
! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer ] unit-test ! [ [ [ ] [ POSTPONE: f ] ] ] [ [ t not ] infer simple-effect ] unit-test
! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer ] unit-test ! [ [ [ ] [ POSTPONE: f ] ] ] [ [ 5 not ] infer simple-effect ] unit-test
! [ [ [ object ] [ general-t ] ] ] [ [ dup [ not ] unless ] infer ] 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 ! This form should not have a stack effect
! : bad-bin 5 [ 5 bad-bin bad-bin 5 ] [ 2drop ] ifte ; ! : 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 ! : bad-recursion-1
! dup [ drop bad-recursion-1 5 ] [ ] ifte ; ! dup [ drop bad-recursion-1 5 ] [ ] ifte ;
! !
! [ [ bad-recursion-1 ] infer ] unit-test-fails ! [ [ bad-recursion-1 ] infer simple-effect ] unit-test-fails

9
library/test/prettyprint.factor
View File

@ -58,12 +58,3 @@ unit-test
[ ] [ \ pprinter see ] unit-test [ ] [ \ pprinter see ] unit-test
[ "ALIEN: 1234" ] [ 1234 <alien> unparse ] 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

4
library/test/redefine.factor
View File

@ -1,5 +1,5 @@
IN: temporary IN: temporary
USING: compiler inference math ; USING: compiler inference math generic ;
USE: test USE: test
@ -8,4 +8,4 @@ USE: test
: foo 1 2 3 ; : foo 1 2 3 ;
[ 1 2 3 1 2 3 ] [ bar ] unit-test [ 1 2 3 1 2 3 ] [ bar ] unit-test
[ [ 0 3 ] ] [ [ foo ] infer ] unit-test [ [ [ ] [ object object object ] ] ] [ [ foo ] infer ] unit-test

16
library/vocabularies.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2004, 2005 Slava Pestov. ! Copyright (C) 2004, 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license. ! See http://factor.sf.net/license.txt for BSD license.
IN: words IN: words
USING: hashtables kernel lists namespaces strings sequences ; USING: hashtables errors kernel lists namespaces strings
sequences ;
SYMBOL: vocabularies SYMBOL: vocabularies
@ -56,17 +57,16 @@ SYMBOL: vocabularies
dup word-name over word-vocabulary nest set-hash dup word-name over word-vocabulary nest set-hash
] bind ; ] 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 ( name vocab -- word )
#! Create a new word in a vocabulary. If the vocabulary #! Create a new word in a vocabulary. If the vocabulary
#! already contains the word, the existing instance is #! already contains the word, the existing instance is
#! returned. #! returned.
2dup vocab ?hash [ 2dup check-create 2dup vocab ?hash
nip [ nip ] [ (create) dup reveal ] ?ifte ;
dup f "documentation" set-word-prop
dup f "stack-effect" set-word-prop
] [
(create) dup reveal
] ?ifte ;
: constructor-word ( string vocab -- word ) : constructor-word ( string vocab -- word )
>r "<" swap ">" append3 r> create ; >r "<" swap ">" append3 r> create ;

17
library/words.factor
View File

@ -87,8 +87,7 @@ M: word (uncrossref) drop ;
: define ( word primitive parameter -- ) : define ( word primitive parameter -- )
pick uncrossref pick uncrossref
pick set-word-def pick set-word-def
over set-word-primitive swap set-word-primitive ;
f "parsing" set-word-prop ;
GENERIC: definer ( word -- word ) GENERIC: definer ( word -- word )
#! Return the parsing word that defined this word. #! Return the parsing word that defined this word.
@ -117,13 +116,15 @@ M: compound definer drop \ : ;
: (define-compound) ( word def -- ) : (define-compound) ( word def -- )
>r dup dup remove-crossref r> 1 swap define add-crossref ; >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 -- ) : define-compound ( word def -- )
#! If the word is a generic word, clear the properties over reset-generic (define-compound) ;
#! 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) ;
GENERIC: literalize ( obj -- obj ) GENERIC: literalize ( obj -- obj )