generic.factor cleanups; started generalized dispatching

factor/jedit/FactorPlugin.java

@@ -447,6 +447,8 @@ public class FactorPlugin extends EditPlugin
 		String decl = "USE: " + vocab;
 		if(leadingNewline)
 			decl = "\n" + decl;
+		if(lastUseOffset == 0)
+			decl = decl + "\n";
 		buffer.insert(lastUseOffset,decl);
 		showStatus(view,"inserted-use",decl);
 	} //}}}

library/bootstrap/boot-stage2.factor

@@ -36,6 +36,7 @@ USE: stdio
     "/version.factor"
     "/library/kernel.factor"
     "/library/stack.factor"
+    "/library/generic.factor"
     "/library/types.factor"
     "/library/math/math.factor"
     "/library/cons.factor"
@@ -50,7 +51,6 @@ USE: stdio
     "/library/strings.factor"
     "/library/hashtables.factor"
     "/library/namespaces.factor"
-    "/library/generic.factor"
     "/library/list-namespaces.factor"
     "/library/sbuf.factor"
     "/library/continuations.factor"

library/bootstrap/boot.factor

@@ -38,6 +38,7 @@ primitives,
     "/version.factor"
     "/library/stack.factor"
     "/library/kernel.factor"
+    "/library/generic.factor"
     "/library/types.factor"
     "/library/combinators.factor"
     "/library/math/math.factor"
@@ -52,7 +53,6 @@ primitives,
     "/library/strings.factor"
     "/library/hashtables.factor"
     "/library/namespaces.factor"
-    "/library/generic.factor"
     "/library/list-namespaces.factor"
     "/library/sbuf.factor"
     "/library/continuations.factor"

library/bootstrap/image.factor

@@ -42,7 +42,6 @@ IN: image
 USE: errors
 USE: hashtables
 USE: kernel
-USE: kernel-internals
 USE: lists
 USE: math
 USE: namespaces
@@ -84,6 +83,26 @@ SYMBOL: boot-quot
 : untag ( cell tag -- ) tag-mask bitnot bitand ;
 : tag ( cell -- tag ) tag-mask bitand ;
 
+: fixnum-tag  BIN: 000 ; inline
+: word-tag    BIN: 001 ; inline
+: cons-tag    BIN: 010 ; inline
+: object-tag  BIN: 011 ; inline
+: ratio-tag   BIN: 100 ; inline
+: complex-tag BIN: 101 ; inline
+: header-tag  BIN: 110 ; inline
+
+: f-type      6  ; inline
+: t-type      7  ; inline
+: array-type  8  ; inline
+: bignum-type 9  ; inline
+: float-type  10 ; inline
+: vector-type 11 ; inline
+: string-type 12 ; inline
+: sbuf-type   13 ; inline
+: port-type   14 ; inline
+: dll-type    15 ; inline
+: alien-type  16 ; inline
+
 : immediate ( x tag -- tagged ) swap tag-bits shift bitor ;
 : >header ( id -- tagged ) header-tag immediate ;
 
@@ -135,14 +154,14 @@ SYMBOL: boot-quot
 ( Bignums )
 
 : emit-bignum ( bignum -- tagged )
+    #! This can only emit 0, -1 and 1.
     object-tag here-as >r
     bignum-type >header emit
-    dup 0 = 1 2 ? emit ( capacity )
     [
-        [ 0 = ] [ emit pad ]
+        [ 0  | [ 1 0   ] ]
-        [ 0 < ] [ 1 emit neg emit ]
+        [ -1 | [ 2 1 1 ] ]
-        [ 0 > ] [ 0 emit     emit ]
+        [ 1  | [ 2 0 1 ] ]
-    ] cond r> ;
+    ] assoc [ emit ] each pad r> ;
 
 ( Special objects )
 

library/compiler/linearizer.factor

@@ -86,10 +86,16 @@ SYMBOL: #return-to ( push addr on C stack )
 : label, ( label -- )
     #label swons , ;
 
-: (linearize-label) ( node -- )
+: linearize-simple-label ( node -- )
+    #! Some labels become simple labels after the optimization
+    #! stage.
     dup [ node-label get ] bind label,
     [ node-param get ] bind (linearize) ;
 
