New locals syntax; added M::

core/parser/parser.factor

@@ -352,6 +352,8 @@ TUPLE: bad-number ;
 : parse-definition ( -- quot )
     \ ; parse-until >quotation ;
 
+: (:) CREATE dup reset-generic parse-definition ;
+
 GENERIC: expected>string ( obj -- str )
 
 M: f expected>string drop "end of input" ;

core/syntax/syntax.factor

@@ -107,7 +107,7 @@ IN: bootstrap.syntax
     ] define-syntax
 
     ":" [
-        CREATE dup reset-generic parse-definition define
+        (:) define
     ] define-syntax
 
     "GENERIC:" [

extra/benchmark/fasta/fasta.factor

@@ -51,7 +51,7 @@ HINTS: random fixnum ;
     dup keys >byte-array
     swap values >float-array unclip [ + ] accumulate swap add ;
 
-:: select-random | seed chars floats |
+:: select-random ( seed chars floats -- elt )
     floats seed random -rot
     [ >= ] curry find drop
     chars nth-unsafe ; inline
@@ -62,7 +62,7 @@ HINTS: random fixnum ;
 : write-description ( desc id -- )
     ">" write write bl print ; inline
 
-:: split-lines | n quot |
+:: split-lines ( n quot -- )
     n line-length /mod
     [ [ line-length quot call ] times ] dip
     dup zero? [ drop ] quot if ; inline
@@ -71,7 +71,7 @@ HINTS: random fixnum ;
     write-description
     [ make-random-fasta ] 2curry split-lines ; inline
 
-:: make-repeat-fasta | k len alu |
+:: make-repeat-fasta ( k len alu -- )
     [let | kn [ alu length ] |
         len [ k + kn mod alu nth-unsafe ] B{ } map-as print
         k len +

extra/channels/examples/examples.factor

@@ -24,7 +24,7 @@ IN: channels.examples
         from swap dupd mod zero? not [ swap to ] [ 2drop ] if     
     ] 3keep filter ;
 
-:: (sieve) | prime c | ( prime c -- )
+:: (sieve) ( prime c -- )
     [let | p [ c from ] 
            newc [ <channel> ] |
         p prime to

extra/cocoa/plists/plists.factor

@@ -2,6 +2,7 @@
 ! See http://factorcode.org/license.txt for BSD license.
 USING: strings arrays hashtables assocs sequences
 xml.writer xml.utilities kernel namespaces ;
+IN: cocoa.plists
 
 GENERIC: >plist ( obj -- tag )
 

extra/concurrency/exchangers/exchangers-tests.factor

@@ -3,7 +3,7 @@ USING: sequences tools.test concurrency.exchangers
 concurrency.count-downs concurrency.promises locals kernel
 threads ;
 
-:: exchanger-test | |
+:: exchanger-test ( -- )
     [let |
         ex [ <exchanger> ]
         c [ 2 <count-down> ]

extra/concurrency/locks/locks-tests.factor

@@ -3,7 +3,7 @@ USING: tools.test concurrency.locks concurrency.count-downs
 concurrency.messaging concurrency.mailboxes locals kernel
 threads sequences calendar ;
 
-:: lock-test-0 | |
+:: lock-test-0 ( -- )
     [let | v [ V{ } clone ]
            c [ 2 <count-down> ] |
 
@@ -27,7 +27,7 @@ threads sequences calendar ;
            v
     ] ;
 
-:: lock-test-1 | |
+:: lock-test-1 ( -- )
     [let | v [ V{ } clone ]
            l [ <lock> ]
            c [ 2 <count-down> ] |
@@ -79,7 +79,7 @@ threads sequences calendar ;
 
 [ ] [ <rw-lock> dup [ [ ] with-read-lock ] with-write-lock ] unit-test
 
-:: rw-lock-test-1 | |
+:: rw-lock-test-1 ( -- )
     [let | l [ <rw-lock> ]
            c [ 1 <count-down> ]
            c' [ 1 <count-down> ]
@@ -129,7 +129,7 @@ threads sequences calendar ;
 
 [ V{ 1 2 3 4 5 6 } ] [ rw-lock-test-1 ] unit-test
 
-:: rw-lock-test-2 | |
+:: rw-lock-test-2 ( -- )
     [let | l [ <rw-lock> ]
            c [ 1 <count-down> ]
            c' [ 2 <count-down> ]
@@ -160,7 +160,7 @@ threads sequences calendar ;
 [ V{ 1 2 3 } ] [ rw-lock-test-2 ] unit-test
 
 ! Test lock timeouts
-:: lock-timeout-test | |
+:: lock-timeout-test ( -- )
     [let | l [ <lock> ] |
         [
             l [ 1 seconds sleep ] with-lock

extra/crypto/md5/md5.factor

@@ -32,7 +32,7 @@ SYMBOL: old-d
     old-c c update-old-new
     old-d d update-old-new ;
 
-:: (ABCD) | x s i k func a b c d |
+:: (ABCD) ( x s i k func a b c d -- )
     #! a = b + ((a + F(b,c,d) + X[k] + T[i]) <<< s)
     a [
         b get c get d get func call w+

extra/io/sniffer/bsd/bsd.factor

@@ -24,7 +24,7 @@ C: <sniffer-spec> sniffer-spec
 : IOC_INOUT      IOC_IN IOC_OUT bitor ; inline
 : IOC_DIRMASK    HEX: e0000000 ; inline
 
-:: ioc | inout group num len |
+:: ioc ( inout group num len -- n )
     group first 8 shift num bitor
     len IOCPARM_MASK bitand 16 shift bitor
     inout bitor ;

extra/locals/locals-docs.factor

@@ -16,7 +16,7 @@ HELP: [|
 { $examples
     { $example
         "USE: locals"
-        ":: adder | n | [| m | m n + ] ;"
+        ":: adder ( n -- quot ) [| m | m n + ] ;"
         "3 5 adder call ."
         "8"
     }
@@ -29,7 +29,7 @@ HELP: [let
 { $examples
     { $example
         "USING: locals math.functions ;"
-        ":: frobnicate | n seq |"
+        ":: frobnicate ( n seq -- newseq )"
         "    [let | n' [ n 6 * ] |"
         "        seq [ n' gcd nip ] map ] ;"
         "6 { 36 14 } frobnicate ."
@@ -44,7 +44,7 @@ HELP: [wlet
 { $examples
     { $example
         "USE: locals"
-        ":: quuxify | n seq |"
+        ":: quuxify ( n seq -- newseq )"
         "    [wlet | add-n [| m | m n + ] |"
         "        seq [ add-n ] map ] ;"
         "2 { 1 2 3 } quuxify ."
@@ -57,13 +57,15 @@ HELP: with-locals
 { $description "Performs closure conversion of a lexically-scoped form. All nested sub-forms are converted. This word must be applied to a " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " used in an ordinary definition, however forms in " { $link POSTPONE: :: } " and " { $link POSTPONE: MACRO:: } " definitions are automatically closure-converted and there is no need to use this word." } ;
 
 HELP: ::
-{ $syntax ":: word | bindings... | body... ;" }
+{ $syntax ":: word ( bindings... -- outputs... ) body... ;" }
 { $description "Defines a word with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
+{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." }
 { $examples "See " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " and " { $link POSTPONE: [wlet } "." } ;
 
 HELP: MACRO::
-{ $syntax "MACRO:: word | bindings... | body... ;" }
+{ $syntax "MACRO:: word ( bindings... -- outputs... ) body... ;" }
-{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." } ;
+{ $description "Defines a macro with named inputs; it reads stack values into bindings from left to right, then executes the body with those bindings in lexical scope. Any " { $link POSTPONE: [| } ", " { $link POSTPONE: [let } " or " { $link POSTPONE: [wlet } " forms used in the body of the word definition are automatically closure-converted." }
+{ $notes "The output names do not affect the word's behavior, however the compiler attempts to check the stack effect as with other definitions." } ;
 
 { POSTPONE: MACRO: POSTPONE: MACRO:: } related-words
 
@@ -72,7 +74,7 @@ ARTICLE: "locals-mutable" "Mutable locals"
 $nl
 "Here is a example word which outputs a pair of quotations which increment and decrement an internal counter, and then return the new value. The quotations are closed over the counter and each invocation of the word yields new quotations with their unique internal counter:"
 { $code
-    ":: counter | |"
+    ":: counter ( -- )"
     "    [let | value! [ 0 ] |"
     "        [ value 1+ dup value! ]"
     "        [ value 1- dup value! ] ] ;"
@@ -86,7 +88,7 @@ ARTICLE: "locals-limitations" "Limitations of locals"
 $nl
 "Another limitation is that closure conversion does not descend into arrays, hashtables or other types of literals. For example, the following does not work:"
 { $code
-    ":: bad-cond-usage | a |"
+    ":: bad-cond-usage ( a -- ... )"
     "    { [ a 0 < ] [ ... ] }"
     "    { [ a 0 > ] [ ... ] }"
     "    { [ a 0 = ] [ ... ] } ;"

extra/locals/locals-tests.factor

@@ -1,52 +1,52 @@
 USING: locals math sequences tools.test hashtables words kernel
-namespaces arrays ;
+namespaces arrays strings prettyprint ;
 IN: temporary
 
-:: foo | a b | a a ;
+:: foo ( a b -- a a ) a a ;
 
 [ 1 1 ] [ 1 2 foo ] unit-test
 
-:: add-test | a b | a b + ;
+:: add-test ( a b -- c ) a b + ;
 
 [ 3 ] [ 1 2 add-test ] unit-test
 
-:: sub-test | a b | a b - ;
+:: sub-test ( a b -- c ) a b - ;
 
 [ -1 ] [ 1 2 sub-test ] unit-test
 
-:: map-test | a b | a [ b + ] map ;
+:: map-test ( a b -- seq ) a [ b + ] map ;
 
 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test ] unit-test
 
-:: map-test-2 | seq inc | seq [| elt | elt inc + ] map ;
+:: map-test-2 ( seq inc -- seq ) seq [| elt | elt inc + ] map ;
 
 [ { 5 6 7 } ] [ { 1 2 3 } 4 map-test-2 ] unit-test
 
-:: let-test | c |
+:: let-test ( c -- d )
     [let | a [ 1 ] b [ 2 ] | a b + c + ] ;
 
 [ 7 ] [ 4 let-test ] unit-test
 
-:: let-test-2 | |
+:: let-test-2 ( a -- a )
-    [let | a [ ] | [let | b [ a ] | a ] ] ;
+    a [let | a [ ] | [let | b [ a ] | a ] ] ;
 
 [ 3 ] [ 3 let-test-2 ] unit-test
 
-:: let-test-3 | |
+:: let-test-3 ( a -- a )
-    [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
+    a [let | a [ ] | [let | b [ [ a ] ] | [let | a [ 3 ] | b ] ] ] ;
 
-:: let-test-4 | |
+:: let-test-4 ( a -- b )
-    [let | a [ 1 ] b [ ] | a b 2array ] ;
+    a [let | a [ 1 ] b [ ] | a b 2array ] ;
 
 [ { 1 2 } ] [ 2 let-test-4 ] unit-test
 
-:: let-test-5 | |
+:: let-test-5 ( a -- b )
-    [let | a [ ] b [ ] | a b 2array ] ;
+    a [let | a [ ] b [ ] | a b 2array ] ;
 
 [ { 2 1 } ] [ 1 2 let-test-5 ] unit-test
 
-:: let-test-6 | |
+:: let-test-6 ( a -- b )
-    [let | a [ ] b [ 1 ] | a b 2array ] ;
+    a [let | a [ ] b [ 1 ] | a b 2array ] ;
 
 [ { 2 1 } ] [ 2 let-test-6 ] unit-test
 
@@ -57,26 +57,26 @@ IN: temporary
     with-locals
 ] unit-test
 
-:: wlet-test-2 | a b |
+:: wlet-test-2 ( a b -- seq )
     [wlet | add-b [ b + ] |
         a [ add-b ] map ] ;
 
 
 [ { 4 5 6 } ] [ { 2 3 4 } 2 wlet-test-2 ] unit-test
     
-:: wlet-test-3 | a |
+:: wlet-test-3 ( a -- b )
     [wlet | add-a [ a + ] | [ add-a ] ]
     [let | a [ 3 ] | a swap call ] ;
 
 [ 5 ] [ 2 wlet-test-3 ] unit-test
 
-:: wlet-test-4 | a |
+:: wlet-test-4 ( a -- b )
     [wlet | sub-a [| b | b a - ] |
         3 sub-a ] ;
 
 [ -7 ] [ 10 wlet-test-4 ] unit-test
 
-:: write-test-1 | n! |
+:: write-test-1 ( n! -- q )
     [| i | n i + dup n! ] ;
 
 0 write-test-1 "q" set
@@ -89,7 +89,7 @@ IN: temporary
 
 [ 5 ] [ 2 "q" get call ] unit-test
 
-:: write-test-2 | |
+:: write-test-2 ( -- q )
     [let | n! [ 0 ] |
         [| i | n i + dup n! ] ] ;
 
@@ -108,21 +108,55 @@ write-test-2 "q" set
     20 10 [| a! | [| b! | a b ] ] with-locals call call
 ] unit-test
 
-:: write-test-3 | a! | [| b | b a! ] ;
+:: write-test-3 ( a! -- q ) [| b | b a! ] ;
 
 [ ] [ 1 2 write-test-3 call ] unit-test
 
-:: write-test-4 | x! | [ [let | y! [ 0 ] | f x! ] ] ;
+:: write-test-4 ( x! -- q ) [ [let | y! [ 0 ] | f x! ] ] ;
 
 [ ] [ 5 write-test-4 drop ] unit-test
 
 SYMBOL: a
 
-:: use-test | a b c |
+:: use-test ( a b c -- a b c )
     USE: kernel ;
 
 [ t ] [ a symbol? ] unit-test
 
-:: let-let-test | n | [let | n [ n 3 + ] | n ] ;
+:: let-let-test ( n -- n ) [let | n [ n 3 + ] | n ] ;
 
 [ 13 ] [ 10 let-let-test ] unit-test
+
+GENERIC: lambda-generic ( a b -- c )
+
+GENERIC# lambda-generic-1 1 ( a b -- c )
+
+M:: integer lambda-generic-1 ( a b -- c ) a b * ;
+
+M:: string lambda-generic-1 ( a b -- c )
+    a b CHAR: x <string> lambda-generic ;
+
+M:: integer lambda-generic ( a b -- c ) a b lambda-generic-1 ;
+
+GENERIC# lambda-generic-2 1 ( a b -- c )
+
+M:: integer lambda-generic-2 ( a b -- c )
+    a CHAR: x <string> b lambda-generic ;
+
+M:: string lambda-generic-2 ( a b -- c ) a b append ;
+
+M:: string lambda-generic ( a b -- c ) a b lambda-generic-2 ;
+
+[ 10 ] [ 5 2 lambda-generic ] unit-test
+
+[ "abab" ] [ "aba" "b" lambda-generic ] unit-test
+
+[ "abaxxx" ] [ "aba" 3 lambda-generic ] unit-test
+
+[ "xaba" ] [ 1 "aba" lambda-generic ] unit-test
+
+[ ] [ \ lambda-generic-1 see ] unit-test
+
+[ ] [ \ lambda-generic-2 see ] unit-test
+
+[ ] [ \ lambda-generic see ] unit-test

extra/locals/locals.factor

@@ -4,7 +4,8 @@ USING: kernel namespaces sequences sequences.private assocs math
 inference.transforms parser words quotations debugger macros
 arrays macros splitting combinators prettyprint.backend
 definitions prettyprint hashtables combinators.lib
-prettyprint.sections sequences.private ;
+prettyprint.sections sequences.private effects generic
+compiler.units ;
 IN: locals
 
 ! Inspired by
@@ -208,9 +209,6 @@ M: object local-rewrite* , ;
 : push-locals ( assoc -- )
     use get push ;
 
-: parse-locals ( -- words assoc )
-    "|" parse-tokens make-locals ;
-
 : pop-locals ( assoc -- )
     use get delete ;
 
@@ -218,7 +216,7 @@ M: object local-rewrite* , ;
     over push-locals parse-until >quotation swap pop-locals ;
 
 : parse-lambda ( -- lambda )
-    parse-locals \ ] (parse-lambda) <lambda> ;
+    "|" parse-tokens make-locals \ ] (parse-lambda) <lambda> ;
 
 : (parse-bindings) ( -- )
     scan dup "|" = [
@@ -246,11 +244,18 @@ M: wlet local-rewrite*
     dup wlet-bindings values over wlet-vars rot wlet-body
     <lambda> [ call ] curry compose local-rewrite* \ call , ;
 
-: (::) ( prop -- word quot n )
+: parse-locals
-    >r CREATE dup reset-generic
+    parse-effect
-    scan "|" assert= parse-locals \ ; (parse-lambda) <lambda>
+    word [ over "declared-effect" set-word-prop ] when*
-    2dup r> set-word-prop
+    effect-in make-locals ;
-    [ lambda-rewrite first ] keep lambda-vars length ;
+
+: ((::)) ( word -- word quot )
+    scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
+    2dup "lambda" set-word-prop
+    lambda-rewrite first ;
+
+: (::) ( -- word quot )
+    CREATE dup reset-generic ((::)) ;
 
 PRIVATE>
 
@@ -268,9 +273,22 @@ PRIVATE>
 
 MACRO: with-locals ( form -- quot ) lambda-rewrite ;
 
-: :: "lambda" (::) drop define ; parsing
+: :: (::) define ; parsing
 
-: MACRO:: "lambda-macro" (::) (MACRO:) ; parsing
+! This will be cleaned up when method tuples and method words
+! are unified
+: create-method ( class generic -- method )
+    2dup method dup
+    [ 2nip method-word ]
+    [ 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
 
 <PRIVATE
 
@@ -323,26 +341,42 @@ M: lambda-word definer drop \ :: \ ; ;
 M: lambda-word definition
     "lambda" word-prop lambda-body ;
 
-: lambda-word-synopsis ( word prop -- )
+: lambda-word-synopsis ( word -- )
-    over definer.
+    dup definer.
-    over seeing-word
+    dup seeing-word
-    over pprint-word
+    dup pprint-word
-    \ | pprint-word
+    stack-effect. ;
-    word-prop lambda-vars pprint-vars
-    \ | pprint-word ;
 
-M: lambda-word synopsis*
+M: lambda-word synopsis* lambda-word-synopsis ;
-    "lambda" lambda-word-synopsis ;
 
 PREDICATE: macro lambda-macro
-    "lambda-macro" word-prop >boolean ;
+    "lambda" word-prop >boolean ;
 
 M: lambda-macro definer drop \ MACRO:: \ ; ;
 
 M: lambda-macro definition
-    "lambda-macro" word-prop lambda-body ;
+    "lambda" word-prop lambda-body ;
 
-M: lambda-macro synopsis*
+M: lambda-macro synopsis* lambda-word-synopsis ;
-    "lambda-macro" lambda-word-synopsis ;
+
+PREDICATE: method-body lambda-method
+    "lambda" word-prop >boolean ;
+
+M: lambda-method definer drop \ M:: \ ; ;
+
+M: lambda-method definition
+    "lambda" word-prop lambda-body ;
+
+: method-stack-effect
+    dup "lambda" word-prop lambda-vars
+    swap "method" word-prop method-generic stack-effect dup [ effect-out ] when
+    <effect> ;
+
+M: lambda-method synopsis*
+    dup definer.
+    dup "method" word-prop dup
+        method-specializer pprint*
+        method-generic pprint*
+    method-stack-effect effect>string comment. ;
 
 PRIVATE>

extra/macros/macros.factor

@@ -1,26 +1,21 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2008 Slava Pestov.
 ! See http://factorcode.org/license.txt for BSD license.
-
+USING: parser kernel sequences words effects
-USING: parser kernel sequences words effects inference.transforms
+inference.transforms combinators assocs definitions quotations
-combinators assocs definitions quotations namespaces memoize ;
+namespaces memoize ;
-
 IN: macros
 
-: (:) ( -- word definition effect-in )
-    CREATE dup reset-generic parse-definition
-    over "declared-effect" word-prop effect-in length ;
-
 : real-macro-effect ( word -- effect' )
     "declared-effect" word-prop effect-in 1 <effect> ;
 
-: (MACRO:) ( word definition effect-in -- )
+: define-macro ( word definition -- )
-    >r 2dup "macro" set-word-prop
+    over "declared-effect" word-prop effect-in length >r
-    2dup over real-macro-effect memoize-quot
+    2dup "macro" set-word-prop
-    [ call ] append define
+    2dup over real-macro-effect memoize-quot [ call ] append define
     r> define-transform ;
 
 : MACRO:
-    (:) (MACRO:) ; parsing
+    (:) define-macro ; parsing
 
 PREDICATE: word macro "macro" word-prop >boolean ;
 

extra/math/miller-rabin/miller-rabin.factor

@@ -30,7 +30,7 @@ TUPLE: positive-even-expected n ;
     #! factor an integer into s * 2^r
     0 swap (factor-2s) ;
 
-:: (miller-rabin) | n prime?! |
+:: (miller-rabin) ( n prime?! -- ? )
     n 1- factor-2s s set r set
     trials get [
         n 1- [1,b] random a set

extra/tools/walker/debug/debug.factor

@@ -5,7 +5,7 @@ sequences concurrency.messaging locals continuations
 threads namespaces namespaces.private ;
 IN: tools.walker.debug
 
-:: test-walker | quot |
+:: test-walker ( quot -- data )
     [let | p [ <promise> ]
            s [ f <model> ]
            c [ f <model> ] |