81 lines
2.0 KiB
Factor
81 lines
2.0 KiB
Factor
|
! Copyright (C) 2007, 2008 Slava Pestov.
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
USING: accessors arrays kernel words sequences generic math
|
||
|
|
namespaces quotations assocs combinators
|
||
|
|
inference.backend inference.dataflow inference.state
|
||
|
|
classes.tuple classes.tuple.private effects summary hashtables
|
||
|
|
classes generic sets definitions generic.standard slots.private ;
|
||
|
|
IN: inference.transforms
|
||
|
|
|
||
|
|
: pop-literals ( n -- rstate seq )
|
||
|
|
dup zero? [
|
||
|
|
drop recursive-state get { }
|
||
|
|
] [
|
||
|
|
dup ensure-values
|
||
|
|
f swap [ 2drop pop-literal ] map reverse
|
||
|
|
] if ;
|
||
|
|
|
||
|
|
: transform-quot ( quot n -- newquot )
|
||
|
|
[ pop-literals [ ] each ] curry
|
||
|
|
swap
|
||
|
|
[ swap infer-quot ] 3compose ;
|
||
|
|
|
||
|
|
: define-transform ( word quot n -- )
|
||
|
|
transform-quot "infer" set-word-prop ;
|
||
|
|
|
||
|
|
! Combinators
|
||
|
|
\ cond [
|
||
|
|
cond>quot
|
||
|
|
] 1 define-transform
|
||
|
|
|
||
|
|
\ case [
|
||
|
|
dup empty? [
|
||
|
|
drop [ no-case ]
|
||
|
|
] [
|
||
|
|
dup peek quotation? [
|
||
|
dup peek swap but-last
|
||
|
|
] [
|
||
|
|
[ no-case ] swap
|
||
|
|
] if case>quot
|
||
|
|
] if
|
||
|
|
] 1 define-transform
|
||
|
|
|
||
|
|
\ cleave [ cleave>quot ] 1 define-transform
|
||
|
|
|
||
|
|
\ 2cleave [ 2cleave>quot ] 1 define-transform
|
||
|
|
|
||
|
|
\ 3cleave [ 3cleave>quot ] 1 define-transform
|
||
|
|
|
||
|
|
\ spread [ spread>quot ] 1 define-transform
|
||
|
|
|
||
|
|
! Tuple operations
|
||
|
|
: [get-slots] ( slots -- quot )
|
||
|
|
[ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ;
|
||
|
|
|
||
|
|
\ get-slots [ [get-slots] ] 1 define-transform
|
||
|
|
|
||
|
|
ERROR: duplicated-slots-error names ;
|
||
|
|
|
||
|
|
M: duplicated-slots-error summary
|
||
|
|
drop "Calling set-slots with duplicate slot setters" ;
|
||
|
|
|
||
|
|
\ set-slots [
|
||
|
|
dup all-unique?
|
||
|
|
[ <reversed> [get-slots] ] [ duplicated-slots-error ] if
|
||
|
|
] 1 define-transform
|
||
|
|
|
||
|
|
\ boa [
|
||
|
|
dup tuple-class? [
|
||
|
|
dup +inlined+ depends-on
|
||
|
|
[ "boa-check" word-prop ]
|
||
|
|
[ tuple-layout [ <tuple-boa> ] curry ]
|
||
|
|
bi append
|
||
|
|
] [
|
||
|
|
\ boa \ no-method boa time-bomb
|
||
|
|
] if
|
||
|
|
] 1 define-transform
|
||
|
|
|
||
|
|
\ (call-next-method) [
|
||
|
|
[ [ +inlined+ depends-on ] bi@ ] [ next-method-quot ] 2bi
|
||
|
|
] 2 define-transform
|