diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 0e038d0a10..74b4d03cbb 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -47,6 +47,7 @@ vocabs.loader system debugger continuations ; "listener" vocab [ restarts. vocab-main execute ] [ die ] if* + 1 exit ] recover ] [ "Cannot find " write write "." print diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 40bcbe78b1..ad2fa14954 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -214,7 +214,7 @@ M: check-closed summary drop "Attempt to perform I/O on closed stream" ; M: check-method summary - drop "Invalid parameters for define-method" ; + drop "Invalid parameters for create-method" ; M: check-tuple summary drop "Invalid class for define-constructor" ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 9b799d9143..62b85dde3a 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -34,7 +34,7 @@ $nl { $subsection define-generic } { $subsection define-simple-generic } "Methods can be added to existing generic words:" -{ $subsection define-method } +{ $subsection create-method } "Method definitions can be looked up:" { $subsection method } { $subsection methods } @@ -123,7 +123,7 @@ HELP: method { $values { "class" class } { "generic" generic } { "method/f" "a " { $link method-body } " or " { $link f } } } { $description "Looks up a method definition." } ; -{ method define-method POSTPONE: M: } related-words +{ method create-method POSTPONE: M: } related-words HELP: { $values { "quot" quotation } { "class" class } { "generic" generic } { "method" "a new method definition" } } @@ -140,16 +140,17 @@ HELP: order HELP: check-method { $values { "class" class } { "generic" generic } } { $description "Asserts that " { $snippet "class" } " is a class word and " { $snippet "generic" } " is a generic word, throwing a " { $link check-method } " error if the assertion fails." } -{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link define-method } " is given an invalid class or generic word." } ; +{ $error-description "Thrown if " { $link POSTPONE: M: } " or " { $link create-method } " is given an invalid class or generic word." } ; HELP: with-methods { $values { "word" generic } { "quot" "a quotation with stack effect " { $snippet "( methods -- )" } } } { $description "Applies a quotation to the generic word's methods hashtable, and regenerates the generic word's definition when the quotation returns." } $low-level-note ; -HELP: define-method -{ $values { "quot" quotation } { "class" class } { "generic" generic } } -{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ; +HELP: create-method +{ $values { "class" class } { "generic" generic } { "method" method-body } } +{ $description "Creates a method or returns an existing one. This is the runtime equivalent of " { $link POSTPONE: M: } "." } +{ $notes "To define a method, pass the output value to " { $link define } "." } ; HELP: implementors { $values { "class" class } { "seq" "a sequence of generic words" } } diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 3c83b87d49..ad31831e94 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -17,10 +17,6 @@ M: object perform-combination #! the method will throw an error. We don't want that. nip [ "Invalid method combination" throw ] curry [ ] like ; -GENERIC: method-prologue ( class combination -- quot ) - -M: object method-prologue 2drop [ ] ; - GENERIC: make-default-method ( generic combination -- method ) PREDICATE: word generic "combination" word-prop >boolean ; @@ -50,55 +46,49 @@ TUPLE: check-method class generic ; : check-method ( class generic -- class generic ) over class? over generic? and [ \ check-method construct-boa throw - ] unless ; + ] unless ; inline -: with-methods ( word quot -- ) +: with-methods ( generic quot -- ) swap [ "methods" word-prop swap call ] keep make-generic ; inline : method-word-name ( class word -- string ) word-name "/" rot word-name 3append ; -: make-method-def ( quot class generic -- quot ) - "combination" word-prop method-prologue swap append ; - -PREDICATE: word method-body "method-def" word-prop >boolean ; +PREDICATE: word method-body + "method-generic" word-prop >boolean ; M: method-body stack-effect "method-generic" word-prop stack-effect ; -: method-word-props ( quot class generic -- assoc ) +: method-word-props ( class generic -- assoc ) [ "method-generic" set "method-class" set - "method-def" set ] H{ } make-assoc ; -: ( quot class generic -- method ) +: ( class generic -- method ) check-method - [ make-method-def ] 3keep [ method-word-props ] 2keep method-word-name f - tuck set-word-props - dup rot define ; + [ set-word-props ] keep ; -: redefine-method ( quot class generic -- ) - [ method swap "method-def" set-word-prop ] 3keep - [ make-method-def ] 2keep - method swap define ; +: reveal-method ( method class generic -- ) + [ set-at ] with-methods ; -: define-method ( quot class generic -- ) - >r bootstrap-word r> - 2dup method [ - redefine-method +: create-method ( class generic -- method ) + 2dup method dup [ + 2nip ] [ - [ ] 2keep - [ set-at ] with-methods + drop [ dup ] 2keep reveal-method ] if ; +: ( generic combination -- method ) + object bootstrap-word pick + [ -rot make-default-method define ] keep ; + : define-default-method ( generic combination -- ) - dupd make-default-method object bootstrap-word pick - "default-method" set-word-prop ; + dupd "default-method" set-word-prop ; ! Definition protocol M: method-spec where @@ -108,11 +98,10 @@ M: method-spec set-where first2 method set-where ; M: method-spec definer - drop \ M: \ ; ; + first2 method definer ; M: method-spec definition - first2 method dup - [ "method-def" word-prop ] when ; + first2 method definition ; : forget-method ( class generic -- ) check-method @@ -125,9 +114,6 @@ M: method-spec forget* M: method-body definer drop \ M: \ ; ; -M: method-body definition - "method-def" word-prop ; - M: method-body forget* dup "method-class" word-prop swap "method-generic" word-prop diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor index 27b0ddb7a2..9fd5481a39 100755 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -43,7 +43,7 @@ TUPLE: no-math-method left right generic ; : applicable-method ( generic class -- quot ) over method - [ word-def ] + [ 1quotation ] [ default-math-method ] ?if ; : object-method ( generic -- quot ) diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 313f487c99..c634e02e75 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,10 +8,6 @@ IN: generic.standard TUPLE: standard-combination # ; -M: standard-combination method-prologue - standard-combination-# object - swap add* [ declare ] curry ; - C: standard-combination SYMBOL: (dispatch#) diff --git a/core/optimizer/specializers/specializers.factor b/core/optimizer/specializers/specializers.factor index 10a9fda3ea..5153d84c7f 100755 --- a/core/optimizer/specializers/specializers.factor +++ b/core/optimizer/specializers/specializers.factor @@ -24,20 +24,40 @@ IN: optimizer.specializers \ dispatch , ] [ ] make ; -: specializer-methods ( quot word -- default alist ) +: specializer-cases ( quot word -- default alist ) dup [ array? ] all? [ 1array ] unless [ [ make-specializer ] keep [ declare ] curry pick append ] { } map>assoc ; +: method-declaration ( method -- quot ) + dup "method-generic" word-prop dispatch# object + swap "method-class" word-prop add* ; + +: specialize-method ( quot method -- quot' ) + method-declaration [ declare ] curry swap append ; + +: specialize-quot ( quot specializer -- quot' ) + dup { number } = [ + drop tag-specializer + ] [ + specializer-cases alist>quot + ] if ; + +: standard-method? ( method -- ? ) + dup method-body? [ + "method-generic" word-prop standard-generic? + ] [ drop f ] if ; + : specialized-def ( word -- quot ) - dup word-def swap "specializer" word-prop [ - dup { number } = [ - drop tag-specializer - ] [ - specializer-methods alist>quot - ] if - ] when* ; + dup word-def swap { + { [ dup standard-method? ] [ specialize-method ] } + { + [ dup "specializer" word-prop ] + [ "specializer" word-prop specialize-quot ] + } + { [ t ] [ drop ] } + } cond ; : specialized-length ( specializer -- n ) dup [ array? ] all? [ first ] when length ; diff --git a/core/parser/parser.factor b/core/parser/parser.factor index 50f8f582d3..c955817ab9 100755 --- a/core/parser/parser.factor +++ b/core/parser/parser.factor @@ -215,9 +215,6 @@ SYMBOL: in : set-in ( name -- ) check-vocab-string dup in set create-vocab (use+) ; -: create-in ( string -- word ) - in get create dup set-word dup save-location ; - TUPLE: unexpected want got ; : unexpected ( want got -- * ) @@ -238,8 +235,15 @@ PREDICATE: unexpected unexpected-eof : parse-tokens ( end -- seq ) 100 swap (parse-tokens) >array ; +: create-in ( string -- word ) + in get create dup set-word dup save-location ; + : CREATE ( -- word ) scan create-in ; +: CREATE-GENERIC ( -- word ) CREATE dup reset-word ; + +: CREATE-WORD ( -- word ) CREATE dup reset-generic ; + : create-class-in ( word -- word ) in get create dup save-class-location @@ -284,6 +288,12 @@ M: no-word summary ] ?if ] when ; +: create-method-in ( class generic -- method ) + create-method f set-word dup save-location ; + +: CREATE-METHOD ( -- method ) + scan-word scan-word create-method-in ; + TUPLE: staging-violation word ; : staging-violation ( word -- * ) @@ -355,7 +365,9 @@ TUPLE: bad-number ; : parse-definition ( -- quot ) \ ; parse-until >quotation ; -: (:) CREATE dup reset-generic parse-definition ; +: (:) CREATE-WORD parse-definition ; + +: (M:) CREATE-METHOD parse-definition ; GENERIC: expected>string ( obj -- str ) diff --git a/core/slots/slots.factor b/core/slots/slots.factor index 92d22247bd..7e9046573f 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ; C: slot-spec : define-typecheck ( class generic quot -- ) - over define-simple-generic -rot define-method ; + over define-simple-generic + >r create-method r> define ; : define-slot-word ( class slot word quot -- ) rot >fixnum add* define-typecheck ; diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 79a5553228..d9870b08da 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -97,7 +97,7 @@ IN: bootstrap.syntax "parsing" [ word t "parsing" set-word-prop ] define-syntax "SYMBOL:" [ - CREATE dup reset-generic define-symbol + CREATE-WORD define-symbol ] define-syntax "DEFER:" [ @@ -111,31 +111,26 @@ IN: bootstrap.syntax ] define-syntax "GENERIC:" [ - CREATE dup reset-word - define-simple-generic + CREATE-GENERIC define-simple-generic ] define-syntax "GENERIC#" [ - CREATE dup reset-word + CREATE-GENERIC scan-word define-generic ] define-syntax "MATH:" [ - CREATE dup reset-word + CREATE-GENERIC T{ math-combination } define-generic ] define-syntax "HOOK:" [ - CREATE dup reset-word scan-word + CREATE-GENERIC scan-word define-generic ] define-syntax "M:" [ - f set-word - location >r - scan-word bootstrap-word scan-word - [ parse-definition -rot define-method ] 2keep - 2array r> remember-definition + (M:) define ] define-syntax "UNION:" [ @@ -163,7 +158,7 @@ IN: bootstrap.syntax ] define-syntax "C:" [ - CREATE dup reset-generic + CREATE-WORD scan-word dup check-tuple [ construct-boa ] curry define-inline ] define-syntax diff --git a/core/threads/threads-tests.factor b/core/threads/threads-tests.factor index c2e627e7bf..d746404cba 100755 --- a/core/threads/threads-tests.factor +++ b/core/threads/threads-tests.factor @@ -14,3 +14,5 @@ yield [ 3 ] [ [ 3 swap resume-with ] "Test suspend" suspend ] unit-test + +[ f ] [ f get-global ] unit-test diff --git a/core/threads/threads.factor b/core/threads/threads.factor index b4fd6eee60..d7d7988893 100755 --- a/core/threads/threads.factor +++ b/core/threads/threads.factor @@ -32,8 +32,6 @@ mailbox variables sleep-entry ; : threads 41 getenv ; -threads global [ H{ } assoc-like ] change-at - : thread ( id -- thread ) threads at ; : thread-registered? ( thread -- ? ) diff --git a/core/words/words.factor b/core/words/words.factor index ce69c1ff2e..73b877fdbb 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -68,7 +68,7 @@ SYMBOL: bootstrapping? : crossref? ( word -- ? ) { { [ dup "forgotten" word-prop ] [ f ] } - { [ dup "method-def" word-prop ] [ t ] } + { [ dup "method-generic" word-prop ] [ t ] } { [ dup word-vocabulary ] [ t ] } { [ t ] [ f ] } } cond nip ; diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 654d096b26..9eabfae95c 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -7,7 +7,7 @@ IN: delegate swap { } like "protocol-words" set-word-prop ; : PROTOCOL: - CREATE dup reset-generic dup define-symbol + CREATE-WORD dup define-symbol parse-definition swap define-protocol ; parsing PREDICATE: word protocol "protocol-words" word-prop ; diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index b4f1b0a61e..bd1e62f22a 100755 --- a/extra/locals/locals-tests.factor +++ b/extra/locals/locals-tests.factor @@ -1,5 +1,6 @@ USING: locals math sequences tools.test hashtables words kernel -namespaces arrays strings prettyprint ; +namespaces arrays strings prettyprint io.streams.string parser +; IN: locals.tests :: foo ( a b -- a a ) a a ; @@ -178,3 +179,19 @@ M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ; [ "[| a! | ]" ] [ [| a! | ] unparse ] unit-test + +DEFER: xyzzy + +[ ] [ + "IN: locals.tests USE: math GENERIC: xyzzy M: integer xyzzy ;" + "lambda-generic-test" parse-stream drop +] unit-test + +[ 10 ] [ 10 xyzzy ] unit-test + +[ ] [ + "IN: locals.tests USE: math USE: locals GENERIC: xyzzy M:: integer xyzzy ( n -- ) 5 ;" + "lambda-generic-test" parse-stream drop +] unit-test + +[ 5 ] [ 10 xyzzy ] unit-test diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 9819e65e37..a8f5e139e7 100755 --- a/extra/locals/locals.factor +++ b/extra/locals/locals.factor @@ -249,13 +249,14 @@ M: wlet local-rewrite* word [ over "declared-effect" set-word-prop ] when* effect-in make-locals ; -: ((::)) ( word -- word quot ) +: parse-locals-definition ( word -- word quot ) scan "(" assert= parse-locals \ ; (parse-lambda) 2dup "lambda" set-word-prop lambda-rewrite first ; -: (::) ( -- word quot ) - CREATE dup reset-generic ((::)) ; +: (::) CREATE-WORD parse-locals-definition ; + +: (M::) CREATE-METHOD parse-locals-definition ; PRIVATE> @@ -275,18 +276,7 @@ MACRO: with-locals ( form -- quot ) lambda-rewrite ; : :: (::) define ; parsing -! This will be cleaned up when method tuples and method words -! are unified -: create-method ( class generic -- method ) - 2dup method dup - [ 2nip ] - [ drop 2dup [ ] -rot define-method create-method ] if ; - -: CREATE-METHOD ( -- class generic body ) - scan-word bootstrap-word scan-word 2dup - create-method f set-word dup save-location ; - -: M:: CREATE-METHOD ((::)) nip -rot define-method ; parsing +: M:: (M::) define ; parsing : MACRO:: (::) define-macro ; parsing diff --git a/extra/logging/logging.factor b/extra/logging/logging.factor index 5846515dca..42545500a5 100755 --- a/extra/logging/logging.factor +++ b/extra/logging/logging.factor @@ -127,8 +127,7 @@ PRIVATE> : LOG: #! Syntax: name level - CREATE - dup reset-generic + CREATE-WORD dup scan-word [ >r >r 1array stack>message r> r> log-message ] 2curry define ; parsing diff --git a/extra/memoize/memoize.factor b/extra/memoize/memoize.factor index 3b0b8fd29f..ab915ae7d5 100755 --- a/extra/memoize/memoize.factor +++ b/extra/memoize/memoize.factor @@ -40,7 +40,7 @@ IN: memoize over make-memoizer define ; : MEMO: - CREATE dup reset-generic parse-definition define-memoized ; parsing + CREATE-WORD parse-definition define-memoized ; parsing PREDICATE: word memoized "memoize" word-prop ; diff --git a/extra/multiline/multiline.factor b/extra/multiline/multiline.factor index 5baa205d15..079f484274 100755 --- a/extra/multiline/multiline.factor +++ b/extra/multiline/multiline.factor @@ -18,7 +18,7 @@ IN: multiline lexer get next-line ; : STRING: - CREATE dup reset-generic + CREATE-WORD parse-here 1quotation define-inline ; parsing : (parse-multiline-string) ( start-index end-text -- end-index ) diff --git a/extra/promises/promises.factor b/extra/promises/promises.factor index 3724b929f0..469f6a91ed 100755 --- a/extra/promises/promises.factor +++ b/extra/promises/promises.factor @@ -40,6 +40,6 @@ TUPLE: promise quot forced? value ; ] [ ] make ; : LAZY: - CREATE dup reset-generic + CREATE-WORD dup parse-definition make-lazy-quot define ; parsing diff --git a/extra/unicode/data/data.factor b/extra/unicode/data/data.factor index 11be803893..d8e1e8937a 100755 --- a/extra/unicode/data/data.factor +++ b/extra/unicode/data/data.factor @@ -5,7 +5,7 @@ IN: unicode.data << : VALUE: - CREATE dup reset-generic { f } clone [ first ] curry define ; parsing + CREATE-WORD { f } clone [ first ] curry define ; parsing : set-value ( value word -- ) word-def first set-first ;