! 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
{
[ "forgotten" word-prop ]
[ compiled get key? ]
+ [ single-generic? ]
[ inlined-block? ]
[ primitive? ]
} 1|| not ;
! 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
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
-! 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
! 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 -- )
! 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
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
\ 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 -- )
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
M: default-method irrelevant? drop t ;
-M: engine-word irrelevant? drop t ;
+M: predicate-engine irrelevant? drop t ;
PRIVATE>
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
"classes.predicate"
"compiler.units"
"continuations.private"
- "generic.standard.private"
+ "generic.single.private"
"growable"
"hashtables"
"hashtables.private"
{ "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
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! 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> 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 ;
--- /dev/null
+Slava Pestov
\ No newline at end of file
--- /dev/null
+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
--- /dev/null
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+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 ;
+
+: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
+
+: push-method ( method specializer atomic assoc -- )
+ [
+ [ H{ } clone <predicate-engine> ] 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
+: 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
+
+! 2.1 Convert tuple methods
+TUPLE: echelon-dispatch-engine n methods ;
+
+C: <echelon-dispatch-engine> 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 ;
+
+: <tuple-dispatch-engine> ( methods -- engine )
+ echelon-sort
+ [ dupd <echelon-dispatch-engine> ] assoc-map
+ \ tuple-dispatch-engine boa ;
+
+: convert-tuple-methods ( assoc -- assoc' )
+ tuple bootstrap-word
+ \ <tuple-dispatch-engine> convert-methods ;
+
+! 2.2 Convert hi-tag methods
+TUPLE: hi-tag-dispatch-engine methods ;
+
+C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
+
+: convert-hi-tag-methods ( assoc -- assoc' )
+ \ hi-tag bootstrap-word
+ \ <hi-tag-dispatch-engine> convert-methods ;
+
+! 3 Tag methods
+TUPLE: tag-dispatch-engine methods ;
+
+C: <tag-dispatch-engine> tag-dispatch-engine
+
+: <engine> ( assoc -- engine )
+ flatten-methods
+ convert-tuple-methods
+ convert-hi-tag-methods
+ <tag-dispatch-engine> ;
+
+! ! ! Compile engine ! ! !
+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 <array> [ <enum> 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 <array> default get prefix
+ [ <enum> swap update ] keep
+ ] with-variable ;
+
+: sort-methods ( assoc -- assoc' )
+ >alist [ keys sort-classes ] keep extract-keys ;
+
+: quote-methods ( assoc -- assoc' )
+ [ 1quotation \ 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 [ dup ] prepend ] dip ] assoc-map ;
+
+PREDICATE: predicate-engine-word < word "owner-generic" word-prop ;
+
+: <predicate-engine-word> ( -- word )
+ generic-word get name>> "/predicate-engine" append f <word>
+ 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 )
+ [ <predicate-engine-word> ] dip
+ [ define ] [ drop generic-word get "engines" word-prop push ] [ drop ] 2tri ;
+
+M: predicate-engine compile-engine
+ methods-with-default
+ sort-methods
+ quote-methods
+ prune-redundant-predicates
+ class-predicates
+ [ peek ] [ alist>quot picker prepend define-predicate-engine ] if-empty ;
+
+M: word compile-engine ;
+
+M: f compile-engine ;
+
+: build-decision-tree ( generic -- methods )
+ {
+ [ generic-word set ]
+ [ "engines" word-prop forget-all ]
+ [ V{ } clone "engines" set-word-prop ]
+ [
+ "methods" word-prop clone
+ [ find-default default set ]
+ [ <engine> 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
-Slava Pestov
+Slava Pestov
\ No newline at end of file
+++ /dev/null
-Slava Pestov
\ No newline at end of file
+++ /dev/null
-! 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 ;
-
-: <predicate-engine> ( methods -- engine ) predicate-engine boa ;
-
-: push-method ( method specializer atomic assoc -- )
- [
- [ H{ } clone <predicate-engine> ] 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> 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 ;
-
-: <tuple-dispatch-engine> ( methods -- engine )
- echelon-sort
- [ dupd <echelon-dispatch-engine> ] assoc-map
- \ tuple-dispatch-engine boa ;
-
-: convert-tuple-methods ( assoc -- assoc' )
- tuple bootstrap-word
- \ <tuple-dispatch-engine> convert-methods ;
-
-! 2.2 Convert hi-tag methods
-TUPLE: hi-tag-dispatch-engine methods ;
-
-C: <hi-tag-dispatch-engine> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
- \ hi-tag bootstrap-word
- \ <hi-tag-dispatch-engine> convert-methods ;
-
-! 3 Tag methods
-TUPLE: tag-dispatch-engine methods ;
-
-C: <tag-dispatch-engine> tag-dispatch-engine
-
-: <engine> ( assoc -- engine )
- flatten-methods
- convert-tuple-methods
- convert-hi-tag-methods
- <tag-dispatch-engine> ;
-
-! ! ! 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 <array> [ <enum> 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 <array> default get prefix
- [ <enum> 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+ <effect> ;
-
-: define-predicate-engine ( alist -- word )
- [ generic-word get name>> "/predicate-engine" append f <word> 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
- <engine> compile-engine 1quotation
- picker [ lookup-method ] surround
- ] with-scope ;
\ No newline at end of file
+++ /dev/null
-! 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 )
+++ /dev/null
-! 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> 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 ;
+++ /dev/null
-Chained-conditional dispatch strategy
+++ /dev/null
-Generic word dispatch strategy implementation
+++ /dev/null
-Jump table keyed by pointer tag dispatch strategy
+++ /dev/null
-! 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> lo-tag-dispatch-engine
-
-: direct-dispatch-quot ( alist n -- quot )
- default get <array>
- [ <enum> 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> hi-tag-dispatch-engine
-
-: convert-hi-tag-methods ( assoc -- assoc' )
- \ hi-tag bootstrap-word
- \ <hi-tag-dispatch-engine> 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 ;
+++ /dev/null
-Tuple class dispatch strategy
+++ /dev/null
-! 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> echelon-dispatch-engine
-
-TUPLE: trivial-tuple-dispatch-engine n methods ;
-
-C: <trivial-tuple-dispatch-engine> 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 ;
-
-: <tuple-dispatch-engine> ( methods -- engine )
- echelon-sort
- [ dupd <echelon-dispatch-engine> ] assoc-map
- \ tuple-dispatch-engine boa ;
-
-: convert-tuple-methods ( assoc -- assoc' )
- tuple bootstrap-word
- \ <tuple-dispatch-engine> 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
- [ <trivial-tuple-dispatch-engine> ] 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 ;
-
-: <engine-word> ( -- word )
- engine-word-name f <word>
- dup generic get "tuple-dispatch-generic" set-word-prop ;
-
-: define-engine-word ( quot -- word )
- [ <engine-word> dup ] dip define ;
-
-: tuple-dispatch-engine-body ( engine -- quot )
- [
- picker %
- tuple-layout%
- [ n>> ] [ methods>> ] bi
- [ <trivial-tuple-dispatch-engine> 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 ;
-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."
}
} ;
-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
-! 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 <predicate-dispatch-engine> ] 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 ;
-
-: <big-dispatch-engine> ( assoc -- engine )
- flatten-methods
- convert-tuple-methods
- convert-hi-tag-methods
- <lo-tag-dispatch-engine> ;
-
-: mangle-method ( method -- quot )
- 1quotation generic get extra-values \ drop <repetition>
- 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 ;
-
-: <standard-engine> ( 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 ]
- [ <big-dispatch-engine> ]
- bi
- ]
- } cleave ;
-
-: single-combination ( word -- quot )
- [ <standard-engine> 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> standard-combination
"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 <array> 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> 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
+++ /dev/null
-Standard method combination used for most generic words
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"
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
: 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 <word> ;
projects / factor.git / commitdiff