diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index 7d89068abb..9b4fd2232e 100644 --- a/TODO.FACTOR.txt +++ b/TODO.FACTOR.txt @@ -8,7 +8,6 @@ - make see work with union, builtin, predicate - doc comments of generics -- redo traits with generic method map + ffi: diff --git a/library/generic/traits.factor b/library/generic/traits.factor index 2172f00003..65cb3e72b0 100644 --- 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 10 "priority" set-word-property -traits [ 2drop t ] "class<" set-word-property - -: init-traits-map ( word -- ) - "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 , 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 \ swons + [ \ traits pick set-hash ] cons \ swons r> append define-compound ; : C: ( -- constructor traits [ ] ) diff --git a/library/tools/interpreter.factor b/library/tools/interpreter.factor index 41f77a939f..5f5748d84a 100644 --- 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