+#simple-label [
+    linearize-simple-label
+] "linearizer" set-word-property
+
 : linearize-label ( node -- )
     #! Labels are tricky, because they might contain non-tail
     #! calls. So we push the address of the location right after
@@ -98,11 +104,13 @@ SYMBOL: #return-to ( push addr on C stack )
     #! this in the common case where the labelled block does
     #! not contain non-tail recursive calls to itself.
     <label> dup #return-to swons , >r
-    (linearize-label)
+    linearize-simple-label
     [ #return ] ,
     r> label, ;
 
-#label [ linearize-label ] "linearizer" set-word-property
+#label [
+    linearize-label
+] "linearizer" set-word-property
 
 : linearize-ifte ( param -- )
     #! The parameter is a list of two lists, each one a dataflow

library/compiler/optimizer.factor

@@ -129,20 +129,23 @@ USE: prettyprint
     [ node-param get ] bind can-kill?
 ] "can-kill" set-word-property
 
-: (calls-label?) ( label node -- ? )
-    "calls-label" [ 2drop f ] apply-dataflow ;
-
 #call-label [
     [ node-param get ] bind =
 ] "calls-label" set-word-property
 
 : calls-label? ( label list -- ? )
-    [ dupd (calls-label?) ] some? nip ;
+    [
+        dupd "calls-label" [ 2drop f ] apply-dataflow
+    ] some? nip ;
 
 #label [
     [ node-param get ] bind calls-label?
 ] "calls-label" set-word-property
 
+#simple-label [
+    [ node-param get ] bind calls-label?
+] "calls-label" set-word-property
+
 : branches-call-label? ( label list -- ? )
     [ dupd calls-label? ] some? nip ;
 
@@ -158,17 +161,16 @@ USE: prettyprint
     [ node-param get ] bind branches-call-label?
 ] "calls-label" set-word-property
 
-: recursive-label? ( node -- ? )
+: optimize-label ( -- op )
     #! Does the label node contain calls to itself?
-    [ node-label get node-param get ] bind
+    node-label get node-param get calls-label?
-    calls-label? ;
+    #label #simple-label ? ;
 
 #label [ ( literals node -- )
-    dup recursive-label? [
+    [
-       [ node-param [ kill-nodes ] change ] extend ,
+        optimize-label node-op set
-    ] [
+        node-param [ kill-nodes ] change
-       [ node-param get ] bind (kill-nodes)
+    ] extend ,
-    ] ifte
 ] "kill-node" set-word-property
 
 #ifte [ scan-branches ] "scan-literal" set-word-property

library/generic.factor

@@ -37,7 +37,23 @@ USE: strings
 USE: words
 USE: vectors
 
-! A simple prototype-based generic word system.
+! A simple single-dispatch generic word system.
+
+: predicate-word ( word -- word )
+    word-name "?" cat2 "in" get create ;
+
+: builtin-predicate ( symbol type# -- )
+    [ swap type eq? ] cons >r predicate-word r> define-compound ;
+
+: BUILTIN:
+    #! Followed by type name and type number. Define a built-in
+    #! type predicate with this number.
+    CREATE dup undefined? [ dup define-symbol ] when scan-word
+    2dup builtin-predicate
+    "builtin-type" set-word-property ; parsing
+
+: builtin-type ( symbol -- n )
+    "builtin-type" word-property ;
 
 ! Hashtable slot holding a selector->method map.
 SYMBOL: traits
@@ -63,7 +79,7 @@ SYMBOL: delegate
 : undefined-method
     "No applicable method." throw ;
 
-: method ( selector traits -- traits quot )
+: traits-method ( selector traits -- traits quot )
     #! Look up the method with the traits object on the stack.
     #! Returns the traits to call the method on; either the
     #! original object, or one of the delegates.
@@ -71,20 +87,17 @@ SYMBOL: delegate
         rot drop cdr ( method is defined )
     ] [
         drop delegate swap hash* dup [
-            cdr method ( check delegate )
+            cdr traits-method ( check delegate )
         ] [
             drop [ undefined-method ] ( no delegate )
         ] ifte
     ] ifte ;
 
-: predicate-word ( word -- word )
+: traits-predicate ( word -- )
-    word-name "?" cat2 "in" get create ;
-
-: define-predicate ( word -- )
     #! foo? where foo is a traits type tests if the top of stack
     #! is of this type.
     dup predicate-word swap
