see works with generics

TODO.FACTOR.txt

@@ -19,7 +19,7 @@
 
 + oop:
 
-- make see work with generics
+- make see work with union, builtin, predicate
 - doc comments of generics
 - redo traits with generic method map
 

factor/jedit/FactorPlugin.java

@@ -121,10 +121,6 @@ public class FactorPlugin extends EditPlugin
 					new String[args.size()]));
 
 				external = new ExternalFactor(PORT);
-
-				process.getErrorStream().close();
-				process.getInputStream().close();
-				process.getOutputStream().close();
 			}
 			catch(Exception e)
 			{
@@ -157,6 +153,9 @@ public class FactorPlugin extends EditPlugin
 			external.close();
 			try
 			{
+				process.getErrorStream().close();
+				process.getInputStream().close();
+				process.getOutputStream().close();
 				process.waitFor();
 			}
 			catch(Exception e)
@@ -164,6 +163,7 @@ public class FactorPlugin extends EditPlugin
 				Log.log(Log.DEBUG,FactorPlugin.class,e);
 			}
 			external = null;
+			process = null;
 		}
 	} //}}}
 	

factor/jedit/FactorShell.java

@@ -82,6 +82,7 @@ public class FactorShell extends Shell
 		try
 		{
 			state = getConsoleState(console);
+			state.openStream();
 			state.packetLoop(output);
 		}
 		catch(Exception e)
@@ -210,14 +211,14 @@ public class FactorShell extends Shell
 			}
 			else
 			{
-				/* try
+				try
 				{
 					packetLoop(output);
 				}
 				catch(Exception e)
 				{
 					Log.log(Log.ERROR,this,e);
-				} */
+				}
 			}
 		}
 
@@ -264,8 +265,6 @@ public class FactorShell extends Shell
 			if(waitingForInput)
 				return;
 
-			openStream();
-
 			if(stream == null)
 				return;
 

library/generic/builtin.factor

