From fa07776250e834908027e5c7b5504d565d6b00ca Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 17 Feb 2008 00:37:54 -0600 Subject: [PATCH 1/4] Fix stack effects for hooks --- core/generic/generic.factor | 12 ++++++------ core/generic/standard/standard.factor | 17 +++++++++-------- 2 files changed, 15 insertions(+), 14 deletions(-) diff --git a/core/generic/generic.factor b/core/generic/generic.factor index 6d564d518c..4bdd1ae40d 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -82,16 +82,16 @@ M: method-body stack-effect [ ] 3keep f \ method construct-boa dup method-word over "method" set-word-prop ; -: redefine-method ( quot method -- ) - 2dup set-method-def - method-word swap define ; +: redefine-method ( quot class generic -- ) + [ method set-method-def ] 3keep + [ make-method-def ] 2keep + method method-word swap define ; : define-method ( quot class generic -- ) >r bootstrap-word r> - 2dup method dup [ - 2nip redefine-method + 2dup method [ + redefine-method ] [ - drop [ ] 2keep [ set-at ] with-methods ] if ; diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 49b003bd62..230ec446c7 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs kernel kernel.private slots.private math namespaces sequences vectors words quotations definitions @@ -77,7 +77,6 @@ TUPLE: no-method object generic ; class-predicates alist>quot ; : small-generic ( methods -- def ) - [ 1quotation ] assoc-map object method-alist>quot ; : hash-methods ( methods -- buckets ) @@ -110,7 +109,7 @@ TUPLE: no-method object generic ; : build-type-vtable ( alist-seq -- alist-seq ) dup length [ vtable-class - swap [ word-def ] assoc-map simplify-alist + swap simplify-alist class-predicates alist>quot ] 2map ; @@ -145,7 +144,8 @@ TUPLE: no-method object generic ; ] if ; : standard-methods ( word -- alist ) - dup methods swap default-method add* ; + dup methods swap default-method add* + [ 1quotation ] assoc-map ; M: standard-combination make-default-method standard-combination-# (dispatch#) @@ -161,9 +161,6 @@ TUPLE: hook-combination var ; C: hook-combination -M: hook-combination method-prologue - 2drop [ drop ] ; - : with-hook ( combination quot -- quot' ) 0 (dispatch#) [ swap slip @@ -175,7 +172,11 @@ M: hook-combination make-default-method [ error-method ] with-hook ; M: hook-combination perform-combination - [ standard-methods single-combination ] with-hook ; + [ + standard-methods + [ [ drop ] swap append ] assoc-map + single-combination + ] with-hook ; : define-simple-generic ( word -- ) T{ standard-combination f 0 } define-generic ; From bb3468dc2b369b20ae0997c3a17e9ad1e3505e1d Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 17 Feb 2008 17:08:16 -0600 Subject: [PATCH 2/4] Fixing interaction between mixin classes and forget --- core/classes/classes-docs.factor | 9 ++++++++- core/classes/classes.factor | 9 ++++++--- core/classes/predicate/predicate.factor | 2 +- core/classes/union/union.factor | 4 +--- core/tuples/tuples.factor | 4 +--- core/words/words.factor | 4 +++- 6 files changed, 20 insertions(+), 12 deletions(-) mode change 100644 => 100755 core/classes/predicate/predicate.factor diff --git a/core/classes/classes-docs.factor b/core/classes/classes-docs.factor index 859b6a95d5..56dda6f904 100755 --- a/core/classes/classes-docs.factor +++ b/core/classes/classes-docs.factor @@ -119,7 +119,7 @@ HELP: predicate-word { $values { "word" "a word" } { "predicate" "a predicate word" } } { $description "Suffixes the word's name with \"?\" and creates a word with that name in the same vocabulary as the word itself." } ; -HELP: define-predicate +HELP: define-predicate* { $values { "class" class } { "predicate" "a predicate word" } { "quot" "a quotation" } } { $description "Defines a predicate word. This is identical to a word definition associating " { $snippet "quot" } " with " { $snippet "predicate" } " with the added perk that three word properties are set:" @@ -132,6 +132,13 @@ HELP: define-predicate } $low-level-note ; +HELP: define-predicate +{ $values { "class" class } { "quot" "a quotation" } } +{ $description + "Defines a predicate word named " { $snippet "class?" } " with " { $link define-predicate* } "." +} +$low-level-note ; + HELP: superclass { $values { "class" class } { "super" class } } { $description "Outputs the superclass of a class. All instances of this class are also instances of the superclass." } diff --git a/core/classes/classes.factor b/core/classes/classes.factor index 345676e106..70088f2b03 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -31,13 +31,16 @@ PREDICATE: class tuple-class PREDICATE: word predicate "predicating" word-prop >boolean ; -: define-predicate ( class predicate quot -- ) +: define-predicate* ( class predicate quot -- ) over [ dupd predicate-effect define-declared 2dup 1quotation "predicate" set-word-prop swap "predicating" set-word-prop - ] [ - 3drop + ] [ 3drop ] if ; + +: define-predicate ( class quot -- ) + over "forgotten" word-prop [ 2drop ] [ + >r dup predicate-word r> define-predicate* ] if ; : superclass ( class -- super ) diff --git a/core/classes/predicate/predicate.factor b/core/classes/predicate/predicate.factor old mode 100644 new mode 100755 index a7270869c5..6d1c727ee2 --- a/core/classes/predicate/predicate.factor +++ b/core/classes/predicate/predicate.factor @@ -16,7 +16,7 @@ PREDICATE: class predicate-class : define-predicate-class ( superclass class definition -- ) >r dup f roll predicate-class define-class r> dupd "predicate-definition" set-word-prop - dup predicate-word over predicate-quot define-predicate ; + dup predicate-quot define-predicate ; M: predicate-class reset-class { diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 332903d36b..dcc05e8160 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -31,9 +31,7 @@ PREDICATE: class union-class ] if ; : define-union-predicate ( class -- ) - dup predicate-word - over members union-predicate-quot - define-predicate ; + dup members union-predicate-quot define-predicate ; M: union-class update-predicate define-union-predicate ; diff --git a/core/tuples/tuples.factor b/core/tuples/tuples.factor index 306c7f4726..ea74645525 100755 --- a/core/tuples/tuples.factor +++ b/core/tuples/tuples.factor @@ -66,9 +66,7 @@ M: tuple-class tuple-size "slot-names" word-prop length 2 + ; PRIVATE> : define-tuple-predicate ( class -- ) - dup predicate-word - over [ tuple-class-eq? ] curry - define-predicate ; + dup [ tuple-class-eq? ] curry define-predicate ; : delegate-slot-spec T{ slot-spec f diff --git a/core/words/words.factor b/core/words/words.factor index 091bd3467d..efb3d06a9b 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -172,7 +172,9 @@ SYMBOL: changed-words gensym dup rot define ; : reveal ( word -- ) - dup word-name over word-vocabulary vocab-words set-at ; + dup word-name over word-vocabulary dup vocab-words + [ ] [ no-vocab ] ?if + set-at ; TUPLE: check-create name vocab ; From 9660a9c2d6e62a89f3ab890cff298ce07eae243b Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 17 Feb 2008 17:08:52 -0600 Subject: [PATCH 3/4] Another fix --- core/bootstrap/primitives.factor | 2 +- core/vocabs/loader/loader.factor | 7 ------- core/vocabs/vocabs.factor | 7 ++++++- 3 files changed, 7 insertions(+), 9 deletions(-) diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 05850e10ee..97712972f3 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -98,7 +98,7 @@ H{ } clone update-map set [ over "type" word-prop dup \ tag-mask get < \ tag \ type ? , , \ eq? , - ] [ ] make define-predicate ; + ] [ ] make define-predicate* ; : register-builtin ( class -- ) dup "type" word-prop builtins get set-nth ; diff --git a/core/vocabs/loader/loader.factor b/core/vocabs/loader/loader.factor index a05cd2fa8c..2d53ed82e2 100755 --- a/core/vocabs/loader/loader.factor +++ b/core/vocabs/loader/loader.factor @@ -69,13 +69,6 @@ M: vocab-link vocab-root vocab-tests % ] { } make ; -TUPLE: no-vocab name ; - -: no-vocab ( name -- * ) - vocab-name \ no-vocab construct-boa throw ; - -M: no-vocab summary drop "Vocabulary does not exist" ; - SYMBOL: load-help? : source-was-loaded t swap set-vocab-source-loaded? ; diff --git a/core/vocabs/vocabs.factor b/core/vocabs/vocabs.factor index 1158d60951..720a1ef645 100755 --- a/core/vocabs/vocabs.factor +++ b/core/vocabs/vocabs.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Eduardo Cavazos, Slava Pestov. +! Copyright (C) 2007, 2008 Eduardo Cavazos, Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs strings kernel sorting namespaces sequences definitions ; @@ -113,3 +113,8 @@ UNION: vocab-spec vocab vocab-link ; vocab-name dictionary get delete-at ; M: vocab-spec forget* forget-vocab ; + +TUPLE: no-vocab name ; + +: no-vocab ( name -- * ) + vocab-name \ no-vocab construct-boa throw ; From de8b804abe24772bec3de3d750ecf1232faadb00 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sun, 17 Feb 2008 18:38:29 -0600 Subject: [PATCH 4/4] Fix method redefinition bug --- core/bootstrap/compiler/compiler.factor | 2 +- core/compiler/compiler.factor | 6 ++++-- core/compiler/units/units.factor | 7 ++++++- core/debugger/debugger.factor | 7 +++++-- core/inference/known-words/known-words.factor | 4 +++- core/listener/listener.factor | 9 ++++++++- core/optimizer/inlining/inlining.factor | 1 + extra/tools/annotations/annotations-tests.factor | 2 +- vm/code_heap.c | 10 +++------- 9 files changed, 32 insertions(+), 16 deletions(-) diff --git a/core/bootstrap/compiler/compiler.factor b/core/bootstrap/compiler/compiler.factor index 6d21504f8b..608b5cb581 100755 --- a/core/bootstrap/compiler/compiler.factor +++ b/core/bootstrap/compiler/compiler.factor @@ -78,7 +78,7 @@ nl [ compiled-usages recompile ] recompile-hook set-global ; : disable-compiler ( -- ) - [ [ f ] { } map>assoc modify-code-heap ] recompile-hook set-global ; + [ default-recompile-hook ] recompile-hook set-global ; enable-compiler diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index b40c5afd33..f0caec7ad1 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -55,7 +55,9 @@ IN: compiler H{ } clone compiled set [ queue-compile ] each compile-queue get compile-loop - compiled get >alist modify-code-heap + compiled get >alist + dup [ drop crossref? ] assoc-contains? + modify-code-heap ] with-scope ; inline : compile ( words -- ) @@ -70,4 +72,4 @@ IN: compiler [ all-words recompile ] with-compiler-errors ; : decompile ( word -- ) - f 2array 1array modify-code-heap ; + f 2array 1array t modify-code-heap ; diff --git a/core/compiler/units/units.factor b/core/compiler/units/units.factor index 242ed9854a..225e1c17c6 100755 --- a/core/compiler/units/units.factor +++ b/core/compiler/units/units.factor @@ -77,6 +77,11 @@ GENERIC: definitions-changed ( assoc obj -- ) [ ] cleanup ] with-scope ; inline +: default-recompile-hook + [ f ] { } map>assoc + dup [ drop crossref? ] assoc-contains? + modify-code-heap ; + recompile-hook global -[ [ [ f ] { } map>assoc modify-code-heap ] or ] +[ [ default-recompile-hook ] or ] change-at diff --git a/core/debugger/debugger.factor b/core/debugger/debugger.factor index 53f3387d85..776e2976d9 100755 --- a/core/debugger/debugger.factor +++ b/core/debugger/debugger.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays definitions generic hashtables inspector io kernel math namespaces prettyprint sequences assocs sequences.private strings io.styles vectors words system splitting math.parser tuples continuations continuations.private combinators generic.math io.streams.duplex classes compiler.units -generic.standard ; +generic.standard vocabs ; IN: debugger GENERIC: error. ( error -- ) @@ -254,3 +254,6 @@ M: no-compilation-unit error. "Attempting to define " write no-compilation-unit-definition pprint " outside of a compilation unit" print ; + +M: no-vocab summary + drop "Vocabulary does not exist" ; diff --git a/core/inference/known-words/known-words.factor b/core/inference/known-words/known-words.factor index 2173d5d4e1..8e8251ff62 100755 --- a/core/inference/known-words/known-words.factor +++ b/core/inference/known-words/known-words.factor @@ -10,7 +10,7 @@ namespaces.private parser prettyprint quotations quotations.private sbufs sbufs.private sequences sequences.private slots.private strings strings.private system threads.private tuples tuples.private vectors vectors.private -words words.private assocs inspector ; +words words.private assocs inspector compiler.units ; IN: inference.known-words ! Shuffle words @@ -598,3 +598,5 @@ set-primitive-effect \ do-primitive [ \ do-primitive no-effect ] "infer" set-word-prop \ dll-valid? { object } { object } set-primitive-effect + +\ modify-code-heap { array object } { } set-primitive-effect diff --git a/core/listener/listener.factor b/core/listener/listener.factor index 02cd727930..2d777d8087 100755 --- a/core/listener/listener.factor +++ b/core/listener/listener.factor @@ -48,7 +48,14 @@ M: duplex-stream stream-read-quot : listen ( -- ) listener-hook get call prompt. - [ read-quot [ call ] [ bye ] if* ] try ; + [ read-quot [ try ] [ bye ] if* ] + [ + dup parse-error? [ + error-hook get call + ] [ + rethrow + ] if + ] recover ; : until-quit ( -- ) quit-flag get diff --git a/core/optimizer/inlining/inlining.factor b/core/optimizer/inlining/inlining.factor index 9350658611..f3709780f9 100755 --- a/core/optimizer/inlining/inlining.factor +++ b/core/optimizer/inlining/inlining.factor @@ -63,6 +63,7 @@ DEFER: (flat-length) : inline-standard-method ( node word -- node ) 2dup dispatching-class dup [ + over +inlined+ depends-on swap method method-word 1quotation f splice-quot ] [ 3drop t diff --git a/extra/tools/annotations/annotations-tests.factor b/extra/tools/annotations/annotations-tests.factor index da0c85196d..90d9d26f51 100755 --- a/extra/tools/annotations/annotations-tests.factor +++ b/extra/tools/annotations/annotations-tests.factor @@ -7,7 +7,7 @@ IN: temporary [ ] [ foo ] unit-test ! erg's bug -GENERIC: some-generic +GENERIC: some-generic ( a -- b ) M: integer some-generic 1+ ; diff --git a/vm/code_heap.c b/vm/code_heap.c index c2f8ba0f5e..4113e8abc8 100755 --- a/vm/code_heap.c +++ b/vm/code_heap.c @@ -28,7 +28,7 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start) if(type_of(symbol) == BYTE_ARRAY_TYPE) { - F_CHAR *name = alien_offset(symbol); + F_SYMBOL *name = alien_offset(symbol); void *sym = ffi_dlsym(dll,name); if(sym) @@ -40,7 +40,7 @@ void *get_rel_symbol(F_REL *rel, CELL literals_start) F_ARRAY *names = untag_object(symbol); for(i = 0; i < array_capacity(names); i++) { - F_CHAR *name = alien_offset(array_nth(names,i)); + F_SYMBOL *name = alien_offset(array_nth(names,i)); void *sym = ffi_dlsym(dll,name); if(sym) @@ -318,10 +318,9 @@ void default_word_code(F_WORD *word, bool relocate) DEFINE_PRIMITIVE(modify_code_heap) { + bool rescan_code_heap = to_boolean(dpop()); F_ARRAY *alist = untag_array(dpop()); - bool rescan_code_heap = false; - CELL count = untag_fixnum_fast(alist->capacity); CELL i; for(i = 0; i < count; i++) @@ -330,9 +329,6 @@ DEFINE_PRIMITIVE(modify_code_heap) F_WORD *word = untag_word(array_nth(pair,0)); - if(word->vocabulary != F) - rescan_code_heap = true; - CELL data = array_nth(pair,1); if(data == F)