-    [ object-map ] swap traits-map [ eq? ] cons append
+    traits-map [ swap object-map eq? ] cons
     define-compound ;
 
 : TRAITS:
@@ -93,15 +106,26 @@ SYMBOL: delegate
     CREATE
     dup define-symbol
     dup init-traits-map
-    define-predicate ; parsing
+    traits-predicate ; parsing
+
+: add-method ( quot class vtable -- )
+    >r "builtin-type" word-property r>
+    set-vector-nth ;
+
+: <vtable> ( word -- vtable )
+    num-types [ drop [ undefined-method ] ] vector-project
+    [ "vtable" set-word-property ] keep ;
+
+: add-traits-dispatch ( word vtable -- )
+    >r unit [ car swap traits-method call ] cons \ vector r>
+    add-method ;
 
 : GENERIC:
     #! GENERIC: bar creates a generic word bar that calls the
     #! bar method on the traits object, with the traits object
     #! on the stack.
-    CREATE
+    CREATE dup <vtable> 2dup add-traits-dispatch
-    dup unit [ car swap method call ] cons
+    [ generic ] cons define-compound ; parsing
-    define-compound ; parsing
 
 : constructor-word ( word -- word )
     word-name "<" swap ">" cat3 "in" get create ;
@@ -111,23 +135,18 @@ SYMBOL: delegate
     traits-map [ traits pick set-hash ] cons append
     define-compound ;
 
-: C: ( -- word [ ] )
+: (;C) ( constructor traits definition -- )
-    #! C: foo ... begins definition for <foo> where foo is a
+    >r
-    #! traits type. We have to reverse the list at the end,
+    traits-map [ traits pick set-hash ] cons \ <namespace> swons
-    #! since the parser conses onto the list, and it will be
+    r> append define-compound ;
-    #! reversed again by ;C.
-    scan-word [ constructor-word [ <namespace> ] ] keep
-    traits-map [ traits pick set-hash ] cons append reverse ;
-    parsing
 
-: ;C ( word [ ] -- )
+: C: ( -- constructor traits [ ] )
-    POSTPONE: ; ; parsing
+    #! C: foo ... begins definition for <foo> where foo is a
+    #! traits type.
+    scan-word [ constructor-word ] keep [ (;C) ] [ ] ; parsing
 
 : M: ( -- type generic [ ] )
     #! M: foo bar begins a definition of the bar generic word
     #! specialized to the foo type.
-    scan-word scan-word f ; parsing
+    scan-word scan-word [ rot traits-map [ put ] bind ] [ ] ;
-
+    parsing
-: ;M ( type generic def -- )
-    #! ;M ends a method definition.
-    rot traits-map [ reverse put ] bind ; parsing

library/httpd/html.factor

@@ -143,7 +143,7 @@ M: html-stream fwrite-attr ( str style stream -- )
                 ] file-link-tag
             ] object-link-tag
         ] icon-tag
-    ] bind ;M
+    ] bind ;
 
 C: html-stream ( stream -- stream )
     #! Wraps the given stream in an HTML stream. An HTML stream
@@ -159,7 +159,7 @@ C: html-stream ( stream -- stream )
     #! underline
     #! size
     #! link - an object path
-    [ dup delegate set stdio set ] extend ;C
+    [ dup delegate set stdio set ] extend ;
 
 : with-html-stream ( quot -- )
     [ stdio [ <html-stream> ] change  call ] with-scope ;

library/inference/dataflow.factor

@@ -40,6 +40,11 @@ SYMBOL: dataflow-graph
 ! Label nodes have the node-label variable set.
 SYMBOL: #label
 
+! A label that is not called recursively at all, or only tail
+! recursively. The optimizer changes some #labels to
+! #simple-labels.
+SYMBOL: #simple-label
+
 SYMBOL: #call ( non-tail call )
 SYMBOL: #call-label
 SYMBOL: #push ( literal )

library/io/ansi.factor

@@ -82,7 +82,7 @@ M: ansi-stream fwrite-attr ( string style stream -- )
     [
         [ default-style ] unless* ansi-attr-string
         delegate get fwrite
-    ] bind ;M
+    ] bind ;
 
 C: ansi-stream ( stream -- stream )
     #! Wraps the given stream in an ANSI stream. ANSI streams