@@ -50,6 +50,9 @@ builtin [
 
 builtin 50 "priority" set-word-property
 
+! All builtin types are equivalent in ordering
+builtin [ 2drop t ] "class<" set-word-property
+
 : builtin-predicate ( type# symbol -- )
     over f type = [
         nip [ not ] "predicate" set-word-property

library/generic/generic.factor

@@ -80,10 +80,14 @@ USE: math-internals
 : class-ord ( class -- n ) metaclass "priority" word-property ;
 
 : class< ( cls1 cls2 -- ? )
-    swap class-ord swap class-ord < ;
+    over metaclass over metaclass = [
+        dup metaclass "class<" word-property call
+    ] [
+        swap class-ord swap class-ord <
+    ] ifte ;
 
-: sort-methods ( methods -- alist )
+: methods ( generic -- alist )
-    hash>alist [ 2car class< ] sort ;
+    "methods" word-property hash>alist [ 2car class< ] sort ;
 
 : add-method ( generic vtable definition class -- )
     #! Add the method entry to the vtable. Unlike define-method,
@@ -95,8 +99,9 @@ USE: math-internals
 : <empty-vtable> ( -- vtable )
     num-types [ drop [ undefined-method ] ] vector-project ;
 
-: <vtable> ( generic methods -- vtable )
+: <vtable> ( generic -- vtable )
-    >r <empty-vtable> r> sort-methods [
+    <empty-vtable> over methods [
+        ( generic vtable method )
         >r 2dup r> unswons add-method
     ] each nip ;
 
@@ -104,21 +109,28 @@ USE: math-internals
     over "combination" word-property cons define-compound ;
 
 : (define-method) ( definition class generic -- )
-    [ "methods" word-property set-hash ] keep
+    [ "methods" word-property set-hash ] keep dup <vtable>
-    dup dup "methods" word-property <vtable>
     define-generic ;
 
+: init-methods ( word -- )
+     dup "methods" word-property [
+         drop
+     ] [
+        <namespace> "methods" set-word-property
+     ] ifte ;
+
 ! Defining generic words
-: (GENERIC) ( combination -- )
+: (GENERIC) ( combination definer -- )
     #! Takes a combination parameter. A combination is a
     #! quotation that takes some objects and a vtable from the
     #! stack, and calls the appropriate row of the vtable.
-    CREATE [ swap "combination" set-word-property ] keep
+    CREATE
-    dup dup "methods" word-property [
+    [ swap "definer" set-word-property ] keep
-        dup <namespace> [ "methods" set-word-property ] keep
+    [ swap "combination" set-word-property ] keep
-    ] unless* <vtable> define-generic ;
+    dup init-methods
+    dup <vtable> define-generic ;
 
-PREDICATE: word generic ( word -- ? )
+PREDICATE: compound generic ( word -- ? )
     "combination" word-property ;
 
 : single-combination ( obj vtable -- )
@@ -127,7 +139,7 @@ PREDICATE: word generic ( word -- ? )
 : GENERIC:
     #! GENERIC: bar creates a generic word bar. Add methods to
     #! the generic word using M:.
-    [ single-combination ] (GENERIC) ; parsing
+    [ single-combination ] \ GENERIC: (GENERIC) ; parsing
 
 : arithmetic-combination ( n n vtable -- )
     #! Note that the numbers remain on the stack, possibly after
@@ -139,7 +151,7 @@ PREDICATE: word generic ( word -- ? )
     #! the generic word using M:. 2GENERIC words dispatch on
     #! arithmetic types and should not be used for non-numerical
     #! types.
-    [ arithmetic-combination ] (GENERIC) ; parsing
+    [ arithmetic-combination ] \ 2GENERIC: (GENERIC) ; parsing
 
 : define-method ( class -- quotation )
     #! In a vain attempt at something resembling a "meta object

library/generic/object.factor

@@ -55,4 +55,6 @@ object [ drop t ] "predicate" set-word-property
 
 object 100 "priority" set-word-property
 
+object [ 2drop t ] "class<" set-word-property
+
 object object define-class

library/generic/predicate.factor

@@ -65,6 +65,14 @@ predicate [
 
 predicate 25 "priority" set-word-property
 
+predicate [
+    2dup = [
+        2drop t
+    ] [
+        >r "superclass" word-property r> class<
+    ] ifte
+] "class<" set-word-property
+
 : define-predicate ( class predicate definition -- )
     rot "superclass" word-property "predicate" word-property
     [ \ dup , append, , [ drop f ] , \ ifte , ] make-list

library/generic/traits.factor

@@ -92,6 +92,8 @@ traits [
 
 traits 10 "priority" set-word-property
 
+traits [ 2drop t ] "class<" set-word-property
+
 : init-traits-map ( word -- )
     <namespace> "traits-map" set-word-property ;
 

library/generic/union.factor

@@ -52,6 +52,8 @@ union [
 
 union 30 "priority" set-word-property
 
+union [ 2drop t ] "class<" set-word-property
+
 : union-predicate ( definition -- list )
     [
         [

library/syntax/prettyprint.factor

@@ -58,20 +58,17 @@ M: object prettyprint* ( indent obj -- indent )
 : prettyprint-newline ( indent -- )
     "\n" write indent ;
 
-: prettyprint-space ( -- )
-    " " write ;
-
 : prettyprint-element ( indent obj -- indent )
     over prettyprint-limit get >= [
         unparse write
     ] [
         prettyprint*
-    ] ifte prettyprint-space ;
+    ] ifte " " write ;
 
 : <prettyprint ( indent -- indent )
     tab-size +
     "prettyprint-single-line" get [
-        prettyprint-space
+        " " write
     ] [
         dup prettyprint-newline
     ] ifte ;
@@ -128,7 +125,7 @@ M: word prettyprint* ( indent word -- indent )
         ] [
             [
                 \ | prettyprint*
-                prettyprint-space prettyprint-element
+                " " write prettyprint-element
             ] when*
         ] ifte
     ] when* ;
@@ -150,7 +147,7 @@ M: vector prettyprint* ( indent vector -- indent )
     dup vector-length 0 = [
         drop
         \ { prettyprint*
-        prettyprint-space
+        " " write
         \ } prettyprint*
     ] [
         swap prettyprint-{ swap prettyprint-vector prettyprint-}
@@ -166,7 +163,7 @@ M: hashtable prettyprint* ( indent hashtable -- indent )
     hash>alist dup length 0 = [
         drop
         \ {{ prettyprint*
-        prettyprint-space 
+        " " write 
         \ }} prettyprint*
     ] [
         swap prettyprint-{{ swap prettyprint-list prettyprint-}}

library/syntax/see.factor

@@ -53,11 +53,11 @@ USE: words
     dup vocab-attrs write-attr ;
 
 : prettyprint-IN: ( word -- )
-    \ IN: prettyprint* prettyprint-space
+    \ IN: prettyprint* " " write
-    word-vocabulary prettyprint-vocab prettyprint-space ;
+    word-vocabulary prettyprint-vocab " " write ;
 
 : prettyprint-: ( indent -- indent )
-    \ : prettyprint* prettyprint-space
+    \ : prettyprint* " " write
     tab-size + ;
 
 : prettyprint-; ( indent -- indent )
@@ -66,7 +66,7 @@ USE: words
 
 : prettyprint-prop ( word prop -- )
     tuck word-name word-property [
-        prettyprint-space prettyprint-1
+        " " write prettyprint-1
     ] [
         drop
     ] ifte ;
@@ -98,28 +98,43 @@ USE: words
         stack-effect. dup prettyprint-newline
     ] keep documentation. ;
 
+: prettyprint-M: ( indent -- indent )
+    \ M: prettyprint-1 " " write tab-size + ;
+
 GENERIC: see ( word -- )
 
-M: object see ( obj -- )
-    "Not a word: " write . ;
-
 M: compound see ( word -- )
-    [ prettyprint-IN: ] keep
+    dup prettyprint-IN:
     0 prettyprint-: swap
     [ prettyprint-1 ] keep
     [ prettyprint-docs ] keep
     [ word-parameter prettyprint-list prettyprint-; ] keep
     prettyprint-plist prettyprint-newline ;
 
+: see-method ( indent word class method -- indent )
+    >r >r >r prettyprint-M:
+    r> prettyprint-1 " " write
+    r> prettyprint-1 " " write
+    dup prettyprint-newline
+    r> prettyprint-list
+    prettyprint-;
+    terpri ;
+
+M: generic see ( word -- )
+    dup prettyprint-IN:
+    0 swap
+    dup "definer" word-property prettyprint-1 " " write
+    dup prettyprint-1 terpri
+    dup methods [ over >r uncons see-method r> ] each 2drop ;
+
 M: primitive see ( word -- )
     dup prettyprint-IN:
     "PRIMITIVE: " write dup prettyprint-1 stack-effect. terpri ;
 
 M: symbol see ( word -- )
     dup prettyprint-IN:
-    0 swap
+    \ SYMBOL: prettyprint-1 " " write . ;
-    \ SYMBOL: prettyprint-1 prettyprint-space . ;
 
 M: undefined see ( word -- )
     dup prettyprint-IN:
-    \ DEFER: prettyprint-1 prettyprint-space . ;
+    \ DEFER: prettyprint-1 " " write . ;

library/test/generic.factor

@@ -142,3 +142,6 @@ M: very-funny gooey sq ;
 [ t ] [ del1 builtin-supertypes [ integer? ] all? ] unit-test
 
 [ cons ] [ [ 1 2 ] class ] unit-test
+
+[ t ] [ \ generic \ compound class< ] unit-test
+[ f ] [ \ compound \ generic class< ] unit-test