unified method map

diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt
index 7d89068abbfb9eb5e57c1f5c5ea4f217bb5ffcb7..9b4fd2232e1164f9cdda34f18234161f5c1be2fa 100644 (file)
--- a/TODO.FACTOR.txt
+++ b/TODO.FACTOR.txt
@@ -8,7 +8,6 @@
 \r
 - make see work with union, builtin, predicate\r
 - doc comments of generics\r
-- redo traits with generic method map\r
 \r
 + ffi:\r
 \r

diff --git a/library/generic/traits.factor b/library/generic/traits.factor
index 2172f000037baab65d387c690b1a2c58ee9e2ee4..65cb3e72b0032770122b8fef3cc6d6ad72a0cedf 100644 (file)
--- a/library/generic/traits.factor
+++ b/library/generic/traits.factor
@@ -38,70 +38,46 @@ USE: vectors
 
 ! Traits metaclass for user-defined classes based on hashtables
 
-! Hashtable slot holding a selector->method map.
-SYMBOL: traits
-
-: traits-map ( class -- hash )
-    #! The method map word property maps selector words to
-    #! definitions.
-    "traits-map" word-property ;
+: traits ( object -- symbol ) \ traits swap hash ;
 
 ! Hashtable slot holding an optional delegate. Any undefined
 ! methods are called on the delegate. The object can also
 ! manually pass any methods on to the delegate.
 SYMBOL: delegate
 
-: object-map ( obj -- hash )
-    #! Get the method map for an object.
-    #! We will use hashtable? here when its a first-class type.
-    dup vector? [ traits swap hash ] [ drop f ] ifte ;
-
-: traits-dispatch ( 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.
-    2dup object-map hash* dup [
-        rot drop cdr ( method is defined )
+: traits-dispatch ( object selector -- object quot )
+    over traits over "methods" word-property hash* dup [
+        nip cdr ( method is defined )
     ] [
-        drop delegate swap hash* dup [
-            cdr traits-dispatch ( check delegate )
+        drop delegate rot hash [
+            swap traits-dispatch ( check delegate )
         ] [
-            drop [ undefined-method ] ( no delegate )
-        ] ifte
+            [ undefined-method ] ( no delegate )
+        ] ifte*
     ] ifte ;
 
 : add-traits-dispatch ( word vtable -- )
-    >r unit [ car swap traits-dispatch call ] cons \ vector r>
+    >r unit [ car traits-dispatch call ] cons \ vector r>
     set-vtable ;
 
-traits [
+\ traits [
     ( generic vtable definition class -- )
     2drop add-traits-dispatch
 ] "add-method" set-word-property
 
-traits [
-    ( class generic quotation )
-    3dup -rot (define-method)
-    over dup word-parameter car add-traits-dispatch
-    swap rot traits-map set-hash
-] "define-method" set-word-property
-
-traits [
+\ traits [
     drop vector "builtin-type" word-property unit
 ] "builtin-supertypes" set-word-property
 
-traits 10 "priority" set-word-property
-
-traits [ 2drop t ] "class<" set-word-property
+\ traits 10 "priority" set-word-property
 
-: init-traits-map ( word -- )
-    <namespace> "traits-map" set-word-property ;
+\ traits [ 2drop t ] "class<" set-word-property
 
 : traits-predicate ( word -- )
     #! foo? where foo is a traits type tests if the top of stack
     #! is of this type.
     dup predicate-word swap
-    traits-map [ swap object-map eq? ] cons
+    [ swap traits eq? ] cons
     define-compound ;
 
 : TRAITS:
@@ -109,8 +85,7 @@ traits [ 2drop t ] "class<" set-word-property
     #! created with <foo>, and tested with foo?.
     CREATE
     dup define-symbol
-    dup init-traits-map
-    dup traits "metaclass" set-word-property
+    dup \ traits "metaclass" set-word-property
     traits-predicate ; parsing
 
 : constructor-word ( word -- word )
@@ -118,7 +93,7 @@ traits [ 2drop t ] "class<" set-word-property
 
 : define-constructor ( constructor traits definition -- )
     >r
-    traits-map [ traits pick set-hash ] cons \ <namespace> swons
+    [ \ traits pick set-hash ] cons \ <namespace> swons
     r> append define-compound ;
 
 : C: ( -- constructor traits [ ] )

diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor
index 41f77a939f513150aec9856b1b8542f1c30eb74f..5f5748d84aa85d31ec6546978ba46c1f2a7a70bc 100644 (file)
--- a/library/tools/interpreter.factor
+++ b/library/tools/interpreter.factor
@@ -192,13 +192,16 @@ SYMBOL: meta-cf
 : not-done ( quot -- )
     done? [ "Stepper is done." print drop ] [ call ] ifte ;
 
+: next-report ( -- obj )
+    next dup report meta-cf get report ;
+
 : step
     #! Step into current word.
-    [ meta-cf get . next do-1 ] not-done ;
+    [ next-report do-1 ] not-done ;
 
 : into
     #! Step into current word.
-    [ meta-cf get . next do ] not-done ;
+    [ next-report do ] not-done ;
 
 : walk-banner ( -- )
     "The following words control the single-stepper:" print