] with-aligned-stack ;
M: x86.32 %nest-stacks ( -- )
+ ! Save current frame. See comment in vm/contexts.hpp
+ EAX stack-reg stack-frame get total-size>> 3 cells - [+] LEA
8 [
push-vm-ptr
- ! Save current frame. See comment in vm/contexts.hpp
- EAX stack-reg stack-frame get total-size>> [+] LEA
EAX PUSH
"nest_stacks" f %alien-invoke
] with-aligned-stack ;
{ { +vector+ +scalar+ -> +vector+ } A-vn->v-op }
{ { +vector+ +literal+ -> +vector+ } A-vn->v-op }
{ { +vector+ +vector+ -> +scalar+ } A-vv->n-op }
+ { { +vector+ +vector+ -> +boolean+ } A-vv->n-op }
{ { +vector+ -> +vector+ } A-v->v-op }
{ { +vector+ -> +scalar+ } A-v->n-op }
+ { { +vector+ -> +boolean+ } A-v->n-op }
{ { +vector+ -> +nonnegative+ } A-v->n-op }
} >>schema-wrappers
(define-simd-128)
float-4{ 0 1 0 2 }
[ { float-4 } declare dup v+ underlying>> double-2 boa dup v+ ] compile-call
] unit-test
-
- [ 33.0 ] [
- double-2{ 1 2 } double-2{ 10 20 }
- [ { double-2 double-2 } declare v+ underlying>> 3.0 float* ] compile-call
- ] unit-test
] when
! Fuzz testing
'[ first2 inputs _ _ check-vector-op ]
] dip check-optimizer ; inline
-: approx= ( x y -- ? )
+: (approx=) ( x y -- ? )
{
{ [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
- { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
+ { [ 2dup [ fp-nan? ] either? ] [ 2drop f ] }
{ [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
- { [ 2dup [ sequence? ] both? ] [
- [
- {
- { [ 2dup [ fp-nan? ] both? ] [ 2drop t ] }
- { [ 2dup [ fp-infinity? ] either? ] [ fp-bitwise= ] }
- { [ 2dup [ fp-nan? ] either? not ] [ -1.e8 ~ ] }
- } cond
- ] 2all?
- ] }
+ { [ 2dup [ float? ] both? ] [ -1.e8 ~ ] }
} cond ;
+: approx= ( x y -- ? )
+ 2dup [ sequence? ] both?
+ [ [ (approx=) ] 2all? ] [ (approx=) ] if ;
+
: exact= ( x y -- ? )
{
{ [ 2dup [ float? ] both? ] [ fp-bitwise= ] }
locals compiler.tree.propagation.info ;
IN: math.vectors.specialization
-SYMBOLS: -> +vector+ +scalar+ +nonnegative+ +literal+ ;
+SYMBOLS: -> +vector+ +scalar+ +boolean+ +nonnegative+ +literal+ ;
: signature-for-schema ( array-type elt-type schema -- signature )
[
{
{ +vector+ [ drop ] }
{ +scalar+ [ nip ] }
+ { +boolean+ [ 2drop boolean ] }
{ +nonnegative+ [ nip ] }
{ +literal+ [ 2drop f ] }
} case
{
{ +vector+ [ drop <class-info> ] }
{ +scalar+ [ nip <class-info> ] }
+ { +boolean+ [ 2drop boolean <class-info> ] }
{
+nonnegative+
[
{ v> { +vector+ +vector+ -> +vector+ } }
{ v>= { +vector+ +vector+ -> +vector+ } }
{ vunordered? { +vector+ +vector+ -> +vector+ } }
- { vany? { +vector+ -> +scalar+ } }
- { vall? { +vector+ -> +scalar+ } }
- { vnone? { +vector+ -> +scalar+ } }
+ { vany? { +vector+ -> +boolean+ } }
+ { vall? { +vector+ -> +boolean+ } }
+ { vnone? { +vector+ -> +boolean+ } }
}
PREDICATE: vector-word < word vector-words key? ;
--- /dev/null
+! (c)Joe Groff bsd license
+USING: typed compiler.cfg.debugger compiler.tree.debugger words ;
+IN: typed.debugger
+
+: typed-test-mr ( word -- mrs )
+ "typed-word" word-prop test-mr ; inline
+: typed-test-mr. ( word -- )
+ "typed-word" word-prop test-mr mr. ; inline
+: typed-optimized. ( word -- )
+ "typed-word" word-prop optimized. ; inline
--- /dev/null
+USING: definitions kernel locals.definitions see see.private typed words ;
+IN: typed.prettyprint
+
+PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
+
+M: typed-word definer drop \ TYPED: \ ; ;
+M: typed-lambda-word definer drop \ TYPED:: \ ; ;
+
+M: typed-word definition "typed-def" word-prop ;
+M: typed-word declarations. "typed-word" word-prop declarations. ;
+
--- /dev/null
+Strongly-typed word definitions
--- /dev/null
+! (c)2009 Joe Groff bsd license
+USING: arrays effects help.markup help.syntax locals math quotations words ;
+IN: typed
+
+HELP: TYPED:
+{ $syntax
+"""TYPED: word ( a b: class ... -- x: class y ... )
+ body ;""" }
+{ $description "Like " { $link POSTPONE: : } ", defines a new word with a given stack effect in the current vocabulary. The inputs and outputs of the stack effect can additionally be given type annotations in the form " { $snippet "a: class" } ". When invoked, the word will attempt to coerce its input values to the declared input types before executing the body, throwing an " { $link input-mismatch-error } " if the types cannot be made to match. The word will likewise attempt to coerce its outputs to their declared types and throw an " { $link output-mismatch-error } " if the types cannot be made to match." }
+{ $notes "The aforementioned type conversions and checks are structured in such a way that they will be eliminated by the compiler if it can statically determine that the types of the inputs at a call site or of the outputs in the word definition are always correct." }
+{ $examples
+"A version of " { $link + } " specialized for floats, converting other real number types:"
+{ $example
+"""USING: math prettyprint typed ;
+IN: scratchpad
+
+TYPED: add-floats ( a: float b: float -- c: float )
+ + ;
+
+1 2+1/2 add-floats ."""
+"3.5" } } ;
+
+HELP: TYPED::
+{ $syntax
+"""TYPED:: word ( a b: class ... -- x: class y ... )
+ body ;""" }
+{ $description "Like " { $link POSTPONE: :: } ", defines a new word with named inputs in the current vocabulary. The inputs and outputs of the stack effect can additionally be given type annotations in the form " { $snippet "a: class" } ". When invoked, the word will attempt to coerce its input values to the declared input types before executing the body, throwing an " { $link input-mismatch-error } " if the types cannot be made to match. The word will likewise attempt to coerce its outputs to their declared types and throw an " { $link output-mismatch-error } " if the types cannot be made to match." }
+{ $notes "The aforementioned type conversions and checks are structured in such a way that they will be eliminated by the compiler if it can statically determine that the types of the inputs at a call site or of the outputs in the word definition are always correct." }
+{ $examples
+"A version of the quadratic formula specialized for floats, converting other real number types:"
+{ $example
+"""USING: kernel math math.libm prettyprint typed ;
+IN: scratchpad
+
+TYPED:: quadratic-roots ( a: float b: float c: float -- q1: float q2: float )
+ b neg
+ b sq 4.0 a * c * - fsqrt
+ [ + ] [ - ] 2bi
+ [ 2.0 a * / ] bi@ ;
+
+1 0 -9/4 quadratic-roots [ . ] bi@"""
+"""1.5
+-1.5""" } } ;
+
+HELP: define-typed
+{ $values { "word" word } { "def" quotation } { "effect" effect } }
+{ $description "The runtime equivalent to " { $link POSTPONE: TYPED: } " and " { $link POSTPONE: TYPED:: } ". Defines " { $snippet "word" } " with " { $snippet "def" } " as its body and " { $snippet "effect" } " as its stack effect. The word will check that its inputs and outputs correspond to the types specified in " { $snippet "effect" } " as described in the " { $link POSTPONE: TYPED: } " documentation." } ;
+
+HELP: input-mismatch-error
+{ $values { "word" word } { "expected-types" array } }
+{ $class-description "Errors of this class are raised at runtime by " { $link POSTPONE: TYPED: } " words when they are invoked with input values that do not match their type annotations. The " { $snippet "word" } " slot indicates the word that failed, and the " { $snippet "expected-types" } " slot specifies the input types expected." } ;
+
+HELP: output-mismatch-error
+{ $values { "word" word } { "expected-types" array } }
+{ $class-description "Errors of this class are raised at runtime by " { $link POSTPONE: TYPED: } " words when they attempt to output values that do not match their type annotations. The " { $snippet "word" } " slot indicates the word that failed, and the " { $snippet "expected-types" } " slot specifies the output types expected." } ;
+
+{ POSTPONE: TYPED: POSTPONE: TYPED:: define-typed } related-words
+
+ARTICLE: "typed" "Strongly-typed word definitions"
+"The Factor compiler supports advanced compiler optimizations that take advantage of the type information it can glean from source code. The " { $vocab-link "typed" } " vocabulary provides syntax that allows words to provide checked type information about their inputs and outputs and improve the performance of compiled code."
+{ $subsections
+ POSTPONE: TYPED:
+ POSTPONE: TYPED::
+ define-typed
+ input-mismatch-error
+ output-mismatch-error
+} ;
+
+ABOUT: "typed"
--- /dev/null
+USING: accessors effects eval kernel layouts math quotations tools.test typed words ;
+IN: typed.tests
+
+TYPED: f+ ( a: float b: float -- c: float )
+ + ;
+
+[ 3.5 ]
+[ 2 1+1/2 f+ ] unit-test
+
+TYPED: fix+ ( a: fixnum b: fixnum -- c: fixnum )
+ + ;
+
+most-positive-fixnum neg 1 - 1quotation
+[ most-positive-fixnum 1 fix+ ] unit-test
+
+TUPLE: tweedle-dee ;
+TUPLE: tweedle-dum ;
+
+TYPED: dee ( x: tweedle-dee -- y )
+ drop \ tweedle-dee ;
+
+TYPED: dum ( x: tweedle-dum -- y )
+ drop \ tweedle-dum ;
+
+[ \ tweedle-dum new dee ] [ input-mismatch-error? ] must-fail-with
+[ \ tweedle-dee new dum ] [ input-mismatch-error? ] must-fail-with
+
+
+TYPED: dumdum ( x -- y: tweedle-dum )
+ drop \ tweedle-dee new ;
+
+[ f dumdum ] [ output-mismatch-error? ] must-fail-with
+
+TYPED:: f+locals ( a: float b: float -- c: float )
+ a b + ;
+
+[ 3.5 ] [ 2 1+1/2 f+locals ] unit-test
+
+TUPLE: unboxable
+ { x fixnum read-only }
+ { y fixnum read-only } ;
+
+TUPLE: unboxable2
+ { u unboxable read-only }
+ { xy fixnum read-only } ;
+
+TYPED: unboxy ( in: unboxable -- out: unboxable2 )
+ dup [ x>> ] [ y>> ] bi - unboxable2 boa ;
+
+[ (( in: fixnum in: fixnum -- out: fixnum out: fixnum out: fixnum )) ]
+[ \ unboxy "typed-word" word-prop stack-effect ] unit-test
+
+[ T{ unboxable2 { u T{ unboxable { x 12 } { y 3 } } } { xy 9 } } ]
+[ T{ unboxable { x 12 } { y 3 } } unboxy ] unit-test
+
+[ 9 ]
+[
+"""
+USING: kernel math ;
+IN: typed.tests
+
+TUPLE: unboxable
+ { x fixnum read-only }
+ { y fixnum read-only }
+ { z float read-only } ;
+""" eval( -- )
+
+"""
+USING: accessors kernel math ;
+IN: typed.tests
+T{ unboxable f 12 3 4.0 } unboxy xy>>
+""" eval( -- xy )
+] unit-test
--- /dev/null
+! (c)Joe Groff bsd license
+USING: accessors arrays classes classes.tuple combinators
+combinators.short-circuit definitions effects fry hints
+math kernel kernel.private namespaces parser quotations
+sequences slots words locals
+locals.parser macros stack-checker.state ;
+IN: typed
+
+ERROR: type-mismatch-error word expected-types ;
+ERROR: input-mismatch-error < type-mismatch-error ;
+ERROR: output-mismatch-error < type-mismatch-error ;
+
+PREDICATE: typed-gensym < word "typed-gensym" word-prop ;
+PREDICATE: typed-word < word "typed-word" word-prop ;
+
+<PRIVATE
+
+: unboxable-tuple-class? ( type -- ? )
+ {
+ [ all-slots empty? not ]
+ [ immutable-tuple-class? ]
+ } 1&& ;
+
+! typed inputs
+
+: typed-stack-effect? ( effect -- ? )
+ [ object = ] all? not ;
+
+: input-mismatch-quot ( word types -- quot )
+ [ input-mismatch-error ] 2curry ;
+
+: (unboxer) ( type -- quot )
+ dup unboxable-tuple-class? [
+ all-slots [
+ [ name>> reader-word 1quotation ]
+ [ class>> (unboxer) ] bi compose
+ ] map [ cleave ] curry
+ ] [ drop [ ] ] if ;
+
+:: unboxer ( error-quot word types type -- quot )
+ type "coercer" word-prop [ ] or
+ [ dup type instance? [ word types error-quot call ] unless ]
+ type (unboxer)
+ compose compose ;
+
+: make-unboxer ( error-quot word types -- quot )
+ dup [ unboxer ] with with with
+ [ swap \ dip [ ] 2sequence prepend ] map-reduce ;
+
+: (unboxed-types) ( type -- types )
+ dup unboxable-tuple-class?
+ [ all-slots [ class>> (unboxed-types) ] map concat ]
+ [ 1array ] if ;
+
+: unboxed-types ( types -- types' )
+ [ (unboxed-types) ] map concat ;
+
+:: typed-inputs ( quot word types -- quot' )
+ types unboxed-types :> unboxed-types
+
+ [ input-mismatch-error ] word types make-unboxer
+ unboxed-types quot '[ _ declare @ ]
+ compose ;
+
+! typed outputs
+
+: output-mismatch-quot ( word types -- quot )
+ [ output-mismatch-error ] 2curry ;
+
+:: typed-outputs ( quot word types -- quot' )
+ [ output-mismatch-error ] word types make-unboxer
+ quot prepose ;
+
+DEFER: make-boxer
+
+: boxer ( type -- quot )
+ dup unboxable-tuple-class?
+ [ [ all-slots [ class>> ] map make-boxer ] [ [ boa ] curry ] bi compose ]
+ [ drop [ ] ] if ;
+
+: make-boxer ( types -- quot )
+ [ boxer ] [ swap '[ @ _ dip ] ] map-reduce ;
+
+! defining typed words
+
+: (depends-on) ( types -- types )
+ dup [ inlined-dependency depends-on ] each ; inline
+
+MACRO: (typed) ( word def effect -- quot )
+ [ swap ] dip
+ [
+ nip effect-in-types (depends-on) swap
+ [ [ unboxed-types ] [ make-boxer ] bi ] dip
+ '[ _ declare @ @ ]
+ ]
+ [
+ effect-out-types (depends-on)
+ dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
+ ] 2bi ;
+
+: <typed-gensym> ( parent-word -- word )
+ [ name>> "( typed " " )" surround f <word> dup ]
+ [ "typed-gensym" set-word-prop ] bi ;
+
+: unboxed-effect ( effect -- effect' )
+ [ effect-in-types unboxed-types [ "in" swap 2array ] map ]
+ [ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ;
+
+M: typed-gensym stack-effect
+ call-next-method unboxed-effect ;
+M: typed-gensym crossref?
+ "typed-gensym" word-prop crossref? ;
+
+: define-typed-gensym ( word def effect -- gensym )
+ [ 2drop <typed-gensym> dup ]
+ [ [ (typed) ] 3curry ]
+ [ 2nip ] 3tri define-declared ;
+
+MACRO: typed ( quot word effect -- quot' )
+ [ effect-in-types (depends-on) dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
+ [
+ nip effect-out-types (depends-on) dup typed-stack-effect?
+ [ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
+ ] 2bi ;
+
+: (typed-def) ( word def effect -- quot )
+ [ define-typed-gensym ] 3keep
+ [ drop [ swap "typed-word" set-word-prop ] [ [ 1quotation ] dip ] 2bi ] dip
+ [ typed ] 3curry ;
+
+: typed-def ( word def effect -- quot )
+ dup {
+ [ effect-in-types typed-stack-effect? ]
+ [ effect-out-types typed-stack-effect? ]
+ } 1|| [ (typed-def) ] [ drop nip ] if ;
+
+M: typed-word subwords
+ [ call-next-method ]
+ [ "typed-word" word-prop ] bi suffix ;
+
+PRIVATE>
+
+: define-typed ( word def effect -- )
+ [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
+ [ drop "typed-def" set-word-prop ]
+ [ 2drop "typed-word" word-prop \ word set-global ] 3tri ;
+
+SYNTAX: TYPED:
+ (:) define-typed ;
+SYNTAX: TYPED::
+ (::) define-typed ;
+
+USING: vocabs vocabs.loader ;
+
+"prettyprint" vocab [ "typed.prettyprint" require ] when
{ deploy-c-types? f }
{ deploy-unicode? f }
{ deploy-io 2 }
- { deploy-reflection 2 }
+ { deploy-reflection 1 }
{ "stop-after-last-window?" t }
{ deploy-word-props? f }
{ deploy-math? t }
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: typed compiler.cfg.debugger compiler.tree.debugger words ;
-IN: typed.debugger
-
-: typed-test-mr ( word -- mrs )
- "typed-word" word-prop test-mr ; inline
-: typed-test-mr. ( word -- )
- "typed-word" word-prop test-mr mr. ; inline
-: typed-optimized. ( word -- )
- "typed-word" word-prop optimized. ; inline
+++ /dev/null
-USING: definitions kernel locals.definitions see see.private typed words ;
-IN: typed.prettyprint
-
-PREDICATE: typed-lambda-word < lambda-word "typed-word" word-prop ;
-
-M: typed-word definer drop \ TYPED: \ ; ;
-M: typed-lambda-word definer drop \ TYPED:: \ ; ;
-
-M: typed-word definition "typed-def" word-prop ;
-M: typed-word declarations. "typed-word" word-prop declarations. ;
-
+++ /dev/null
-Strongly-typed word definitions
+++ /dev/null
-! (c)2009 Joe Groff bsd license
-USING: arrays effects help.markup help.syntax locals math quotations words ;
-IN: typed
-
-HELP: TYPED:
-{ $syntax
-"""TYPED: word ( a b: class ... -- x: class y ... )
- body ;""" }
-{ $description "Like " { $link POSTPONE: : } ", defines a new word with a given stack effect in the current vocabulary. The inputs and outputs of the stack effect can additionally be given type annotations in the form " { $snippet "a: class" } ". When invoked, the word will attempt to coerce its input values to the declared input types before executing the body, throwing an " { $link input-mismatch-error } " if the types cannot be made to match. The word will likewise attempt to coerce its outputs to their declared types and throw an " { $link output-mismatch-error } " if the types cannot be made to match." }
-{ $notes "The aforementioned type conversions and checks are structured in such a way that they will be eliminated by the compiler if it can statically determine that the types of the inputs at a call site or of the outputs in the word definition are always correct." }
-{ $examples
-"A version of " { $link + } " specialized for floats, converting other real number types:"
-{ $example
-"""USING: math prettyprint typed ;
-IN: scratchpad
-
-TYPED: add-floats ( a: float b: float -- c: float )
- + ;
-
-1 2+1/2 add-floats ."""
-"3.5" } } ;
-
-HELP: TYPED::
-{ $syntax
-"""TYPED:: word ( a b: class ... -- x: class y ... )
- body ;""" }
-{ $description "Like " { $link POSTPONE: :: } ", defines a new word with named inputs in the current vocabulary. The inputs and outputs of the stack effect can additionally be given type annotations in the form " { $snippet "a: class" } ". When invoked, the word will attempt to coerce its input values to the declared input types before executing the body, throwing an " { $link input-mismatch-error } " if the types cannot be made to match. The word will likewise attempt to coerce its outputs to their declared types and throw an " { $link output-mismatch-error } " if the types cannot be made to match." }
-{ $notes "The aforementioned type conversions and checks are structured in such a way that they will be eliminated by the compiler if it can statically determine that the types of the inputs at a call site or of the outputs in the word definition are always correct." }
-{ $examples
-"A version of the quadratic formula specialized for floats, converting other real number types:"
-{ $example
-"""USING: kernel math math.libm prettyprint typed ;
-IN: scratchpad
-
-TYPED:: quadratic-roots ( a: float b: float c: float -- q1: float q2: float )
- b neg
- b sq 4.0 a * c * - fsqrt
- [ + ] [ - ] 2bi
- [ 2.0 a * / ] bi@ ;
-
-1 0 -9/4 quadratic-roots [ . ] bi@"""
-"""1.5
--1.5""" } } ;
-
-HELP: define-typed
-{ $values { "word" word } { "def" quotation } { "effect" effect } }
-{ $description "The runtime equivalent to " { $link POSTPONE: TYPED: } " and " { $link POSTPONE: TYPED:: } ". Defines " { $snippet "word" } " with " { $snippet "def" } " as its body and " { $snippet "effect" } " as its stack effect. The word will check that its inputs and outputs correspond to the types specified in " { $snippet "effect" } " as described in the " { $link POSTPONE: TYPED: } " documentation." } ;
-
-HELP: input-mismatch-error
-{ $values { "word" word } { "expected-types" array } }
-{ $class-description "Errors of this class are raised at runtime by " { $link POSTPONE: TYPED: } " words when they are invoked with input values that do not match their type annotations. The " { $snippet "word" } " slot indicates the word that failed, and the " { $snippet "expected-types" } " slot specifies the input types expected." } ;
-
-HELP: output-mismatch-error
-{ $values { "word" word } { "expected-types" array } }
-{ $class-description "Errors of this class are raised at runtime by " { $link POSTPONE: TYPED: } " words when they attempt to output values that do not match their type annotations. The " { $snippet "word" } " slot indicates the word that failed, and the " { $snippet "expected-types" } " slot specifies the output types expected." } ;
-
-{ POSTPONE: TYPED: POSTPONE: TYPED:: define-typed } related-words
-
-ARTICLE: "typed" "Strongly-typed word definitions"
-"The Factor compiler supports advanced compiler optimizations that take advantage of the type information it can glean from source code. The " { $vocab-link "typed" } " vocabulary provides syntax that allows words to provide checked type information about their inputs and outputs and improve the performance of compiled code."
-{ $subsections
- POSTPONE: TYPED:
- POSTPONE: TYPED::
- define-typed
- input-mismatch-error
- output-mismatch-error
-} ;
-
-ABOUT: "typed"
+++ /dev/null
-USING: accessors effects eval kernel layouts math quotations tools.test typed words ;
-IN: typed.tests
-
-TYPED: f+ ( a: float b: float -- c: float )
- + ;
-
-[ 3.5 ]
-[ 2 1+1/2 f+ ] unit-test
-
-TYPED: fix+ ( a: fixnum b: fixnum -- c: fixnum )
- + ;
-
-most-positive-fixnum neg 1 - 1quotation
-[ most-positive-fixnum 1 fix+ ] unit-test
-
-TUPLE: tweedle-dee ;
-TUPLE: tweedle-dum ;
-
-TYPED: dee ( x: tweedle-dee -- y )
- drop \ tweedle-dee ;
-
-TYPED: dum ( x: tweedle-dum -- y )
- drop \ tweedle-dum ;
-
-[ \ tweedle-dum new dee ] [ input-mismatch-error? ] must-fail-with
-[ \ tweedle-dee new dum ] [ input-mismatch-error? ] must-fail-with
-
-
-TYPED: dumdum ( x -- y: tweedle-dum )
- drop \ tweedle-dee new ;
-
-[ f dumdum ] [ output-mismatch-error? ] must-fail-with
-
-TYPED:: f+locals ( a: float b: float -- c: float )
- a b + ;
-
-[ 3.5 ] [ 2 1+1/2 f+locals ] unit-test
-
-TUPLE: unboxable
- { x fixnum read-only }
- { y fixnum read-only } ;
-
-TUPLE: unboxable2
- { u unboxable read-only }
- { xy fixnum read-only } ;
-
-TYPED: unboxy ( in: unboxable -- out: unboxable2 )
- dup [ x>> ] [ y>> ] bi - unboxable2 boa ;
-
-[ (( in: fixnum in: fixnum -- out: fixnum out: fixnum out: fixnum )) ]
-[ \ unboxy "typed-word" word-prop stack-effect ] unit-test
-
-[ T{ unboxable2 { u T{ unboxable { x 12 } { y 3 } } } { xy 9 } } ]
-[ T{ unboxable { x 12 } { y 3 } } unboxy ] unit-test
-
-[ 9 ]
-[
-"""
-USING: kernel math ;
-IN: typed.tests
-
-TUPLE: unboxable
- { x fixnum read-only }
- { y fixnum read-only }
- { z float read-only } ;
-""" eval( -- )
-
-"""
-USING: accessors kernel math ;
-IN: typed.tests
-T{ unboxable f 12 3 4.0 } unboxy xy>>
-""" eval( -- xy )
-] unit-test
+++ /dev/null
-! (c)Joe Groff bsd license
-USING: accessors arrays classes classes.tuple combinators
-combinators.short-circuit definitions effects fry hints
-math kernel kernel.private namespaces parser quotations
-sequences slots words locals
-locals.parser macros stack-checker.state ;
-IN: typed
-
-ERROR: type-mismatch-error word expected-types ;
-ERROR: input-mismatch-error < type-mismatch-error ;
-ERROR: output-mismatch-error < type-mismatch-error ;
-
-PREDICATE: typed-gensym < word "typed-gensym" word-prop ;
-PREDICATE: typed-word < word "typed-word" word-prop ;
-
-<PRIVATE
-
-: unboxable-tuple-class? ( type -- ? )
- {
- [ all-slots empty? not ]
- [ immutable-tuple-class? ]
- } 1&& ;
-
-! typed inputs
-
-: typed-stack-effect? ( effect -- ? )
- [ object = ] all? not ;
-
-: input-mismatch-quot ( word types -- quot )
- [ input-mismatch-error ] 2curry ;
-
-: (unboxer) ( type -- quot )
- dup unboxable-tuple-class? [
- all-slots [
- [ name>> reader-word 1quotation ]
- [ class>> (unboxer) ] bi compose
- ] map [ cleave ] curry
- ] [ drop [ ] ] if ;
-
-:: unboxer ( error-quot word types type -- quot )
- type "coercer" word-prop [ ] or
- [ dup type instance? [ word types error-quot call ] unless ]
- type (unboxer)
- compose compose ;
-
-: make-unboxer ( error-quot word types -- quot )
- dup [ unboxer ] with with with
- [ swap \ dip [ ] 2sequence prepend ] map-reduce ;
-
-: (unboxed-types) ( type -- types )
- dup unboxable-tuple-class?
- [ all-slots [ class>> (unboxed-types) ] map concat ]
- [ 1array ] if ;
-
-: unboxed-types ( types -- types' )
- [ (unboxed-types) ] map concat ;
-
-:: typed-inputs ( quot word types -- quot' )
- types unboxed-types :> unboxed-types
-
- [ input-mismatch-error ] word types make-unboxer
- unboxed-types quot '[ _ declare @ ]
- compose ;
-
-! typed outputs
-
-: output-mismatch-quot ( word types -- quot )
- [ output-mismatch-error ] 2curry ;
-
-:: typed-outputs ( quot word types -- quot' )
- [ output-mismatch-error ] word types make-unboxer
- quot prepose ;
-
-DEFER: make-boxer
-
-: boxer ( type -- quot )
- dup unboxable-tuple-class?
- [ [ all-slots [ class>> ] map make-boxer ] [ [ boa ] curry ] bi compose ]
- [ drop [ ] ] if ;
-
-: make-boxer ( types -- quot )
- [ boxer ] [ swap '[ @ _ dip ] ] map-reduce ;
-
-! defining typed words
-
-: (depends-on) ( types -- types )
- dup [ inlined-dependency depends-on ] each ; inline
-
-MACRO: (typed) ( word def effect -- quot )
- [ swap ] dip
- [
- nip effect-in-types (depends-on) swap
- [ [ unboxed-types ] [ make-boxer ] bi ] dip
- '[ _ declare @ @ ]
- ]
- [
- effect-out-types (depends-on)
- dup typed-stack-effect? [ typed-outputs ] [ 2drop ] if
- ] 2bi ;
-
-: <typed-gensym> ( parent-word -- word )
- [ name>> "( typed " " )" surround f <word> dup ]
- [ "typed-gensym" set-word-prop ] bi ;
-
-: unboxed-effect ( effect -- effect' )
- [ effect-in-types unboxed-types [ "in" swap 2array ] map ]
- [ effect-out-types unboxed-types [ "out" swap 2array ] map ] bi <effect> ;
-
-M: typed-gensym stack-effect
- call-next-method unboxed-effect ;
-M: typed-gensym crossref?
- "typed-gensym" word-prop crossref? ;
-
-: define-typed-gensym ( word def effect -- gensym )
- [ 2drop <typed-gensym> dup ]
- [ [ (typed) ] 3curry ]
- [ 2nip ] 3tri define-declared ;
-
-MACRO: typed ( quot word effect -- quot' )
- [ effect-in-types (depends-on) dup typed-stack-effect? [ typed-inputs ] [ 2drop ] if ]
- [
- nip effect-out-types (depends-on) dup typed-stack-effect?
- [ [ unboxed-types ] [ make-boxer ] bi '[ @ _ declare @ ] ] [ drop ] if
- ] 2bi ;
-
-: (typed-def) ( word def effect -- quot )
- [ define-typed-gensym ] 3keep
- [ drop [ swap "typed-word" set-word-prop ] [ [ 1quotation ] dip ] 2bi ] dip
- [ typed ] 3curry ;
-
-: typed-def ( word def effect -- quot )
- dup {
- [ effect-in-types typed-stack-effect? ]
- [ effect-out-types typed-stack-effect? ]
- } 1|| [ (typed-def) ] [ drop nip ] if ;
-
-M: typed-word subwords
- [ call-next-method ]
- [ "typed-word" word-prop ] bi suffix ;
-
-PRIVATE>
-
-: define-typed ( word def effect -- )
- [ [ 2drop ] [ typed-def ] [ 2nip ] 3tri define-inline ]
- [ drop "typed-def" set-word-prop ]
- [ 2drop "typed-word" word-prop \ word set-global ] 3tri ;
-
-SYNTAX: TYPED:
- (:) define-typed ;
-SYNTAX: TYPED::
- (::) define-typed ;
-
-USING: vocabs vocabs.loader ;
-
-"prettyprint" vocab [ "typed.prettyprint" require ] when
projects / factor.git / commitdiff