88 lines
2.2 KiB
Factor
Executable File
88 lines
2.2 KiB
Factor
Executable File
! Copyright (C) 2007, 2008 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: fry accessors arrays kernel words sequences generic math
|
|
namespaces quotations assocs combinators classes.tuple
|
|
classes.tuple.private effects summary hashtables classes generic
|
|
sets definitions generic.standard slots.private continuations
|
|
stack-checker.backend stack-checker.state stack-checker.visitor
|
|
stack-checker.errors ;
|
|
IN: stack-checker.transforms
|
|
|
|
SYMBOL: +transform-quot+
|
|
SYMBOL: +transform-n+
|
|
|
|
: (apply-transform) ( quot n -- newquot )
|
|
dup zero? [
|
|
drop recursive-state get 1array
|
|
] [
|
|
consume-d
|
|
[ #drop, ]
|
|
[ [ literal value>> ] map ]
|
|
[ first literal recursion>> ] tri prefix
|
|
] if
|
|
swap with-datastack ;
|
|
|
|
: apply-transform ( word -- )
|
|
[ +inlined+ depends-on ] [
|
|
[ +transform-quot+ word-prop ]
|
|
[ +transform-n+ word-prop ]
|
|
bi (apply-transform)
|
|
first2 swap infer-quot
|
|
] bi ;
|
|
|
|
: apply-macro ( word -- )
|
|
[ +inlined+ depends-on ] [
|
|
[ "macro" word-prop ]
|
|
[ "declared-effect" word-prop in>> length ]
|
|
bi (apply-transform)
|
|
first2 swap infer-quot
|
|
] bi ;
|
|
|
|
: define-transform ( word quot n -- )
|
|
[ drop +transform-quot+ set-word-prop ]
|
|
[ nip +transform-n+ set-word-prop ]
|
|
3bi ;
|
|
|
|
! 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
|
|
|
|
\ boa [
|
|
dup tuple-class? [
|
|
dup +inlined+ depends-on
|
|
[ "boa-check" word-prop ]
|
|
[ tuple-layout '[ , <tuple-boa> ] ]
|
|
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
|
|
|
|
! Deprecated
|
|
\ get-slots [ [ 1quotation ] map [ cleave ] curry ] 1 define-transform
|
|
|
|
\ set-slots [ <reversed> [ get-slots ] curry ] 1 define-transform
|