From 8806a0b18b446c949c274b608b7f2d00b1d6861b Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Wed, 15 Apr 2009 16:12:31 -0700 Subject: [PATCH 001/114] Make fuel auto-use the existing using in fuel-debug--uses-for-file. --- extra/fuel/fuel.factor | 28 +++++++++++++++++++++++++--- misc/fuel/fuel-debug-uses.el | 12 +++++++++--- 2 files changed, 34 insertions(+), 6 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 403708e880..a8c2adc3e1 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -1,9 +1,9 @@ ! Copyright (C) 2008, 2009 Jose Antonio Ortega Ruiz. ! See http://factorcode.org/license.txt for BSD license. -USING: assocs compiler.units fuel.eval fuel.help fuel.remote fuel.xref -help.topics io.pathnames kernel namespaces parser sequences -tools.scaffold vocabs.loader ; +USING: accessors assocs compiler.units continuations fuel.eval fuel.help +fuel.remote fuel.xref help.topics io.pathnames kernel math namespaces parser +sequences tools.scaffold vocabs.loader ; IN: fuel @@ -28,6 +28,24 @@ IN: fuel > [ "Use the " head? ] [ " vocabulary" tail? ] bi and ; + +: get-restart-vocab ( restart -- vocab ) + [ "Use the " length ] dip + name>> [ length " vocabulary" length - ] keep + subseq ; + +: is-suggested-restart ( restart -- ? ) + dup is-use-restart [ + get-restart-vocab :uses-suggestions get member? + ] [ drop f ] if ; + +: try-suggested-restarts ( -- ) + restarts get [ is-suggested-restart ] filter + dup length 1 = [ first restart ] [ drop ] if ; : fuel-set-use-hook ( -- ) [ amended-use get clone :uses prefix fuel-eval-set-result ] @@ -38,6 +56,10 @@ SYMBOL: :uses PRIVATE> +: fuel-use-suggested-vocabs ( ... suggestions quot: ( ... -- ... ) -- ... ) + [ :uses-suggestions set ] dip + [ try-suggested-restarts rethrow ] recover ; + : fuel-run-file ( path -- ) [ fuel-set-use-hook run-file ] curry with-scope ; inline diff --git a/misc/fuel/fuel-debug-uses.el b/misc/fuel/fuel-debug-uses.el index 4842f960d1..8b25744011 100644 --- a/misc/fuel/fuel-debug-uses.el +++ b/misc/fuel/fuel-debug-uses.el @@ -88,9 +88,16 @@ fuel-debug--uses nil fuel-debug--uses-restarts nil)) +(defun fuel-debug--current-usings (file) + (with-current-buffer (find-file-noselect file) + (sort (fuel-syntax--find-usings t) 'string<))) + (defun fuel-debug--uses-for-file (file) (let* ((lines (fuel-debug--file-lines file)) - (cmd `(:fuel ((V{ ,@lines } fuel-get-uses)) t t))) + (old-usings (fuel-debug--current-usings file)) + (cmd `(:fuel ((V{ ,@old-usings } + [ V{ ,@lines } fuel-get-uses ] + fuel-use-suggested-vocabs)) t t))) (fuel-debug--uses-prepare file) (fuel--with-popup (fuel-debug--uses-buffer) (insert "Asking Factor. Please, wait ...\n") @@ -105,8 +112,7 @@ (defun fuel-debug--uses-display (uses) (let* ((inhibit-read-only t) - (old (with-current-buffer (find-file-noselect fuel-debug--uses-file) - (sort (fuel-syntax--find-usings t) 'string<))) + (old (fuel-debug--current-usings fuel-debug--uses-file)) (new (sort uses 'string<))) (erase-buffer) (fuel-debug--uses-insert-title) From af7ecb16cfd617c78c4987895b96a52328879f27 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 19 Apr 2009 14:52:24 -0700 Subject: [PATCH 002/114] Determine restart vocab thru obj>> instead of error string --- extra/fuel/fuel.factor | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 3c623212b0..12eb5bdbfc 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -2,8 +2,8 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors assocs compiler.units continuations fuel.eval fuel.help -fuel.remote fuel.xref help.topics io.pathnames kernel math namespaces parser -sequences tools.scaffold vocabs.loader ; +fuel.remote fuel.xref help.topics io.pathnames kernel namespaces parser +sequences tools.scaffold vocabs.loader words ; IN: fuel @@ -33,10 +33,8 @@ SYMBOL: :uses-suggestions : is-use-restart ( restart -- ? ) name>> [ "Use the " head? ] [ " vocabulary" tail? ] bi and ; -: get-restart-vocab ( restart -- vocab ) - [ "Use the " length ] dip - name>> [ length " vocabulary" length - ] keep - subseq ; +: get-restart-vocab ( restart -- vocab/f ) + obj>> dup word? [ vocabulary>> ] [ drop f ] if ; : is-suggested-restart ( restart -- ? ) dup is-use-restart [ @@ -56,9 +54,9 @@ SYMBOL: :uses-suggestions PRIVATE> -: fuel-use-suggested-vocabs ( ... suggestions quot: ( ... -- ... ) -- ... ) +: fuel-use-suggested-vocabs ( suggestions quot ... suggestions quot: ( ... -- ... ) -- ... ) [ :uses-suggestions set ] dip - [ try-suggested-restarts rethrow ] recover ; + [ try-suggested-restarts rethrow ] recover ; inline : fuel-run-file ( path -- ) [ fuel-set-use-hook run-file ] curry with-scope ; inline From 18b5090892e20b5016affc51846340d9e3e52c00 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Sun, 19 Apr 2009 19:57:35 -0700 Subject: [PATCH 003/114] Add tests for auto-USING selection --- extra/fuel/fuel-tests.factor | 33 +++++++++++++++++++++++++++++++++ 1 file changed, 33 insertions(+) create mode 100644 extra/fuel/fuel-tests.factor diff --git a/extra/fuel/fuel-tests.factor b/extra/fuel/fuel-tests.factor new file mode 100644 index 0000000000..a0cab888e8 --- /dev/null +++ b/extra/fuel/fuel-tests.factor @@ -0,0 +1,33 @@ +! Copyright (C) 2009 Nicholas Seckar. +! See http://factorcode.org/license.txt for BSD license. +USING: continuations eval fuel fuel.private namespaces tools.test words ; +IN: fuel.tests + +: fake-continuation ( -- continuation ) + f f f "fake" f ; + +: make-uses-restart ( -- restart ) + "Use the words vocabulary" \ word? + fake-continuation ; + +: make-defer-restart ( -- restart ) + "Defer word in current vocabulary" f + fake-continuation ; + +{ f } [ make-defer-restart is-use-restart ] unit-test +{ t } [ make-uses-restart is-use-restart ] unit-test + +{ "words" } [ make-uses-restart get-restart-vocab ] unit-test + +{ f } [ make-defer-restart is-suggested-restart ] unit-test +{ f } [ make-uses-restart is-suggested-restart ] unit-test +{ f } [ { "io" } :uses-suggestions + [ make-uses-restart is-suggested-restart ] with-variable +] unit-test +{ t } [ { "words" } :uses-suggestions + [ make-uses-restart is-suggested-restart ] with-variable +] unit-test + +{ } [ + { "kernel" } [ "\\ dup drop" eval( -- ) ] fuel-use-suggested-vocabs +] unit-test From 47064cd1af6c1ddc6448928acea86f371e293840 Mon Sep 17 00:00:00 2001 From: Nicholas Seckar Date: Wed, 22 Apr 2009 15:40:17 -0700 Subject: [PATCH 004/114] Fix stack effect of fuel-use-suggested-vocabs --- extra/fuel/fuel.factor | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/extra/fuel/fuel.factor b/extra/fuel/fuel.factor index 12eb5bdbfc..a9ed17877e 100644 --- a/extra/fuel/fuel.factor +++ b/extra/fuel/fuel.factor @@ -54,7 +54,7 @@ SYMBOL: :uses-suggestions PRIVATE> -: fuel-use-suggested-vocabs ( suggestions quot ... suggestions quot: ( ... -- ... ) -- ... ) +: fuel-use-suggested-vocabs ( suggestions quot -- ... ) [ :uses-suggestions set ] dip [ try-suggested-restarts rethrow ] recover ; inline From e4055005ea0cbdfda801f507761fb1d1652f4147 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 24 Apr 2009 22:03:38 +0200 Subject: [PATCH 005/114] FUEL: Fixes for string highlighting. --- misc/fuel/fuel-syntax.el | 19 +++++++++---------- 1 file changed, 9 insertions(+), 10 deletions(-) diff --git a/misc/fuel/fuel-syntax.el b/misc/fuel/fuel-syntax.el index 6b646511ca..61aa2b7cdd 100644 --- a/misc/fuel/fuel-syntax.el +++ b/misc/fuel/fuel-syntax.el @@ -241,18 +241,17 @@ table)) (defconst fuel-syntax--syntactic-keywords - `(;; Comments - ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) - ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) - ;; Strings and chars - ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)" - (1 "w") (2 "\"") (4 "\"")) - ("\\(CHAR:\\|\\\\\\) \\(.\\)\\( \\|$\\)" (2 "w")) - ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" - (3 "\"") (5 "\"")) - ("\\_<\\(\"\\)\\([^\n\r\f\\\"]\\|\\\\.\\)*?\\(\"\\)" (1 "\"") (3 "\"")) + `(;; Strings and chars ("\\_<<\\(\"\\)\\_>" (1 "\\_>" (1 ">b")) + ("\\( \\|^\\)\\(DLL\\|P\\|SBUF\\)?\\(\"\\)\\(\\([^\n\r\f\"\\]\\|\\\\.\\)*\\)\\(\"\\)" + (3 "\"") (6 "\"")) + ("CHAR: \\(\"\\) [^\\\"]*?\\(\"\\)\\([^\\\"]\\|\\\\.\\)*?\\(\"\\)" + (1 "w") (2 "b")) + ("\\(CHAR:\\|\\\\\\) \\(\\w\\|!\\)\\( \\|$\\)" (2 "w")) + ;; Comments + ("\\_<\\(#?!\\) .*\\(\n\\|$\\)" (1 "<") (2 ">")) + ("\\_<\\(#?!\\)\\(\n\\|$\\)" (1 "<") (2 ">")) ;; postpone ("\\_b")) ;; Multiline constructs From 9b19b341268834751631f1ae69ce870672b33046 Mon Sep 17 00:00:00 2001 From: "Jose A. Ortega Ruiz" Date: Fri, 24 Apr 2009 22:15:20 +0200 Subject: [PATCH 006/114] FUEL: Fix for C-cC-eC-l (make factor command ( -- )). --- misc/fuel/fuel-mode.el | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/misc/fuel/fuel-mode.el b/misc/fuel/fuel-mode.el index aa9a7d944e..0186392f34 100644 --- a/misc/fuel/fuel-mode.el +++ b/misc/fuel/fuel-mode.el @@ -140,7 +140,7 @@ for details." (interactive) (message "Loading all vocabularies in USING: form ...") (let ((err (fuel-eval--retort-error - (fuel-eval--send/wait '(:fuel* (t) t :usings) 120000)))) + (fuel-eval--send/wait '(:fuel* (t .) t :usings) 120000)))) (message (if err "Warning: some vocabularies failed to load" "All vocabularies loaded")))) From 8c5b0373a83955d0f94b86055c6a3623145d8e79 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 15:31:06 -0500 Subject: [PATCH 007/114] Working on new method dispatch system --- Makefile | 3 +- .../known-words/known-words.factor | 3 + core/bootstrap/primitives.factor | 2 + core/generic/standard/compiler/authors.txt | 1 + .../generic/standard/compiler/compiler.factor | 174 ++++++++++++++++++ vm/data_heap.c | 2 +- vm/dispatch.c | 108 +++++++++++ vm/dispatch.h | 1 + vm/layouts.h | 2 +- vm/master.h | 1 + vm/primitives.c | 3 +- 11 files changed, 296 insertions(+), 4 deletions(-) create mode 100644 core/generic/standard/compiler/authors.txt create mode 100644 core/generic/standard/compiler/compiler.factor create mode 100644 vm/dispatch.c create mode 100644 vm/dispatch.h diff --git a/Makefile b/Makefile index 35a5ba58bf..511c191711 100644 --- a/Makefile +++ b/Makefile @@ -35,6 +35,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \ vm/data_gc.o \ vm/data_heap.o \ vm/debug.o \ + vm/dispatch.o \ vm/errors.o \ vm/factor.o \ vm/image.o \ @@ -182,5 +183,5 @@ vm/ffi_test.o: vm/ffi_test.c .m.o: $(CC) -c $(CFLAGS) -o $@ $< - + .PHONY: factor diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index eade33e52b..ab205b4a16 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -12,6 +12,7 @@ classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.types words.private quotations.private combinators.private stack-checker.values +generic.standard.private alien.libraries stack-checker.alien stack-checker.state @@ -676,3 +677,5 @@ M: object infer-call* \ gc-stats { } { array } define-primitive \ jit-compile { quotation } { } define-primitive + +\ lookup-method { object array } { word } define-primitive \ No newline at end of file diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 1258da8a4d..a8e23cd336 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -69,6 +69,7 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" + "generic.standard.private" "growable" "hashtables" "hashtables.private" @@ -532,6 +533,7 @@ tuple { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } + { "lookup-method" "generic.standard.private" (( object methods -- method )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/generic/standard/compiler/authors.txt b/core/generic/standard/compiler/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/standard/compiler/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/standard/compiler/compiler.factor b/core/generic/standard/compiler/compiler.factor new file mode 100644 index 0000000000..0456918b49 --- /dev/null +++ b/core/generic/standard/compiler/compiler.factor @@ -0,0 +1,174 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes.algebra math combinators +generic.standard.engines hashtables kernel kernel.private layouts +namespaces sequences words sorting quotations effects +generic.standard.private words.private ; +IN: generic.standard.compiler + +! ! ! Build an engine ! ! ! + +! 1. Flatten methods +TUPLE: predicate-engine methods ; + +: ( methods -- engine ) predicate-engine boa ; + +: push-method ( method specializer atomic assoc -- ) + [ + [ H{ } clone ] unless* + [ methods>> set-at ] keep + ] change-at ; + +: flatten-method ( class method assoc -- ) + [ [ flatten-class keys ] keep ] 2dip [ + [ spin ] dip push-method + ] 3curry each ; + +: flatten-methods ( assoc -- assoc' ) + H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; + +! 2. Convert methods +: convert-methods ( assoc class word -- assoc' ) + over [ split-methods ] 2dip pick assoc-empty? + [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline + +! 2.1 Convert tuple methods +TUPLE: echelon-dispatch-engine n methods ; + +C: echelon-dispatch-engine + +TUPLE: tuple-dispatch-engine echelons ; + +: push-echelon ( class method assoc -- ) + [ swap dup "layout" word-prop third ] dip + [ ?set-at ] change-at ; + +: echelon-sort ( assoc -- assoc' ) + H{ } clone [ [ push-echelon ] curry assoc-each ] keep ; + +: ( methods -- engine ) + echelon-sort + [ dupd ] assoc-map + \ tuple-dispatch-engine boa ; + +: convert-tuple-methods ( assoc -- assoc' ) + tuple bootstrap-word + \ convert-methods ; + +! 2.2 Convert hi-tag methods +TUPLE: hi-tag-dispatch-engine methods ; + +C: hi-tag-dispatch-engine + +: convert-hi-tag-methods ( assoc -- assoc' ) + \ hi-tag bootstrap-word + \ convert-methods ; + +! 3 Tag methods +TUPLE: tag-dispatch-engine methods ; + +C: tag-dispatch-engine + +: ( assoc -- engine ) + flatten-methods + convert-tuple-methods + convert-hi-tag-methods + ; + +! ! ! Compile engine ! ! ! +SYMBOL: assumed +SYMBOL: default +SYMBOL: generic-word + +GENERIC: compile-engine ( engine -- obj ) + +: compile-engines ( assoc -- assoc' ) + [ compile-engine ] assoc-map ; + +: compile-engines* ( assoc -- assoc' ) + [ over assumed [ compile-engine ] with-variable ] assoc-map ; + +: direct-dispatch-table ( assoc n -- table ) + default get [ swap update ] keep ; + +M: tag-dispatch-engine compile-engine + methods>> compile-engines* + [ [ tag-number ] dip ] assoc-map + num-tags get direct-dispatch-table ; + +: hi-tag-number ( class -- n ) "type" word-prop ; + +: num-hi-tags ( -- n ) + num-types get num-tags get - ; + +M: hi-tag-dispatch-engine compile-engine + methods>> compile-engines* + [ [ hi-tag-number num-tags get - ] dip ] assoc-map + num-hi-tags direct-dispatch-table ; + +: build-fast-hash ( methods -- buckets ) + >alist V{ } clone [ hashcode 1array ] distribute-buckets + [ compile-engines* >alist >array ] map ; + +M: echelon-dispatch-engine compile-engine + methods>> compile-engines* build-fast-hash ; + +M: tuple-dispatch-engine compile-engine + tuple assumed [ + echelons>> compile-engines + dup keys supremum f default get prefix + [ swap update ] keep + ] with-variable ; + +: sort-methods ( assoc -- assoc' ) + >alist [ keys sort-classes ] keep extract-keys ; + +: literalize-methods ( assoc -- assoc' ) + [ [ ] curry \ drop prefix ] assoc-map ; + +: methods-with-default ( engine -- assoc ) + methods>> clone default get object bootstrap-word pick set-at ; + +: keep-going? ( assoc -- ? ) + assumed get swap second first class<= ; + +: prune-redundant-predicates ( assoc -- default assoc' ) + { + { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } + { [ dup length 1 = ] [ first second { } ] } + { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } + [ [ first second ] [ rest-slice ] bi ] + } cond ; + +: class-predicates ( assoc -- assoc ) + [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; + +: predicate-engine-effect ( -- effect ) + (dispatch#) get 1+ dup 1+ ; + +: define-predicate-engine ( alist -- word ) + [ generic-word get name>> "/predicate-engine" append f dup ] dip + predicate-engine-effect define-declared ; + +M: predicate-engine compile-engine + methods-with-default + sort-methods + literalize-methods + prune-redundant-predicates + class-predicates + [ peek wrapped>> ] + [ alist>quot picker prepend define-predicate-engine ] if-empty ; + +M: word compile-engine ; + +M: f compile-engine ; + +: build-engine ( generic combination -- engine ) + [ + #>> (dispatch#) set + [ generic-word set ] + [ "default-method" word-prop default set ] + [ "methods" word-prop ] tri + compile-engine 1quotation + picker [ lookup-method ] surround + ] with-scope ; \ No newline at end of file diff --git a/vm/data_heap.c b/vm/data_heap.c index c5aa42aebe..eb8add544e 100644 --- a/vm/data_heap.c +++ b/vm/data_heap.c @@ -334,7 +334,7 @@ CELL next_object(void) type = untag_header(value); heap_scan_ptr += untagged_object_size(heap_scan_ptr); - return RETAG(obj,type <= HEADER_TYPE ? type : OBJECT_TYPE); + return RETAG(obj,type < HEADER_TYPE ? type : OBJECT_TYPE); } /* Push object at heap scan cursor and advance; pushes f when done */ diff --git a/vm/dispatch.c b/vm/dispatch.c new file mode 100644 index 0000000000..e231d6f431 --- /dev/null +++ b/vm/dispatch.c @@ -0,0 +1,108 @@ +#include "master.h" + +static CELL search_lookup_alist(CELL table, CELL class) +{ + F_ARRAY *pairs = untag_object(table); + F_FIXNUM index = array_capacity(pairs) - 1; + while(index >= 0) + { + F_ARRAY *pair = untag_object(array_nth(pairs,index)); + if(array_nth(pair,0) == class) + return array_nth(pair,1); + else + index--; + } + + return F; +} + +static CELL search_lookup_hash(CELL table, CELL class, CELL hashcode) +{ + F_ARRAY *buckets = untag_object(table); + CELL bucket = array_nth(buckets,hashcode & (array_capacity(buckets) - 1)); + if(type_of(bucket) == WORD_TYPE || bucket == F) + return bucket; + else + return search_lookup_alist(bucket,class); +} + +static CELL nth_superclass(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +{ + CELL *ptr = (CELL *)(layout + 1); + return ptr[echelon * 2]; +} + +static CELL nth_hashcode(F_TUPLE_LAYOUT *layout, F_FIXNUM echelon) +{ + CELL *ptr = (CELL *)(layout + 1); + return ptr[echelon * 2 + 1]; +} + +static CELL lookup_tuple_method(CELL object, CELL methods) +{ + F_ARRAY *echelons = untag_object(methods); + F_TUPLE *tuple = untag_object(object); + F_TUPLE_LAYOUT *layout = untag_object(tuple->layout); + + F_FIXNUM echelon = untag_fixnum_fast(layout->echelon); + F_FIXNUM max_echelon = array_capacity(echelons) - 1; + if(echelon > max_echelon) echelon = max_echelon; + + while(echelon >= 0) + { + CELL echelon_methods = array_nth(echelons,echelon); + + if(type_of(echelon_methods) == WORD_TYPE) + return echelon_methods; + else if(echelon_methods != F) + { + CELL class = nth_superclass(layout,echelon); + CELL hashcode = untag_fixnum_fast(nth_hashcode(layout,echelon)); + CELL result = search_lookup_hash(echelon_methods,class,hashcode); + if(result != F) + return result; + } + + echelon--; + } + + critical_error("Cannot find tuple method",object); + return F; +} + +static CELL lookup_hi_tag_method(CELL object, CELL methods) +{ + F_ARRAY *hi_tag_methods = untag_object(methods); + CELL hi_tag = object_type(object); + return array_nth(hi_tag_methods,hi_tag - HEADER_TYPE); +} + +static CELL lookup_method(CELL object, CELL methods) +{ + F_ARRAY *tag_methods = untag_object(methods); + CELL tag = TAG(object); + CELL element = array_nth(tag_methods,tag); + + if(type_of(element) == WORD_TYPE) + return element; + else + { + switch(tag) + { + case TUPLE_TYPE: + return lookup_tuple_method(object,element); + case OBJECT_TYPE: + return lookup_hi_tag_method(object,element); + default: + critical_error("Bad methods array",methods); + return F; + } + } +} + +void primitive_lookup_method(void) +{ + CELL methods = dpop(); + CELL object = dpop(); + dpush(lookup_method(object,methods)); +} diff --git a/vm/dispatch.h b/vm/dispatch.h new file mode 100644 index 0000000000..6541c8fef1 --- /dev/null +++ b/vm/dispatch.h @@ -0,0 +1 @@ +void primitive_lookup_method(void); diff --git a/vm/layouts.h b/vm/layouts.h index e9cdef6272..9d92d2c386 100755 --- a/vm/layouts.h +++ b/vm/layouts.h @@ -42,7 +42,7 @@ typedef signed long long s64; #define F_TYPE 7 #define F F_TYPE -#define HEADER_TYPE 7 /* anything less than or equal to this is a tag */ +#define HEADER_TYPE 8 /* anything less than this is a tag */ #define GC_COLLECTED 5 /* See gc.c */ diff --git a/vm/master.h b/vm/master.h index 86b5223eaa..e2cafd9a87 100644 --- a/vm/master.h +++ b/vm/master.h @@ -41,6 +41,7 @@ #include "callstack.h" #include "alien.h" #include "quotations.h" +#include "dispatch.h" #include "factor.h" #include "utilities.h" diff --git a/vm/primitives.c b/vm/primitives.c index 80b672d9d2..4281e88fc3 100755 --- a/vm/primitives.c +++ b/vm/primitives.c @@ -144,5 +144,6 @@ void *primitives[] = { primitive_clear_gc_stats, primitive_jit_compile, primitive_load_locals, - primitive_check_datastack + primitive_check_datastack, + primitive_lookup_method }; From c877146531484ef34c93113649e4e26a24687d23 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 16:53:30 -0500 Subject: [PATCH 008/114] Move method-declaration to hints --- basis/hints/hints.factor | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index d445bf72ad..e2506dbe0a 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -42,13 +42,13 @@ SYMBOL: specialize-method? t specialize-method? set-global +: method-declaration ( method -- quot ) + [ "method-generic" word-prop dispatch# object ] + [ "method-class" word-prop ] + bi prefix [ declare ] curry [ ] like ; + : specialize-method ( quot method -- quot' ) - [ - specialize-method? get [ - [ "method-class" word-prop ] [ "method-generic" word-prop ] bi - method-declaration prepend - ] [ drop ] if - ] + [ specialize-method? get [ method-declaration prepend ] [ drop ] if ] [ "method-generic" word-prop "specializer" word-prop ] bi [ specialize-quot ] when* ; From 3dc9fdf9db8113cd6c8276ba0257645c5caab076 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 20:43:01 -0500 Subject: [PATCH 009/114] Fleshed out new dispatch code --- basis/compiler/compiler.factor | 16 +- .../tree/propagation/inlining/inlining.factor | 2 +- basis/debugger/debugger.factor | 2 +- basis/hints/hints.factor | 4 +- basis/see/see.factor | 10 +- basis/stack-checker/backend/backend.factor | 9 +- .../known-words/known-words.factor | 4 +- basis/tools/crossref/crossref.factor | 5 +- .../listener/completion/completion.factor | 12 +- core/bootstrap/primitives.factor | 4 +- .../{standard/compiler => hook}/authors.txt | 0 core/generic/hook/hook-docs.factor | 10 + core/generic/hook/hook.factor | 19 ++ core/generic/single/authors.txt | 1 + core/generic/single/single-docs.factor | 27 +++ .../compiler.factor => single/single.factor} | 125 ++++++++++--- core/generic/standard/authors.txt | 2 +- core/generic/standard/engines/engines.factor | 53 ------ .../engines/predicate/predicate.factor | 38 ---- .../standard/engines/predicate/summary.txt | 1 - core/generic/standard/engines/summary.txt | 1 - core/generic/standard/engines/tag/summary.txt | 1 - core/generic/standard/engines/tag/tag.factor | 71 ------- .../standard/engines/tuple/summary.txt | 1 - .../standard/engines/tuple/tuple.factor | 167 ----------------- core/generic/standard/standard-docs.factor | 35 +--- core/generic/standard/standard.factor | 173 ++---------------- core/generic/standard/summary.txt | 1 - core/syntax/syntax-docs.factor | 4 +- core/syntax/syntax.factor | 2 +- core/words/words.factor | 11 +- 31 files changed, 218 insertions(+), 593 deletions(-) rename core/generic/{standard/compiler => hook}/authors.txt (100%) create mode 100644 core/generic/hook/hook-docs.factor create mode 100644 core/generic/hook/hook.factor create mode 100644 core/generic/single/authors.txt create mode 100644 core/generic/single/single-docs.factor rename core/generic/{standard/compiler/compiler.factor => single/single.factor} (57%) delete mode 100644 core/generic/standard/engines/engines.factor delete mode 100644 core/generic/standard/engines/predicate/predicate.factor delete mode 100644 core/generic/standard/engines/predicate/summary.txt delete mode 100644 core/generic/standard/engines/summary.txt delete mode 100644 core/generic/standard/engines/tag/summary.txt delete mode 100644 core/generic/standard/engines/tag/tag.factor delete mode 100644 core/generic/standard/engines/tuple/summary.txt delete mode 100644 core/generic/standard/engines/tuple/tuple.factor delete mode 100644 core/generic/standard/summary.txt diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index ee91d04b3d..26f9dc47c9 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -2,13 +2,14 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel namespaces arrays sequences io words fry continuations vocabs assocs dlists definitions math graphs generic -combinators deques search-deques macros io source-files.errors -stack-checker stack-checker.state stack-checker.inlining -stack-checker.errors combinators.short-circuit compiler.errors -compiler.units compiler.tree.builder compiler.tree.optimizer -compiler.cfg.builder compiler.cfg.optimizer compiler.cfg.linearization -compiler.cfg.two-operand compiler.cfg.linear-scan -compiler.cfg.stack-frame compiler.codegen compiler.utilities ; +generic.single combinators deques search-deques macros io +source-files.errors stack-checker stack-checker.state +stack-checker.inlining stack-checker.errors combinators.short-circuit +compiler.errors compiler.units compiler.tree.builder +compiler.tree.optimizer compiler.cfg.builder compiler.cfg.optimizer +compiler.cfg.linearization compiler.cfg.two-operand +compiler.cfg.linear-scan compiler.cfg.stack-frame compiler.codegen +compiler.utilities ; IN: compiler SYMBOL: compile-queue @@ -19,6 +20,7 @@ SYMBOL: compiled { [ "forgotten" word-prop ] [ compiled get key? ] + [ single-generic? ] [ inlined-block? ] [ primitive? ] } 1|| not ; diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor index aa66b2f6d7..42c47377e0 100755 --- a/basis/compiler/tree/propagation/inlining/inlining.factor +++ b/basis/compiler/tree/propagation/inlining/inlining.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors kernel arrays sequences math math.order -math.partial-dispatch generic generic.standard generic.math +math.partial-dispatch generic generic.standard generic.single generic.math classes.algebra classes.union sets quotations assocs combinators words namespaces continuations classes fry combinators.smart hints locals diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor index d8ebd5bbf9..2091a26133 100644 --- a/basis/debugger/debugger.factor +++ b/basis/debugger/debugger.factor @@ -6,7 +6,7 @@ sequences assocs sequences.private strings io.styles io.pathnames vectors words system splitting math.parser classes.mixin classes.tuple continuations continuations.private combinators generic.math classes.builtin classes compiler.units -generic.standard vocabs init kernel.private io.encodings +generic.standard generic.single vocabs init kernel.private io.encodings accessors math.order destructors source-files parser classes.tuple.parser effects.parser lexer generic.parser strings.parser vocabs.loader vocabs.parser see diff --git a/basis/hints/hints.factor b/basis/hints/hints.factor index e2506dbe0a..d83275c750 100644 --- a/basis/hints/hints.factor +++ b/basis/hints/hints.factor @@ -1,9 +1,9 @@ -! Copyright (C) 2008 Slava Pestov. +! Copyright (C) 2008, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: parser words definitions kernel sequences assocs arrays kernel.private fry combinators accessors vectors strings sbufs byte-arrays byte-vectors io.binary io.streams.string splitting math -math.parser generic generic.standard generic.standard.engines classes +math.parser generic generic.single generic.standard classes hashtables namespaces ; IN: hints diff --git a/basis/see/see.factor b/basis/see/see.factor index 2494c72fa4..37153b5229 100644 --- a/basis/see/see.factor +++ b/basis/see/see.factor @@ -1,13 +1,13 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes classes.builtin -classes.intersection classes.mixin classes.predicate -classes.singleton classes.tuple classes.union combinators -definitions effects generic generic.standard io io.pathnames +classes.intersection classes.mixin classes.predicate classes.singleton +classes.tuple classes.union combinators definitions effects generic +generic.single generic.standard generic.hook io io.pathnames io.streams.string io.styles kernel make namespaces prettyprint prettyprint.backend prettyprint.config prettyprint.custom -prettyprint.sections sequences sets sorting strings summary -words words.symbol words.constant words.alias ; +prettyprint.sections sequences sets sorting strings summary words +words.symbol words.constant words.alias ; IN: see GENERIC: synopsis* ( defspec -- ) diff --git a/basis/stack-checker/backend/backend.factor b/basis/stack-checker/backend/backend.factor index 4fb5bab96f..338b052316 100755 --- a/basis/stack-checker/backend/backend.factor +++ b/basis/stack-checker/backend/backend.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2004, 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: fry arrays generic io io.streams.string kernel math -namespaces parser sequences strings vectors words quotations -effects classes continuations assocs combinators -compiler.errors accessors math.order definitions sets -generic.standard.engines.tuple hints macros stack-checker.state +USING: fry arrays generic io io.streams.string kernel math namespaces +parser sequences strings vectors words quotations effects classes +continuations assocs combinators compiler.errors accessors math.order +definitions sets hints macros stack-checker.state stack-checker.visitor stack-checker.errors stack-checker.values stack-checker.recursive-state ; IN: stack-checker.backend diff --git a/basis/stack-checker/known-words/known-words.factor b/basis/stack-checker/known-words/known-words.factor index ab205b4a16..a3b0c8d704 100644 --- a/basis/stack-checker/known-words/known-words.factor +++ b/basis/stack-checker/known-words/known-words.factor @@ -12,7 +12,7 @@ classes.tuple.private vectors vectors.private words definitions words.private assocs summary compiler.units system.private combinators locals locals.backend locals.types words.private quotations.private combinators.private stack-checker.values -generic.standard.private +generic.single generic.single.private alien.libraries stack-checker.alien stack-checker.state @@ -236,6 +236,8 @@ M: object infer-call* \ effective-method t "no-compile" set-word-prop \ effective-method subwords [ t "no-compile" set-word-prop ] each +\ execute-unsafe t "no-compile" set-word-prop + \ clear t "no-compile" set-word-prop : non-inline-word ( word -- ) diff --git a/basis/tools/crossref/crossref.factor b/basis/tools/crossref/crossref.factor index c5cd246f2e..6082933bcb 100644 --- a/basis/tools/crossref/crossref.factor +++ b/basis/tools/crossref/crossref.factor @@ -3,8 +3,7 @@ USING: words assocs definitions io io.pathnames io.styles kernel prettyprint sorting see sets sequences arrays hashtables help.crossref help.topics help.markup quotations accessors source-files namespaces -graphs vocabs generic generic.standard.engines.tuple threads -compiler.units init ; +graphs vocabs generic generic.single threads compiler.units init ; IN: tools.crossref SYMBOL: crossref @@ -82,7 +81,7 @@ M: object irrelevant? drop f ; M: default-method irrelevant? drop t ; -M: engine-word irrelevant? drop t ; +M: predicate-engine irrelevant? drop t ; PRIVATE> diff --git a/basis/ui/tools/listener/completion/completion.factor b/basis/ui/tools/listener/completion/completion.factor index ba66121bc2..70131f3212 100644 --- a/basis/ui/tools/listener/completion/completion.factor +++ b/basis/ui/tools/listener/completion/completion.factor @@ -3,13 +3,13 @@ USING: accessors arrays assocs calendar colors colors.constants documents documents.elements fry kernel words sets splitting math math.vectors models.delay models.arrow combinators.short-circuit -parser present sequences tools.completion help.vocabs generic -generic.standard.engines.tuple fonts definitions.icons ui.images -ui.commands ui.operations ui.gadgets ui.gadgets.editors -ui.gadgets.glass ui.gadgets.scrollers ui.gadgets.tables -ui.gadgets.tracks ui.gadgets.labeled +parser present sequences tools.completion help.vocabs generic fonts +definitions.icons ui.images ui.commands ui.operations ui.gadgets +ui.gadgets.editors ui.gadgets.glass ui.gadgets.scrollers +ui.gadgets.tables ui.gadgets.tracks ui.gadgets.labeled ui.gadgets.worlds ui.gadgets.wrappers ui.gestures ui.pens.solid -ui.tools.listener.history combinators vocabs ui.tools.listener.popups ; +ui.tools.listener.history combinators vocabs ui.tools.listener.popups + ; IN: ui.tools.listener.completion ! We don't directly depend on the listener tool but we use a few slots diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index a8e23cd336..42627531aa 100644 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -69,7 +69,7 @@ bootstrapping? on "classes.predicate" "compiler.units" "continuations.private" - "generic.standard.private" + "generic.single.private" "growable" "hashtables" "hashtables.private" @@ -533,7 +533,7 @@ tuple { "jit-compile" "quotations" (( quot -- )) } { "load-locals" "locals.backend" (( ... n -- )) } { "check-datastack" "kernel.private" (( array in# out# -- ? )) } - { "lookup-method" "generic.standard.private" (( object methods -- method )) } + { "lookup-method" "generic.single.private" (( object methods -- method )) } } [ [ first3 ] dip swap make-primitive ] each-index ! Bump build number diff --git a/core/generic/standard/compiler/authors.txt b/core/generic/hook/authors.txt similarity index 100% rename from core/generic/standard/compiler/authors.txt rename to core/generic/hook/authors.txt diff --git a/core/generic/hook/hook-docs.factor b/core/generic/hook/hook-docs.factor new file mode 100644 index 0000000000..9b57d941c0 --- /dev/null +++ b/core/generic/hook/hook-docs.factor @@ -0,0 +1,10 @@ +USING: generic generic.single generic.standard help.markup help.syntax sequences math +math.parser effects ; +IN: generic.hook + +HELP: hook-combination +{ $class-description + "Performs hook method combination . See " { $link POSTPONE: HOOK: } "." +} ; + +{ standard-combination hook-combination } related-words \ No newline at end of file diff --git a/core/generic/hook/hook.factor b/core/generic/hook/hook.factor new file mode 100644 index 0000000000..0574833fab --- /dev/null +++ b/core/generic/hook/hook.factor @@ -0,0 +1,19 @@ +! Copyright (C) 2009 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors definitions generic generic.single kernel +namespaces words ; +IN: generic.hook + +TUPLE: hook-combination < single-combination var ; + +C: hook-combination + +PREDICATE: hook-generic < generic + "combination" word-prop hook-combination? ; + +M: hook-combination picker + combination get var>> [ get ] curry ; + +M: hook-combination dispatch# drop 0 ; + +M: hook-generic definer drop \ HOOK: f ; diff --git a/core/generic/single/authors.txt b/core/generic/single/authors.txt new file mode 100644 index 0000000000..d4f5d6b3ae --- /dev/null +++ b/core/generic/single/authors.txt @@ -0,0 +1 @@ +Slava Pestov \ No newline at end of file diff --git a/core/generic/single/single-docs.factor b/core/generic/single/single-docs.factor new file mode 100644 index 0000000000..8f81be762c --- /dev/null +++ b/core/generic/single/single-docs.factor @@ -0,0 +1,27 @@ +USING: generic help.markup help.syntax sequences math +math.parser effects ; +IN: generic.single + +HELP: no-method +{ $values { "object" "an object" } { "generic" "a generic word" } } +{ $description "Throws a " { $link no-method } " error." } +{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ; + +HELP: inconsistent-next-method +{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } +{ $examples + "The following code throws this error:" + { $code + "GENERIC: error-test ( object -- )" + "" + "M: string error-test print ;" + "" + "M: integer error-test number>string call-next-method ;" + "" + "123 error-test" + } + "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." + $nl + "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" + { $code "M: integer error-test number>string error-test ;" } +} ; \ No newline at end of file diff --git a/core/generic/standard/compiler/compiler.factor b/core/generic/single/single.factor similarity index 57% rename from core/generic/standard/compiler/compiler.factor rename to core/generic/single/single.factor index 0456918b49..d70a378c67 100644 --- a/core/generic/standard/compiler/compiler.factor +++ b/core/generic/single/single.factor @@ -1,13 +1,66 @@ ! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays assocs classes.algebra math combinators -generic.standard.engines hashtables kernel kernel.private layouts -namespaces sequences words sorting quotations effects -generic.standard.private words.private ; -IN: generic.standard.compiler +USING: accessors arrays assocs classes classes.algebra +combinators definitions generic hashtables kernel +kernel.private layouts make math namespaces quotations +sequences words generic.single.private words.private +effects ; +IN: generic.single + +ERROR: no-method object generic ; + +ERROR: inconsistent-next-method class generic ; + +TUPLE: single-combination ; + +PREDICATE: single-generic < generic + "combination" word-prop single-combination? ; + +GENERIC: dispatch# ( word -- n ) + +M: generic dispatch# "combination" word-prop dispatch# ; + +SYMBOL: assumed +SYMBOL: default +SYMBOL: generic-word +SYMBOL: combination + +: with-combination ( combination quot -- ) + [ combination ] dip with-variable ; inline + +HOOK: picker combination ( -- quot ) + +M: single-combination next-method-quot* + [ + 2dup next-method dup [ + [ + pick "predicate" word-prop % + 1quotation , + [ inconsistent-next-method ] 2curry , + \ if , + ] [ ] make picker prepend + ] [ 3drop f ] if + ] with-combination ; + +: single-effective-method ( obj word -- method ) + [ [ order [ instance? ] with find-last nip ] keep method ] + [ "default-method" word-prop ] + bi or ; + +M: single-generic effective-method + [ [ picker ] with-combination call ] keep single-effective-method ; + +M: single-combination make-default-method + combination [ [ picker ] dip [ no-method ] curry append ] with-variable ; ! ! ! Build an engine ! ! ! +: find-default ( methods -- default ) + #! Side-effects methods. + [ object bootstrap-word ] dip delete-at* [ + drop generic-word get "default-method" word-prop + ] unless ; + ! 1. Flatten methods TUPLE: predicate-engine methods ; @@ -28,6 +81,10 @@ TUPLE: predicate-engine methods ; H{ } clone [ [ flatten-method ] curry assoc-each ] keep ; ! 2. Convert methods +: split-methods ( assoc class -- first second ) + [ [ nip class<= not ] curry assoc-filter ] + [ [ nip class<= ] curry assoc-filter ] 2bi ; + : convert-methods ( assoc class word -- assoc' ) over [ split-methods ] 2dip pick assoc-empty? [ 3drop ] [ [ execute ] dip pick set-at ] if ; inline @@ -76,10 +133,6 @@ C: tag-dispatch-engine ; ! ! ! Compile engine ! ! ! -SYMBOL: assumed -SYMBOL: default -SYMBOL: generic-word - GENERIC: compile-engine ( engine -- obj ) : compile-engines ( assoc -- assoc' ) @@ -98,8 +151,7 @@ M: tag-dispatch-engine compile-engine : hi-tag-number ( class -- n ) "type" word-prop ; -: num-hi-tags ( -- n ) - num-types get num-tags get - ; +: num-hi-tags ( -- n ) num-types get num-tags get - ; M: hi-tag-dispatch-engine compile-engine methods>> compile-engines* @@ -123,8 +175,8 @@ M: tuple-dispatch-engine compile-engine : sort-methods ( assoc -- assoc' ) >alist [ keys sort-classes ] keep extract-keys ; -: literalize-methods ( assoc -- assoc' ) - [ [ ] curry \ drop prefix ] assoc-map ; +: quote-methods ( assoc -- assoc' ) + [ 1quotation \ drop prefix ] assoc-map ; : methods-with-default ( engine -- assoc ) methods>> clone default get object bootstrap-word pick set-at ; @@ -141,34 +193,49 @@ M: tuple-dispatch-engine compile-engine } cond ; : class-predicates ( assoc -- assoc ) - [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; + [ [ "predicate" word-prop [ dup ] prepend ] dip ] assoc-map ; -: predicate-engine-effect ( -- effect ) - (dispatch#) get 1+ dup 1+ ; +PREDICATE: predicate-engine-word < word "owner-generic" word-prop ; + +: ( -- word ) + generic-word get name>> "/predicate-engine" append f + dup generic-word get "owner-generic" set-word-prop ; + +M: predicate-engine-word stack-effect "owner-generic" word-prop stack-effect ; : define-predicate-engine ( alist -- word ) - [ generic-word get name>> "/predicate-engine" append f dup ] dip - predicate-engine-effect define-declared ; + [ ] dip + [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ; M: predicate-engine compile-engine methods-with-default sort-methods - literalize-methods + quote-methods prune-redundant-predicates class-predicates - [ peek wrapped>> ] - [ alist>quot picker prepend define-predicate-engine ] if-empty ; + [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ; M: word compile-engine ; M: f compile-engine ; -: build-engine ( generic combination -- engine ) - [ - #>> (dispatch#) set +: build-decision-tree ( generic -- methods ) + { [ generic-word set ] - [ "default-method" word-prop default set ] - [ "methods" word-prop ] tri - compile-engine 1quotation - picker [ lookup-method ] surround - ] with-scope ; \ No newline at end of file + [ "engines" word-prop forget-all ] + [ V{ } clone "engines" set-word-prop ] + [ + "methods" word-prop clone + [ find-default default set ] + [ compile-engine ] bi + ] + } cleave ; + +: execute-unsafe ( word -- ) (execute) ; + +M: single-combination perform-combination + [ + dup build-decision-tree + [ "decision-tree" set-word-prop ] + [ 1quotation picker [ lookup-method execute-unsafe ] surround define ] 2bi + ] with-combination ; \ No newline at end of file diff --git a/core/generic/standard/authors.txt b/core/generic/standard/authors.txt index 1901f27a24..d4f5d6b3ae 100644 --- a/core/generic/standard/authors.txt +++ b/core/generic/standard/authors.txt @@ -1 +1 @@ -Slava Pestov +Slava Pestov \ No newline at end of file diff --git a/core/generic/standard/engines/engines.factor b/core/generic/standard/engines/engines.factor deleted file mode 100644 index b6cb9fc9f7..0000000000 --- a/core/generic/standard/engines/engines.factor +++ /dev/null @@ -1,53 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: assocs kernel kernel.private namespaces quotations -generic math sequences combinators words classes.algebra arrays -; -IN: generic.standard.engines - -SYMBOL: default -SYMBOL: assumed -SYMBOL: (dispatch#) - -GENERIC: engine>quot ( engine -- quot ) - -: engines>quots ( assoc -- assoc' ) - [ engine>quot ] assoc-map ; - -: engines>quots* ( assoc -- assoc' ) - [ over assumed [ engine>quot ] with-variable ] assoc-map ; - -: if-small? ( assoc true false -- ) - [ dup assoc-size 4 <= ] 2dip if ; inline - -: linear-dispatch-quot ( alist -- quot ) - default get [ drop ] prepend swap - [ - [ [ dup ] swap [ eq? ] curry compose ] - [ [ drop ] prepose ] - bi* [ ] like - ] assoc-map - alist>quot ; - -: split-methods ( assoc class -- first second ) - [ [ nip class<= not ] curry assoc-filter ] - [ [ nip class<= ] curry assoc-filter ] 2bi ; - -: convert-methods ( assoc class word -- assoc' ) - over [ split-methods ] 2dip pick assoc-empty? [ - 3drop - ] [ - [ execute ] dip pick set-at - ] if ; inline - -: (picker) ( n -- quot ) - { - { 0 [ [ dup ] ] } - { 1 [ [ over ] ] } - { 2 [ [ pick ] ] } - [ 1- (picker) [ dip swap ] curry ] - } case ; - -: picker ( -- quot ) \ (dispatch#) get (picker) ; - -GENERIC: extra-values ( generic -- n ) diff --git a/core/generic/standard/engines/predicate/predicate.factor b/core/generic/standard/engines/predicate/predicate.factor deleted file mode 100644 index 152b112c2a..0000000000 --- a/core/generic/standard/engines/predicate/predicate.factor +++ /dev/null @@ -1,38 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: generic.standard.engines generic namespaces kernel -kernel.private sequences classes.algebra accessors words -combinators assocs arrays ; -IN: generic.standard.engines.predicate - -TUPLE: predicate-dispatch-engine methods ; - -C: predicate-dispatch-engine - -: class-predicates ( assoc -- assoc ) - [ [ "predicate" word-prop picker prepend ] dip ] assoc-map ; - -: keep-going? ( assoc -- ? ) - assumed get swap second first class<= ; - -: prune-redundant-predicates ( assoc -- default assoc' ) - { - { [ dup empty? ] [ drop [ "Unreachable" throw ] { } ] } - { [ dup length 1 = ] [ first second { } ] } - { [ dup keep-going? ] [ rest-slice prune-redundant-predicates ] } - [ [ first second ] [ rest-slice ] bi ] - } cond ; - -: sort-methods ( assoc -- assoc' ) - >alist [ keys sort-classes ] keep extract-keys ; - -: methods-with-default ( engine -- assoc ) - methods>> clone default get object bootstrap-word pick set-at ; - -M: predicate-dispatch-engine engine>quot - methods-with-default - engines>quots - sort-methods - prune-redundant-predicates - class-predicates - alist>quot ; diff --git a/core/generic/standard/engines/predicate/summary.txt b/core/generic/standard/engines/predicate/summary.txt deleted file mode 100644 index 47fee09ee5..0000000000 --- a/core/generic/standard/engines/predicate/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Chained-conditional dispatch strategy diff --git a/core/generic/standard/engines/summary.txt b/core/generic/standard/engines/summary.txt deleted file mode 100644 index 209190799b..0000000000 --- a/core/generic/standard/engines/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Generic word dispatch strategy implementation diff --git a/core/generic/standard/engines/tag/summary.txt b/core/generic/standard/engines/tag/summary.txt deleted file mode 100644 index 3eea4b11cf..0000000000 --- a/core/generic/standard/engines/tag/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Jump table keyed by pointer tag dispatch strategy diff --git a/core/generic/standard/engines/tag/tag.factor b/core/generic/standard/engines/tag/tag.factor deleted file mode 100644 index 5ed33009c0..0000000000 --- a/core/generic/standard/engines/tag/tag.factor +++ /dev/null @@ -1,71 +0,0 @@ -! Copyright (C) 2008 Slava Pestov. -! See http://factorcode.org/license.txt for BSD license. -USING: classes.private generic.standard.engines namespaces make -arrays assocs sequences.private quotations kernel.private -math slots.private math.private kernel accessors words -layouts sorting sequences combinators ; -IN: generic.standard.engines.tag - -TUPLE: lo-tag-dispatch-engine methods ; - -C: lo-tag-dispatch-engine - -: direct-dispatch-quot ( alist n -- quot ) - default get - [ swap update ] keep - [ dispatch ] curry >quotation ; - -: lo-tag-number ( class -- n ) - dup \ hi-tag bootstrap-word eq? [ - drop \ hi-tag tag-number - ] [ - "type" word-prop - ] if ; - -: sort-tags ( assoc -- alist ) >alist sort-keys reverse ; - -: tag-dispatch-test ( tag# -- quot ) - picker [ tag ] append swap [ eq? ] curry append ; - -: tag-dispatch-quot ( alist -- quot ) - [ default get ] dip - [ [ tag-dispatch-test ] dip ] assoc-map - alist>quot ; - -M: lo-tag-dispatch-engine engine>quot - methods>> engines>quots* - [ [ lo-tag-number ] dip ] assoc-map - [ - [ sort-tags tag-dispatch-quot ] - [ picker % [ tag ] % num-tags get direct-dispatch-quot ] - if-small? % - ] [ ] make ; - -TUPLE: hi-tag-dispatch-engine methods ; - -C: hi-tag-dispatch-engine - -: convert-hi-tag-methods ( assoc -- assoc' ) - \ hi-tag bootstrap-word - \ convert-methods ; - -: num-hi-tags ( -- n ) num-types get num-tags get - ; - -: hi-tag-number ( class -- n ) - "type" word-prop ; - -: hi-tag-quot ( -- quot ) - \ hi-tag def>> ; - -M: hi-tag-dispatch-engine engine>quot - methods>> engines>quots* - [ [ hi-tag-number ] dip ] assoc-map - [ - picker % hi-tag-quot % [ - sort-tags linear-dispatch-quot - ] [ - num-tags get , \ fixnum-fast , - [ [ num-tags get - ] dip ] assoc-map - num-hi-tags direct-dispatch-quot - ] if-small? % - ] [ ] make ; diff --git a/core/generic/standard/engines/tuple/summary.txt b/core/generic/standard/engines/tuple/summary.txt deleted file mode 100644 index cb18ac5c78..0000000000 --- a/core/generic/standard/engines/tuple/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Tuple class dispatch strategy diff --git a/core/generic/standard/engines/tuple/tuple.factor b/core/generic/standard/engines/tuple/tuple.factor deleted file mode 100644 index a0711af095..0000000000 --- a/core/generic/standard/engines/tuple/tuple.factor +++ /dev/null @@ -1,167 +0,0 @@ -! Copyright (c) 2008 Slava Pestov -! See http://factorcode.org/license.txt for BSD license. -USING: kernel classes.tuple.private hashtables assocs sorting -accessors combinators sequences slots.private math.parser words -effects namespaces make generic generic.standard.engines -classes.algebra math math.private kernel.private -quotations arrays definitions ; -IN: generic.standard.engines.tuple - -: nth-superclass% ( n -- ) 2 * 5 + , \ slot , ; inline - -: nth-hashcode% ( n -- ) 2 * 6 + , \ slot , ; inline - -: tuple-layout% ( -- ) - [ { tuple } declare 1 slot { array } declare ] % ; inline - -: tuple-layout-echelon% ( -- ) - [ 4 slot ] % ; inline - -TUPLE: echelon-dispatch-engine n methods ; - -C: echelon-dispatch-engine - -TUPLE: trivial-tuple-dispatch-engine n methods ; - -C: trivial-tuple-dispatch-engine - -TUPLE: tuple-dispatch-engine echelons ; - -: push-echelon ( class method assoc -- ) - [ swap dup "layout" word-prop third ] dip - [ ?set-at ] change-at ; - -: echelon-sort ( assoc -- assoc' ) - V{ } clone [ - [ - push-echelon - ] curry assoc-each - ] keep sort-keys ; - -: ( methods -- engine ) - echelon-sort - [ dupd ] assoc-map - \ tuple-dispatch-engine boa ; - -: convert-tuple-methods ( assoc -- assoc' ) - tuple bootstrap-word - \ convert-methods ; - -M: trivial-tuple-dispatch-engine engine>quot - [ n>> ] [ methods>> ] bi dup assoc-empty? [ - 2drop default get [ drop ] prepend - ] [ - [ - [ nth-superclass% ] - [ engines>quots* linear-dispatch-quot % ] bi* - ] [ ] make - ] if ; - -: hash-methods ( n methods -- buckets ) - >alist V{ } clone [ hashcode 1array ] distribute-buckets - [ ] with map ; - -: class-hash-dispatch-quot ( n methods -- quot ) - [ - \ dup , - [ drop nth-hashcode% ] - [ hash-methods [ engine>quot ] map hash-dispatch-quot % ] 2bi - ] [ ] make ; - -: engine-word-name ( -- string ) - generic get name>> "/tuple-dispatch-engine" append ; - -PREDICATE: engine-word < word - "tuple-dispatch-generic" word-prop generic? ; - -M: engine-word stack-effect - "tuple-dispatch-generic" word-prop - [ extra-values ] [ stack-effect ] bi - dup [ - [ in>> length + ] [ out>> ] [ terminated?>> ] tri - effect boa - ] [ 2drop f ] if ; - -M: engine-word where "tuple-dispatch-generic" word-prop where ; - -M: engine-word crossref? "forgotten" word-prop not ; - -: remember-engine ( word -- ) - generic get "engines" word-prop push ; - -: ( -- word ) - engine-word-name f - dup generic get "tuple-dispatch-generic" set-word-prop ; - -: define-engine-word ( quot -- word ) - [ dup ] dip define ; - -: tuple-dispatch-engine-body ( engine -- quot ) - [ - picker % - tuple-layout% - [ n>> ] [ methods>> ] bi - [ engine>quot ] - [ class-hash-dispatch-quot ] - if-small? % - ] [ ] make ; - -M: echelon-dispatch-engine engine>quot - dup n>> zero? [ - methods>> dup assoc-empty? - [ drop default get ] [ values first engine>quot ] if - ] [ - tuple-dispatch-engine-body - ] if ; - -: >=-case-quot ( default alist -- quot ) - [ [ drop ] prepend ] dip - [ - [ [ dup ] swap [ fixnum>= ] curry compose ] - [ [ drop ] prepose ] - bi* [ ] like - ] assoc-map - alist>quot ; - -: simplify-echelon-alist ( default alist -- default' alist' ) - dup empty? [ - dup first first 1 <= [ - nip unclip second swap - simplify-echelon-alist - ] when - ] unless ; - -: echelon-case-quot ( alist -- quot ) - #! We don't have to test for echelon 1 since all tuple - #! classes are at least at depth 1 in the inheritance - #! hierarchy. - default get swap simplify-echelon-alist - [ - [ - picker % - tuple-layout% - tuple-layout-echelon% - >=-case-quot % - ] [ ] make - ] unless-empty ; - -M: tuple-dispatch-engine engine>quot - [ - [ - tuple assumed set - echelons>> unclip-last - [ - [ - engine>quot - over 0 = [ - define-engine-word - [ remember-engine ] [ 1quotation ] bi - ] unless - dup default set - ] assoc-map - ] - [ first2 engine>quot 2array ] bi* - suffix - ] with-scope - echelon-case-quot % - ] [ ] make ; diff --git a/core/generic/standard/standard-docs.factor b/core/generic/standard/standard-docs.factor index 6e788eb947..33da0037b3 100644 --- a/core/generic/standard/standard-docs.factor +++ b/core/generic/standard/standard-docs.factor @@ -1,12 +1,7 @@ -USING: generic help.markup help.syntax sequences math +USING: generic generic.single help.markup help.syntax sequences math math.parser effects ; IN: generic.standard -HELP: no-method -{ $values { "object" "an object" } { "generic" "a generic word" } } -{ $description "Throws a " { $link no-method } " error." } -{ $error-description "Thrown by the " { $snippet "generic" } " word to indicate it does not have a method for the class of " { $snippet "object" } "." } ; - HELP: standard-combination { $class-description "Performs standard method combination." @@ -22,32 +17,6 @@ HELP: standard-combination } } ; -HELP: hook-combination -{ $class-description - "Performs hook method combination . See " { $link POSTPONE: HOOK: } "." -} ; - HELP: define-simple-generic { $values { "word" "a word" } { "effect" effect } } -{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; - -{ standard-combination hook-combination } related-words - -HELP: inconsistent-next-method -{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." } -{ $examples - "The following code throws this error:" - { $code - "GENERIC: error-test ( object -- )" - "" - "M: string error-test print ;" - "" - "M: integer error-test number>string call-next-method ;" - "" - "123 error-test" - } - "This results in the method on " { $link integer } " being called, which then passes a string to " { $link POSTPONE: call-next-method } ". However, this fails because the string is not compatible with the current method." - $nl - "This usually indicates programmer error; if the intention above was to call the string method on the result of " { $link number>string } ", the code should be rewritten as follows:" - { $code "M: integer error-test number>string error-test ;" } -} ; +{ $description "Defines a generic word with the " { $link standard-combination } " method combination and a dispatch position of 0." } ; \ No newline at end of file diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 5dbc0d17a1..bbf458ef1d 100644 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -1,100 +1,10 @@ -! Copyright (C) 2005, 2008 Slava Pestov. +! Copyright (C) 2009 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: arrays assocs kernel kernel.private slots.private math -namespaces make sequences vectors words quotations definitions -hashtables layouts combinators sequences.private generic -classes classes.algebra classes.private generic.standard.engines -generic.standard.engines.tag generic.standard.engines.predicate -generic.standard.engines.tuple accessors ; +USING: accessors definitions generic generic.single kernel +namespaces words math combinators ; IN: generic.standard -GENERIC: dispatch# ( word -- n ) - -M: generic dispatch# - "combination" word-prop dispatch# ; - -GENERIC: method-declaration ( class generic -- quot ) - -M: generic method-declaration - "combination" word-prop method-declaration ; - -M: quotation engine>quot - assumed get generic get method-declaration prepend ; - -ERROR: no-method object generic ; - -: error-method ( word -- quot ) - [ picker ] dip [ no-method ] curry append ; - -: push-method ( method specializer atomic assoc -- ) - [ - [ H{ } clone ] unless* - [ methods>> set-at ] keep - ] change-at ; - -: flatten-method ( class method assoc -- ) - [ [ flatten-class keys ] keep ] 2dip [ - [ spin ] dip push-method - ] 3curry each ; - -: flatten-methods ( assoc -- assoc' ) - H{ } clone [ - [ - flatten-method - ] curry assoc-each - ] keep ; - -: ( assoc -- engine ) - flatten-methods - convert-tuple-methods - convert-hi-tag-methods - ; - -: mangle-method ( method -- quot ) - 1quotation generic get extra-values \ drop - prepend [ ] like ; - -: find-default ( methods -- quot ) - #! Side-effects methods. - [ object bootstrap-word ] dip delete-at* [ - drop generic get "default-method" word-prop mangle-method - ] unless ; - -: ( word -- engine ) - object bootstrap-word assumed set { - [ generic set ] - [ "engines" word-prop forget-all ] - [ V{ } clone "engines" set-word-prop ] - [ - "methods" word-prop - [ mangle-method ] assoc-map - [ find-default default set ] - [ ] - bi - ] - } cleave ; - -: single-combination ( word -- quot ) - [ engine>quot ] with-scope ; - -ERROR: inconsistent-next-method class generic ; - -: single-next-method-quot ( class generic -- quot/f ) - 2dup next-method dup [ - [ - pick "predicate" word-prop % - 1quotation , - [ inconsistent-next-method ] 2curry , - \ if , - ] [ ] make - ] [ 3drop f ] if ; - -: single-effective-method ( obj word -- method ) - [ [ order [ instance? ] with find-last nip ] keep method ] - [ "default-method" word-prop ] - bi or ; - -TUPLE: standard-combination # ; +TUPLE: standard-combination < single-combination # ; C: standard-combination @@ -102,79 +12,26 @@ PREDICATE: standard-generic < generic "combination" word-prop standard-combination? ; PREDICATE: simple-generic < standard-generic - "combination" word-prop #>> zero? ; + "combination" word-prop #>> 0 = ; CONSTANT: simple-combination T{ standard-combination f 0 } : define-simple-generic ( word effect -- ) [ simple-combination ] dip define-generic ; -: with-standard ( combination quot -- quot' ) - [ #>> (dispatch#) ] dip with-variable ; inline +: (picker) ( n -- quot ) + { + { 0 [ [ dup ] ] } + { 1 [ [ over ] ] } + { 2 [ [ pick ] ] } + [ 1- (picker) [ dip swap ] curry ] + } case ; -M: standard-generic extra-values drop 0 ; - -M: standard-combination make-default-method - [ error-method ] with-standard ; - -M: standard-combination perform-combination - [ drop ] [ [ single-combination ] with-standard ] 2bi define ; +M: standard-combination picker + combination get #>> (picker) ; M: standard-combination dispatch# #>> ; -M: standard-combination method-declaration - dispatch# object swap prefix [ declare ] curry [ ] like ; - -M: standard-combination next-method-quot* - [ - single-next-method-quot - dup [ picker prepend ] when - ] with-standard ; - -M: standard-generic effective-method - [ dispatch# (picker) call ] keep single-effective-method ; - -TUPLE: hook-combination var ; - -C: hook-combination - -PREDICATE: hook-generic < generic - "combination" word-prop hook-combination? ; - -: with-hook ( combination quot -- quot' ) - 0 (dispatch#) [ - [ hook-combination ] dip with-variable - ] with-variable ; inline - -: prepend-hook-var ( quot -- quot' ) - hook-combination get var>> [ get ] curry prepend ; - -M: hook-combination dispatch# drop 0 ; - -M: hook-combination method-declaration 2drop [ ] ; - -M: hook-generic extra-values drop 1 ; - -M: hook-generic effective-method - [ "combination" word-prop var>> get ] keep - single-effective-method ; - -M: hook-combination make-default-method - [ error-method prepend-hook-var ] with-hook ; - -M: hook-combination perform-combination - [ drop ] [ - [ single-combination prepend-hook-var ] with-hook - ] 2bi define ; - -M: hook-combination next-method-quot* - [ - single-next-method-quot - dup [ prepend-hook-var ] when - ] with-hook ; - M: simple-generic definer drop \ GENERIC: f ; -M: standard-generic definer drop \ GENERIC# f ; - -M: hook-generic definer drop \ HOOK: f ; +M: standard-generic definer drop \ GENERIC# f ; \ No newline at end of file diff --git a/core/generic/standard/summary.txt b/core/generic/standard/summary.txt deleted file mode 100644 index 5e731c6f15..0000000000 --- a/core/generic/standard/summary.txt +++ /dev/null @@ -1 +0,0 @@ -Standard method combination used for most generic words diff --git a/core/syntax/syntax-docs.factor b/core/syntax/syntax-docs.factor index 7ab287fd20..e8f86faa9d 100644 --- a/core/syntax/syntax-docs.factor +++ b/core/syntax/syntax-docs.factor @@ -1,7 +1,7 @@ USING: generic help.syntax help.markup kernel math parser words effects classes generic.standard classes.tuple generic.math -generic.standard arrays io.pathnames vocabs.loader io sequences -assocs words.symbol words.alias words.constant combinators ; +generic.standard generic.single arrays io.pathnames vocabs.loader io +sequences assocs words.symbol words.alias words.constant combinators ; IN: syntax ARTICLE: "parser-algorithm" "Parser algorithm" diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 2e072f72d8..3512b92e4c 100644 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -4,7 +4,7 @@ USING: accessors alien arrays byte-arrays definitions generic hashtables kernel math namespaces parser lexer sequences strings strings.parser sbufs vectors words words.symbol words.constant words.alias quotations io assocs splitting classes.tuple -generic.standard generic.math generic.parser classes +generic.standard generic.hook generic.math generic.parser classes io.pathnames vocabs vocabs.parser classes.parser classes.union classes.intersection classes.mixin classes.predicate classes.singleton classes.tuple.parser compiler.units diff --git a/core/words/words.factor b/core/words/words.factor index eb0599db78..894b671494 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -154,8 +154,15 @@ M: word reset-word : reset-generic ( word -- ) [ subwords forget-all ] [ reset-word ] - [ { "methods" "combination" "default-method" } reset-props ] - tri ; + [ + { + "methods" + "combination" + "default-method" + "engines" + "decision-tree" + } reset-props + ] tri ; : gensym ( -- word ) "( gensym )" f ; From d03b1eef01778242512c6fb0a7fd542fb7ab78e7 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Fri, 24 Apr 2009 20:54:30 -0500 Subject: [PATCH 010/114] Compile methods of generic words since the generic word itself doesn't get compiled --- basis/compiler/compiler.factor | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/basis/compiler/compiler.factor b/basis/compiler/compiler.factor index 26f9dc47c9..efa6294c98 100644 --- a/basis/compiler/compiler.factor +++ b/basis/compiler/compiler.factor @@ -163,7 +163,10 @@ M: optimizing-compiler recompile ( words -- alist ) [ compile-queue set H{ } clone compiled set - [ queue-compile ] each + [ + [ queue-compile ] + [ subwords [ compile-dependency ] each ] bi + ] each compile-queue get compile-loop compiled get >alist ] with-scope ; From b31f8a0d15775357aabbd0ce8e04dea4ad7c3810 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 24 Apr 2009 23:23:02 -0500 Subject: [PATCH 011/114] peg lexer changes --- extra/peg-lexer/peg-lexer.factor | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/extra/peg-lexer/peg-lexer.factor b/extra/peg-lexer/peg-lexer.factor index e7acf1f5bb..e58d8dd65b 100644 --- a/extra/peg-lexer/peg-lexer.factor +++ b/extra/peg-lexer/peg-lexer.factor @@ -1,5 +1,6 @@ USING: hashtables assocs sequences locals math accessors multiline delegate strings -delegate.protocols kernel peg peg.ebnf lexer namespaces combinators parser words ; +delegate.protocols kernel peg peg.ebnf peg.private lexer namespaces combinators parser +words ; IN: peg-lexer TUPLE: lex-hash hash ; @@ -43,11 +44,11 @@ M: lex-hash at* : parse* ( parser -- ast ) compile - [ execute( -- result ) [ error-stack get first throw ] unless* ] with-global-lexer + [ execute [ error-stack get first throw ] unless* ] with-global-lexer ast>> ; : create-bnf ( name parser -- ) - reset-tokenizer [ lexer get skip-blank parse* parsed ] curry + reset-tokenizer [ lexer get skip-blank parse* dup ignore? [ drop ] [ parsed ] if ] curry define-syntax ; SYNTAX: ON-BNF: From 8be8357e4d7393d114a588b2bee38ec2abdb6632 Mon Sep 17 00:00:00 2001 From: Sam Anklesaria Date: Fri, 24 Apr 2009 23:23:35 -0500 Subject: [PATCH 012/114] ui.gadgets.alerts updated for new ui --- extra/ui/gadgets/alerts/alerts.factor | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/extra/ui/gadgets/alerts/alerts.factor b/extra/ui/gadgets/alerts/alerts.factor index 04c6b013df..03d60957fa 100644 --- a/extra/ui/gadgets/alerts/alerts.factor +++ b/extra/ui/gadgets/alerts/alerts.factor @@ -1,4 +1,4 @@ -USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences io.styles ; +USING: accessors ui ui.gadgets ui.gadgets.labels ui.gadgets.buttons ui.gadgets.packs locals sequences fonts io.styles ; IN: ui.gadgets.alerts -:: alert ( quot string -- ) { 10 10 } >>gap 1 >>align string