library/io/network.factor

@@ -39,13 +39,13 @@ USE: generic
 TRAITS: server
 
 M: server fclose ( stream -- )
-    [ "socket" get close-port ] bind ;M
+    [ "socket" get close-port ] bind ;
 
 C: server ( port -- stream )
     #! Starts listening on localhost:port. Returns a stream that
     #! you can close with fclose, and accept connections from
     #! with accept. No other stream operations are supported.
-    [ server-socket "socket" set ] extend ;C
+    [ server-socket "socket" set ] extend ;
 
 : <client-stream> ( host port in out -- stream )
     <fd-stream> [ ":" swap unparse cat3 "client" set ] extend ;

library/io/stdio.factor

@@ -63,10 +63,10 @@ SYMBOL: stdio
 TRAITS: stdio-stream
 
 M: stdio-stream fauto-flush ( -- )
-    [ delegate get fflush ] bind ;M
+    [ delegate get fflush ] bind ;
 
 M: stdio-stream fclose ( -- )
-    drop ;M
+    drop ;
 
 C: stdio-stream ( delegate -- stream )
-    [ delegate set ] extend ;C
+    [ delegate set ] extend ;

library/io/stream-impl.factor

@@ -41,28 +41,28 @@ USE: generic
 TRAITS: fd-stream
 
 M: fd-stream fwrite-attr ( str style stream -- )
-    [ drop "out" get blocking-write ] bind ;M
+    [ drop "out" get blocking-write ] bind ;
 
 M: fd-stream freadln ( stream -- str )
-    [ "in" get dup [ blocking-read-line ] when ] bind ;M
+    [ "in" get dup [ blocking-read-line ] when ] bind ;
 
 M: fd-stream fread# ( count stream -- str )
