1 ! (c)2009 Joe Groff bsd license
2 USING: arrays assocs classes classes.tuple.private combinators
3 effects.parser generic.parser kernel math math.order parser
4 quotations sequences sorting words ;
7 ERROR: no-pair-method a b generic ;
9 : ?swap ( a b ? -- a/b b/a )
12 : method-sort-key ( pair -- key )
13 first2 [ tuple-layout third ] bi@ + ;
15 : pair-match-condition ( pair -- quot )
16 first2 [ [ instance? ] swap prefix ] bi@ [ ] 2sequence
17 [ 2dup ] [ bi* and ] surround ;
19 : pair-method-cond ( pair quot -- array )
20 [ pair-match-condition ] [ ] bi* 2array ;
22 : sorted-pair-methods ( word -- alist )
23 "pair-generic-methods" word-prop >alist
24 [ first method-sort-key ] inv-sort-with ;
26 : pair-generic-definition ( word -- def )
27 [ sorted-pair-methods [ first2 pair-method-cond ] map ]
28 [ [ throw-no-pair-method ] curry suffix ] bi 1quotation
29 [ 2dup [ class-of ] compare +gt+ eq? ?swap ] [ cond ] surround ;
31 : make-pair-generic ( word -- )
32 dup pair-generic-definition define ;
34 : define-pair-generic ( word effect -- )
35 [ swap set-stack-effect ]
36 [ drop H{ } clone "pair-generic-methods" set-word-prop ]
37 [ drop make-pair-generic ] 2tri ;
39 : (PAIR-GENERIC:) ( -- )
40 scan-new-generic scan-effect define-pair-generic ;
42 SYNTAX: PAIR-GENERIC: (PAIR-GENERIC:) ;
44 : define-pair-method ( a b pair-generic definition -- )
46 [ "pair-generic-methods" word-prop swapd set-at ]
47 [ make-pair-generic ] bi ;
49 : ?prefix-swap ( quot ? -- quot' )
50 [ \ swap prefix ] when ;
53 scan-word scan-word 2dup <=> +gt+ eq? [
54 ?swap scan-word parse-definition
55 ] keep ?prefix-swap define-pair-method ;
57 SYNTAX: PAIR-M: (PAIR-M:) ;