From 123aabc730b17e49f8ba27804514f4159db1fe43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 17:33:59 -0600 Subject: [PATCH 1/4] Fix Mac Intel alignment issue --- core/cpu/x86/32/32.factor | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index d3e33c46bd..4ed186d769 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -261,6 +261,10 @@ windows? [ cell "ulonglong" c-type set-c-type-align ] unless +macosx? [ + cell "double" c-type set-c-type-align +] when + T{ x86-backend f 4 } compiler-backend set-global : sse2? "Intrinsic" throw ; From e9b5a6b9d30a1ad21d46978731c4ffc202df8b43 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:38:19 -0600 Subject: [PATCH 2/4] with-process-stream waits for process exit --- extra/io/launcher/launcher-docs.factor | 4 ++-- extra/io/launcher/launcher.factor | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index c30516a83f..e372f7a41e 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -146,8 +146,8 @@ HELP: with-process-stream { $values { "desc" "a launch descriptor" } { "quot" quotation } - { "process" process } } -{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ; + { "status" "an exit code" } } +{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ; HELP: wait-for-process { $values { "process" process } { "status" integer } } diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 09a77fe985..9be90d28de 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -98,10 +98,10 @@ TUPLE: process-stream process ; { set-delegate set-process-stream-process } process-stream construct ; -: with-process-stream ( desc quot -- process ) +: with-process-stream ( desc quot -- status ) swap [ swap with-stream ] keep - process-stream-process ; inline + process-stream-process wait-for-process ; inline : notify-exit ( status process -- ) [ set-process-status ] keep From 2872bc9d306c553b1546a46983d660d36e6dcafd Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:38:31 -0600 Subject: [PATCH 3/4] 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 From 77a2a2136a0d4837c6f00e66d784fce9bf8d8a97 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Mon, 4 Feb 2008 19:43:10 -0600 Subject: [PATCH 4/4] Better method usages work in progres --- core/generic/generic.factor | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 78577eaed4..2100f49423 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -134,3 +134,13 @@ M: assoc update-methods ( assoc -- ) dupd define-default-method make-generic ] if ; + +: subwords ( generic -- seq ) + dup "methods" word-prop values + swap "default-method" word-prop add + [ method-word ] map ; + +: xref-generics ( -- ) + all-words + [ generic? ] subset + [ subwords [ xref ] each ] each ;