Parser overhaul

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" ;

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: <method>
 { $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
+HELP: create-method
-{ $values { "quot" quotation } { "class" class } { "generic" generic } }
+{ $values { "class" class } { "generic" generic } { "method" method-body } }
-{ $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ;
+{ $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" } }

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 )
+PREDICATE: word method-body
-    "combination" word-prop method-prologue swap append ;
+    "method-generic" word-prop >boolean ;
-
-PREDICATE: word method-body "method-def" 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 ;
 
-: <method> ( quot class generic -- method )
+: <method> ( class generic -- method )
     check-method
-    [ make-method-def ] 3keep
     [ method-word-props ] 2keep
     method-word-name f <word>
-    tuck set-word-props
+    [ set-word-props ] keep ;
-    dup rot define ;
 
-: redefine-method ( quot class generic -- )
+: reveal-method ( method class generic -- )
-    [ method swap "method-def" set-word-prop ] 3keep
+    [ set-at ] with-methods ;
-    [ make-method-def ] 2keep
-    method swap define ;
 
-: define-method ( quot class generic -- )
+: create-method ( class generic -- method )
-    >r bootstrap-word r>
+    2dup method dup [
-    2dup method [
+        2nip
-        redefine-method
     ] [
-        [ <method> ] 2keep
+        drop [ <method> dup ] 2keep reveal-method
-        [ set-at ] with-methods
     ] if ;
 
+: <default-method> ( generic combination -- method )
+    object bootstrap-word pick <method>
+    [ -rot make-default-method define ] keep ;
+
 : define-default-method ( generic combination -- )
-    dupd make-default-method object bootstrap-word pick <method>
+    dupd <default-method> "default-method" set-word-prop ;
-    "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
+    first2 method definition ;
-    [ "method-def" word-prop ] when ;
 
 : 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

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 )

core/generic/standard/standard.factor

@@ -8,10 +8,6 @@ IN: generic.standard
 
 TUPLE: standard-combination # ;
 
-M: standard-combination method-prologue
-    standard-combination-# object
-    <array> swap add* [ declare ] curry ;
-
 C: <standard-combination> standard-combination
 
 SYMBOL: (dispatch#)

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 <array>
+    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 word-def swap {
-        dup { number } = [
+        { [ dup standard-method? ] [ specialize-method ] }
-            drop tag-specializer
+        {
-        ] [
+            [ dup "specializer" word-prop ]
-            specializer-methods alist>quot
+            [ "specializer" word-prop specialize-quot ]
-        ] if
+        }
-    ] when* ;
+        { [ t ] [ drop ] }
+    } cond ;
 
 : specialized-length ( specializer -- n )
     dup [ array? ] all? [ first ] when length ;

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 <vector> 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 )
 

core/slots/slots.factor

@@ -10,7 +10,8 @@ TUPLE: slot-spec type name offset reader writer ;
 C: <slot-spec> 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 ;

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
+        CREATE-GENERIC define-simple-generic
-        define-simple-generic
     ] define-syntax
 
     "GENERIC#" [
-        CREATE dup reset-word
+        CREATE-GENERIC
         scan-word <standard-combination> 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
         <hook-combination> define-generic
     ] define-syntax
 
     "M:" [
-        f set-word
+        (M:) define
-        location >r
-        scan-word bootstrap-word scan-word
-        [ parse-definition -rot define-method ] 2keep
-        2array r> remember-definition
     ] 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

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 ;

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 ;

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 ;"
+    <string-reader> "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 ;"
+    <string-reader> "lambda-generic-test" parse-stream drop
+] unit-test
+
+[ 5 ] [ 10 xyzzy ] unit-test

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) <lambda>
     2dup "lambda" set-word-prop
     lambda-rewrite first ;
 
-: (::) ( -- word quot )
+: (::) CREATE-WORD parse-locals-definition ;
-    CREATE dup reset-generic ((::)) ;
+
+: (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
+: M:: (M::) define ; parsing
-! 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
 
 : MACRO:: (::) define-macro ; parsing
 

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 ;
 

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 )

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

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 ;