-    [ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ;M
+    [ "in" get dup [ blocking-read# ] [ nip ] ifte ] bind ;
 
 M: fd-stream fflush ( stream -- )
-    [ "out" get [ blocking-flush ] when* ] bind ;M
+    [ "out" get [ blocking-flush ] when* ] bind ;
 
 M: fd-stream fauto-flush ( stream -- )
-    drop ;M
+    drop ;
 
 M: fd-stream fclose ( -- )
     [
         "out" get [ dup blocking-flush close-port ] when*
         "in" get [ close-port ] when*
-    ] bind ;M
+    ] bind ;
 
 C: fd-stream ( in out -- stream )
-    [ "out" set "in" set ] extend ;C
+    [ "out" set "in" set ] extend ;
 
 : <filecr> ( path -- stream )
     t f open-file <fd-stream> ;

library/io/stream.factor

@@ -51,16 +51,16 @@ GENERIC: fclose      ( stream -- )
 TRAITS: string-output-stream
 
 M: string-output-stream fwrite-attr ( string style stream -- )
-    [ drop "buf" get sbuf-append ] bind ;M
+    [ drop "buf" get sbuf-append ] bind ;
 
 M: string-output-stream fclose ( stream -- )
-    drop ;M
+    drop ;
 
 M: string-output-stream fflush ( stream -- )
-    drop ;M
+    drop ;
 
 M: string-output-stream fauto-flush ( stream -- )
-    drop ;M
+    drop ;
 
 : stream>str ( stream -- string )
     #! Returns the string written to the given string output
@@ -69,4 +69,4 @@ M: string-output-stream fauto-flush ( stream -- )
 
 C: string-output-stream ( size -- stream )
     #! Creates a new stream for writing to a string buffer.
-    [ <sbuf> "buf" set ] extend ;C
+    [ <sbuf> "buf" set ] extend ;

library/strings.factor

@@ -151,10 +151,7 @@ USE: math
 : url-quotable? ( ch -- ? )
     #! In a URL, can this character be used without
     #! URL-encoding?
-    [
+    dup letter?
-        [ letter?              ] [ drop t ]
+    over LETTER? or
-        [ LETTER?              ] [ drop t ]
+    over digit? or
-        [ digit?               ] [ drop t ]
+    swap "/_?." str-contains? or ;
-        [ "/_?." str-contains? ] [ drop t ]
-        [                      ] [ drop f ]
-    ] cond ;

library/syntax/parse-syntax.factor

@@ -144,11 +144,11 @@ IN: syntax
 
 : :
     #! Begin a word definition. Word name follows.
-    CREATE [ ] "in-definition" on ; parsing
+    CREATE [ define-compound ] [ ] "in-definition" on ; parsing
 
 : ;
     #! End a word definition.
-    "in-definition" off reverse define-compound ; parsing
+    "in-definition" off reverse swap call ; parsing
 
 ! Symbols
 : SYMBOL:

library/test/generic.factor

@@ -6,7 +6,7 @@ USE: test
 USE: kernel
 
 TRAITS: test-traits
-C: test-traits ;C
+C: test-traits ;
 
 [ t ] [ <test-traits> test-traits? ] unit-test
 [ f ] [ "hello" test-traits? ] unit-test
@@ -14,20 +14,20 @@ C: test-traits ;C
 
 GENERIC: foo
 
-M: test-traits foo drop 12 ;M
+M: test-traits foo drop 12 ;
 
 TRAITS: another-test
-C: another-test ;C
+C: another-test ;
 
-M: another-test foo drop 13 ;M
+M: another-test foo drop 13 ;
 
 [ 12 ] [ <test-traits> foo ] unit-test
 [ 13 ] [ <another-test> foo ] unit-test
 
 TRAITS: quux
-C: quux ;C
+C: quux ;
 
-M: quux foo "foo" swap hash ;M
+M: quux foo "foo" swap hash ;
 
 [
     "Hi"
@@ -38,7 +38,7 @@ M: quux foo "foo" swap hash ;M
 ] unit-test
 
 TRAITS: ctr-test
-C: ctr-test [ 5 "x" set ] extend ;C
+C: ctr-test [ 5 "x" set ] extend ;
 
 [
     5
@@ -47,12 +47,12 @@ C: ctr-test [ 5 "x" set ] extend ;C
 ] unit-test
 
 TRAITS: del1
-C: del1 ;C
+C: del1 ;
 
 GENERIC: super
-M: del1 super drop 5 ;M
+M: del1 super drop 5 ;
 
 TRAITS: del2
-C: del2 ( delegate -- del2 ) [ delegate set ] extend ;C
+C: del2 ( delegate -- del2 ) [ delegate set ] extend ;
 
 [ 5 ] [ <del1> <del2> super ] unit-test

library/test/lists/assoc.factor

@@ -45,6 +45,3 @@ USE: test
 [ [ [ "one" + ] [ "four" * ] ] ] [
     "three" "quot-alist" get remove-assoc
 ] unit-test
-
-[ [ "one" "three" "four" ] [ [ + ] [ - ] [ * ] ] ]
-[ "quot-alist" get unzip ] unit-test

library/test/lists/cons.factor

@@ -25,11 +25,3 @@ USE: test
 
 [ [ 1 2 ]   ] [ 1 2   2list  ] unit-test
 [ [ 1 2 3 ] ] [ 1 2 3 3list  ] unit-test
-
-[ [ "car1" | "cdr1" ] [ "car2" | "cdr2" ] ]
-[ "car1" "car2" "cdr1" "cdr2" 2cons ]
-unit-test
-
-[ [ "car1" | "cdr1" ] [ "car2" | "cdr2" ] ]
-[ "cdr1" "cdr2" "car1" "car2" 2swons ]
-unit-test

library/test/stream.factor

@@ -15,19 +15,19 @@ M: xyzzy-stream fwrite-attr ( str style stream -- )
         drop "<" delegate get fwrite
         delegate get fwrite
         ">" delegate get fwrite
-    ] bind ;M
+    ] bind ;
 
 M: xyzzy-stream fclose ( stream -- )
-    drop ;M
+    drop ;
 
 M: xyzzy-stream fflush ( stream -- )
-    drop ;M
+    drop ;
 
 M: xyzzy-stream fauto-flush ( stream -- )
-    drop ;M
+    drop ;
 
 C: xyzzy-stream ( stream -- stream )
