steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fleshed out new dispatch code

db4
Slava Pestov 2009-04-24 20:43:01 -05:00
parent c877146531
commit 3dc9fdf9db
31 changed files with 218 additions and 593 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
basis/compiler/compiler.factor
View File

@ -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 ;

2
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -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

2
basis/debugger/debugger.factor
View File

@ -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

4
basis/hints/hints.factor
View File

@ -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

10
basis/see/see.factor
View File

@ -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 -- )

9
basis/stack-checker/backend/backend.factor
View File

@ -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

4
basis/stack-checker/known-words/known-words.factor
View File

@ -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 -- )

5
basis/tools/crossref/crossref.factor
View File

@ -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>

12
basis/ui/tools/listener/completion/completion.factor
View File

@ -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

4
core/bootstrap/primitives.factor
View File

@ -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

0
core/generic/standard/compiler/authors.txt → core/generic/hook/authors.txt
View File

10
core/generic/hook/hook-docs.factor Normal file
View File

@ -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

19
core/generic/hook/hook.factor Normal file
View File

@ -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> 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 ;

1
core/generic/single/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

27
core/generic/single/single-docs.factor Normal file
View File

@ -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 ;" }
} ;

125
core/generic/standard/compiler/compiler.factor → core/generic/single/single.factor
View File

@ -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> tag-dispatch-engine
<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+ <effect> ;
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 )
[ generic-word get name>> "/predicate-engine" append f <word> dup ] dip
predicate-engine-effect define-declared ;
[ <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
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
<engine> compile-engine 1quotation
picker [ lookup-method ] surround
] with-scope ;
[ "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 ;

2
core/generic/standard/authors.txt
View File

@ -1 +1 @@
Slava Pestov
Slava Pestov

53
core/generic/standard/engines/engines.factor
View File

@ -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 )

38
core/generic/standard/engines/predicate/predicate.factor
View File

@ -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> 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 ;

1
core/generic/standard/engines/predicate/summary.txt
View File

@ -1 +0,0 @@
Chained-conditional dispatch strategy

1
core/generic/standard/engines/summary.txt
View File

@ -1 +0,0 @@
Generic word dispatch strategy implementation

1
core/generic/standard/engines/tag/summary.txt
View File

@ -1 +0,0 @@
Jump table keyed by pointer tag dispatch strategy

71
core/generic/standard/engines/tag/tag.factor
View File

@ -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> 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 ;

1
core/generic/standard/engines/tuple/summary.txt
View File

@ -1 +0,0 @@
Tuple class dispatch strategy

167
core/generic/standard/engines/tuple/tuple.factor
View File

@ -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> 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 ;

35
core/generic/standard/standard-docs.factor
View File

@ -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." } ;

173
core/generic/standard/standard.factor
View File

@ -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 <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
@ -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 <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 ;

1
core/generic/standard/summary.txt
View File

@ -1 +0,0 @@
Standard method combination used for most generic words

4
core/syntax/syntax-docs.factor
View File

@ -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"

2
core/syntax/syntax.factor
View File

@ -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

11
core/words/words.factor
View File

@ -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 <word> ;