Slight speedup
parent
b4683b1985
commit
77561573e0
|
@ -4,7 +4,6 @@
|
|||
- document inference errors
|
||||
- update docs for declared effects
|
||||
- better doc for accumulate, link from tree
|
||||
- bootstrap speedup with compiling recursives
|
||||
- RT_WORD should refer to XTs not word objects.
|
||||
- better listener multi-line expression handling
|
||||
- history doesn't work in a good way if you ^K the input
|
||||
|
|
|
@ -7,6 +7,7 @@ words ;
|
|||
|
||||
: word-dataflow ( word -- dataflow )
|
||||
[
|
||||
dup ?no-effect
|
||||
dup dup add-recursive-state
|
||||
dup specialized-def (dataflow)
|
||||
swap current-effect check-effect
|
||||
|
|
|
@ -98,6 +98,11 @@ M: quotation infer-quot
|
|||
inference-error
|
||||
] unless ;
|
||||
|
||||
: undo-infer ( -- )
|
||||
recorded get
|
||||
[ "infer" word-prop not ] subset
|
||||
[ f "infer-effect" set-word-prop ] each ;
|
||||
|
||||
: with-infer ( quot -- )
|
||||
[
|
||||
[
|
||||
|
@ -107,7 +112,7 @@ M: quotation infer-quot
|
|||
call
|
||||
check-return
|
||||
] [
|
||||
recorded get [ f "infer-effect" set-word-prop ] each
|
||||
undo-infer
|
||||
rethrow
|
||||
] recover
|
||||
] with-scope ;
|
||||
|
|
|
@ -118,10 +118,14 @@ TUPLE: effect-error word effect ;
|
|||
: effect-error ( word effect -- * ) <effect-error> throw ;
|
||||
|
||||
: check-effect ( word effect -- )
|
||||
over recorded get push
|
||||
dup pick "declared-effect" word-prop dup
|
||||
[ effect<= [ effect-error ] unless ] [ 2drop ] if
|
||||
"infer-effect" set-word-prop ;
|
||||
over "infer" word-prop [
|
||||
2drop
|
||||
] [
|
||||
over recorded get push
|
||||
dup pick "declared-effect" word-prop dup
|
||||
[ effect<= [ effect-error ] unless ] [ 2drop ] if
|
||||
"infer-effect" set-word-prop
|
||||
] if ;
|
||||
|
||||
M: compound apply-word
|
||||
#! Infer a compound word's stack effect.
|
||||
|
@ -131,8 +135,11 @@ M: compound apply-word
|
|||
swap t "no-effect" set-word-prop rethrow
|
||||
] recover ;
|
||||
|
||||
: ?no-effect ( word -- )
|
||||
dup "no-effect" word-prop [ no-effect ] [ drop ] if ;
|
||||
|
||||
: apply-default ( word -- )
|
||||
dup "no-effect" word-prop [ no-effect ] when
|
||||
dup ?no-effect
|
||||
dup "infer-effect" word-prop [
|
||||
over "infer" word-prop [
|
||||
swap effect-in length ensure-values call drop
|
||||
|
|
|
@ -31,7 +31,7 @@ M: number equal? number= ;
|
|||
: >polar ( z -- abs arg )
|
||||
dup abs swap >rect swap fatan2 ; inline
|
||||
|
||||
: cis ( arg --- z ) dup fcos swap fsin rect> ; inline
|
||||
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
|
||||
|
||||
: polar> ( abs arg -- z ) cis * ; inline
|
||||
|
||||
|
|
Loading…
Reference in New Issue