-    [ delegate set ] extend ;C
+    [ delegate set ] extend ;
 
 [
     "<xyzzy>"

library/tools/jedit-wire.factor

@@ -80,16 +80,16 @@ USE: listener
 TRAITS: jedit-stream
 
 M: jedit-stream freadln ( stream -- str )
-    [ CHAR: r write flush read-big-endian-32 read# ] bind ;M
+    [ CHAR: r write flush read-big-endian-32 read# ] bind ;
 
 M: jedit-stream fwrite-attr ( str style stream -- )
-    [ [ default-style ] unless* jedit-write-attr ] bind ;M
+    [ [ default-style ] unless* jedit-write-attr ] bind ;
 
 M: jedit-stream fflush ( stream -- )
-    [ CHAR: f write flush ] bind ;M
+    [ CHAR: f write flush ] bind ;
 
 C: jedit-stream ( stream -- stream )
-    [ dup delegate set stdio set ] extend ;C
+    [ dup delegate set stdio set ] extend ;
 
 : stream-server ( -- )
     #! Execute this in the inferior Factor.

library/types.factor

@@ -27,42 +27,22 @@
 
 USE: kernel
 USE: math
+USE: generic
 
-IN: kernel-internals
+IN: vectors SYMBOL: vector
-
+IN: math         BUILTIN: fixnum  0
-: fixnum-tag  BIN: 000 ; inline
+IN: words        BUILTIN: word    1
-: word-tag    BIN: 001 ; inline
+IN: lists        BUILTIN: cons    2
-: cons-tag    BIN: 010 ; inline
+IN: math         BUILTIN: ratio   4
-: object-tag  BIN: 011 ; inline
+IN: math         BUILTIN: complex 5
-: ratio-tag   BIN: 100 ; inline
+IN: math         BUILTIN: bignum  9
-: complex-tag BIN: 101 ; inline
+IN: math         BUILTIN: float   10
-: header-tag  BIN: 110 ; inline
+IN: vectors      BUILTIN: vector  11
-
+IN: strings      BUILTIN: string  12
-: f-type      6  ; inline
+IN: strings      BUILTIN: sbuf    13
-: t-type      7  ; inline
+IN: io-internals BUILTIN: port    14
-: array-type  8  ; inline
+IN: alien        BUILTIN: dll     15
-: bignum-type 9  ; inline
+IN: alien        BUILTIN: alien   16
-: float-type  10 ; inline
-: vector-type 11 ; inline
-: string-type 12 ; inline
-: sbuf-type   13 ; inline
-: port-type   14 ; inline
-: dll-type    15 ; inline
-: alien-type  16 ; inline
-
-IN: math         : fixnum?  ( obj -- ? ) type fixnum-tag  eq? ;
-IN: words        : word?    ( obj -- ? ) type word-tag    eq? ;
-IN: lists        : cons?    ( obj -- ? ) type cons-tag    eq? ;
-IN: math         : ratio?   ( obj -- ? ) type ratio-tag   eq? ;
-IN: math         : complex? ( obj -- ? ) type complex-tag eq? ;
-IN: math         : bignum?  ( obj -- ? ) type bignum-type eq? ;
-IN: math         : float?   ( obj -- ? ) type float-type  eq? ;
-IN: vectors      : vector?  ( obj -- ? ) type vector-type eq? ;
-IN: strings      : string?  ( obj -- ? ) type string-type eq? ;
-IN: strings      : sbuf?    ( obj -- ? ) type sbuf-type   eq? ;
-IN: io-internals : port?    ( obj -- ? ) type port-type   eq? ;
-IN: alien        : dll?     ( obj -- ? ) type dll-type    eq? ;
-IN: alien        : alien?   ( obj -- ? ) type alien-type  eq? ;
 
 IN: kernel
 

library/words.factor

@@ -42,11 +42,12 @@ USE: strings
     swap set-word-plist ;
 
 : ?word-primitive ( obj -- prim/0 )
-    dup word? [ word-primitive ] [ drop 0 ] ifte ;
+    dup word? [ word-primitive ] [ drop -1 ] ifte ;
 
 : compound?  ( obj -- ? ) ?word-primitive 1 = ;
 : primitive? ( obj -- ? ) ?word-primitive 2 > ;
 : symbol?    ( obj -- ? ) ?word-primitive 2 = ;
+: undefined? ( obj -- ? ) ?word-primitive 0 = ;
 
 : word ( -- word ) global [ "last-word" get ] bind ;
 : set-word ( word -- ) global [ "last-word" set ] bind ;