From 2872bc9d306c553b1546a46983d660d36e6dcafd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:38:31 -0600 Subject: [PATCH] More method cleanups --- core/compiler/compiler.factor | 2 +- core/effects/effects.factor | 20 +++++++---------- core/generic/generic-docs.factor | 4 ---- core/generic/generic-tests.factor | 3 +++ core/generic/generic.factor | 32 +++++++++++++++------------ core/generic/standard/standard.factor | 2 +- core/inference/backend/backend.factor | 4 ++-- core/words/words.factor | 5 ++++- 8 files changed, 37 insertions(+), 35 deletions(-) diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 631c2e4f53..2674734483 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -26,7 +26,7 @@ IN: compiler >r dupd save-effect r> f pick compiler-error over compiled-unxref - compiled-xref ; + over crossref? [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 10ebca6dea..23e8daf122 100755 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces sequences strings words assocs combinators ; @@ -41,17 +41,13 @@ M: integer (stack-picture) drop "object" ; ")" % ] "" make ; -: stack-effect ( word -- effect/f ) - { - { [ dup symbol? ] [ drop 0 1 ] } - { [ dup "parent-generic" word-prop ] [ - "parent-generic" word-prop stack-effect - ] } - { [ t ] [ - { "declared-effect" "inferred-effect" } - swap word-props [ at ] curry map [ ] find nip - ] } - } cond ; +GENERIC: stack-effect ( word -- effect/f ) + +M: symbol stack-effect drop 0 1 ; + +M: word stack-effect + { "declared-effect" "inferred-effect" } + swap word-props [ at ] curry map [ ] find nip ; M: effect clone [ effect-in clone ] keep effect-out clone ; diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index f4da9575e9..631aa7e62d 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -107,10 +107,6 @@ HELP: make-generic { $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." } $low-level-note ; -HELP: init-methods -{ $values { "word" word } } -{ $description "Prepare to define a generic word." } ; - HELP: define-generic { $values { "word" word } { "combination" "a method combination" } } { $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." } diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index dc888ec30c..f0d5bf3063 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -176,6 +176,9 @@ M: f tag-and-f 4 ; ! define-class hashing issue TUPLE: debug-combination ; +M: debug-combination make-default-method + 2drop [ "Oops" throw ] when ; + M: debug-combination perform-combination drop order [ dup class-hashes ] { } map>assoc sort-keys diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 951813dbcd..78577eaed4 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -1,8 +1,8 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words kernel sequences namespaces assocs hashtables definitions kernel.private classes classes.private -quotations arrays vocabs ; +quotations arrays vocabs effects ; IN: generic ! Method combination protocol @@ -65,15 +65,20 @@ TUPLE: check-method class generic ; : make-method-def ( quot word combination -- quot ) "combination" word-prop method-prologue swap append ; +PREDICATE: word method-body "method" word-prop >boolean ; + +M: method-body stack-effect + "method" word-prop method-generic stack-effect ; + : ( quot class generic -- word ) [ make-method-def ] 2keep - [ method-word-name f dup ] keep - "parent-generic" set-word-prop + method-word-name f dup rot define ; : ( quot class generic -- method ) check-method - [ ] 3keep f \ method construct-boa ; + [ ] 3keep f \ method construct-boa + dup method-word over "method" set-word-prop ; : define-method ( quot class generic -- ) >r bootstrap-word r> @@ -120,13 +125,12 @@ M: class forget* ( class -- ) M: assoc update-methods ( assoc -- ) implementors* [ make-generic ] each ; -: init-methods ( word -- ) - dup "methods" word-prop - H{ } assoc-like - "methods" set-word-prop ; - : define-generic ( word combination -- ) - 2dup "combination" set-word-prop - dupd define-default-method - dup init-methods - make-generic ; + over "combination" word-prop over = [ + 2drop + ] [ + 2dup "combination" set-word-prop + over H{ } clone "methods" set-word-prop + dupd define-default-method + make-generic + ] if ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 94ac82a0e4..d52208ccbf 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -10,7 +10,7 @@ TUPLE: standard-combination # ; M: standard-combination method-prologue standard-combination-# object - swap add [ declare ] curry ; + swap add* [ declare ] curry ; C: standard-combination diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 34179bbf32..b839b047d6 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -10,8 +10,8 @@ IN: inference.backend recursive-state get at ; : inline? ( word -- ? ) - dup "parent-generic" word-prop - [ inline? ] [ "inline" word-prop ] ?if ; + dup "method" word-prop + [ method-generic inline? ] [ "inline" word-prop ] ?if ; : local-recursive-state ( -- assoc ) recursive-state get dup keys diff --git a/core/words/words.factor b/core/words/words.factor index b4062d8f02..93b1185335 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -116,13 +116,16 @@ SYMBOL: changed-words [ no-compilation-unit ] unless* set-at ; +: crossref? ( word -- ? ) + dup word-vocabulary swap "method" word-prop or ; + : define ( word def -- ) [ ] like over unxref over redefined over set-word-def dup changed-word - dup word-vocabulary [ dup xref ] when drop ; + dup crossref? [ dup xref ] when drop ; : define-declared ( word def effect -- ) pick swap "declared-effect" set-word-prop