functors: no UPPER: in stack effects
Doug Coleman
parent
92f7613545
commit
d096d6b740
|
|
@ -3,24 +3,24 @@
|
||||||
USING: functors2 ;
|
USING: functors2 ;
|
||||||
IN: alien.complex.functor
|
IN: alien.complex.functor
|
||||||
|
|
||||||
INLINE-FUNCTOR: complex-type ( N: existing-word T: name -- ) [[
|
INLINE-FUNCTOR: complex-type ( n: existing-word t: name -- ) [[
|
||||||
USING: alien alien.c-types classes.struct kernel quotations ;
|
USING: alien alien.c-types classes.struct kernel quotations ;
|
||||||
QUALIFIED: math
|
QUALIFIED: math
|
||||||
|
|
||||||
<<
|
<<
|
||||||
STRUCT: ${T} { real ${N} } { imaginary ${N} } ;
|
STRUCT: ${t} { real ${n} } { imaginary ${n} } ;
|
||||||
|
|
||||||
: <${T}> ( z -- alien )
|
: <${t}> ( z -- alien )
|
||||||
math:>rect ${T} <struct-boa> >c-ptr ;
|
math:>rect ${t} <struct-boa> >c-ptr ;
|
||||||
|
|
||||||
: *${T} ( alien -- z )
|
: *${t} ( alien -- z )
|
||||||
${T} memory>struct [ real>> ] [ imaginary>> ] bi math:rect> ; inline
|
${t} memory>struct [ real>> ] [ imaginary>> ] bi math:rect> ; inline
|
||||||
|
|
||||||
>>
|
>>
|
||||||
|
|
||||||
\ ${T} lookup-c-type
|
\ ${t} lookup-c-type
|
||||||
[ <${T}> ] >>unboxer-quot
|
[ <${t}> ] >>unboxer-quot
|
||||||
[ *${T} ] >>boxer-quot
|
[ *${t} ] >>boxer-quot
|
||||||
complex >>boxed-class
|
complex >>boxed-class
|
||||||
drop
|
drop
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -5,19 +5,18 @@ IN: alien.destructors
|
||||||
|
|
||||||
TUPLE: alien-destructor alien ;
|
TUPLE: alien-destructor alien ;
|
||||||
|
|
||||||
INLINE-FUNCTOR: destructor ( F: existing-word -- ) [[
|
INLINE-FUNCTOR: destructor ( f: existing-word -- ) [[
|
||||||
USING: accessors alien.destructors effects generalizations
|
USING: accessors alien.destructors effects generalizations
|
||||||
destructors kernel literals sequences ;
|
destructors kernel literals sequences ;
|
||||||
|
|
||||||
TUPLE: ${F}-destructor < alien-destructor ;
|
TUPLE: ${f}-destructor < alien-destructor ;
|
||||||
|
|
||||||
: <${F}-destructor> ( alien -- destructor )
|
: <${f}-destructor> ( alien -- destructor )
|
||||||
${F}-destructor boa ; inline
|
${f}-destructor boa ; inline
|
||||||
|
|
||||||
: &${F} ( alien -- alien ) dup <${F}-destructor> &dispose drop ; inline
|
: &${f} ( alien -- alien ) dup <${f}-destructor> &dispose drop ; inline
|
||||||
|
|
||||||
: |${F} ( alien -- alien ) dup <${F}-destructor> |dispose drop ; inline
|
: |${f} ( alien -- alien ) dup <${f}-destructor> |dispose drop ; inline
|
||||||
|
|
||||||
M: ${F}-destructor dispose alien>> ${F} $[ \ ${F} stack-effect out>> length ] ndrop ;
|
|
||||||
|
|
||||||
|
M: ${f}-destructor dispose alien>> ${f} $[ \ ${f} stack-effect out>> length ] ndrop ;
|
||||||
]]
|
]]
|
||||||
|
|
|
||||||
|
|
@ -9,79 +9,70 @@ IN: compiler.cfg.renaming.functor
|
||||||
'[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join
|
'[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join
|
||||||
[ drop ] append ;
|
[ drop ] append ;
|
||||||
|
|
||||||
INLINE-FUNCTOR: renaming ( NAME: name DEF-QUOT: string USE-QUOT: string TEMP-QUOT: string -- ) [[
|
INLINE-FUNCTOR: renaming ( name: name def-quot: string use-quot: string temp-quot: string -- ) [[
|
||||||
|
GENERIC: ${name}-insn-defs ( insn -- )
|
||||||
|
GENERIC: ${name}-insn-uses ( insn -- )
|
||||||
|
GENERIC: ${name}-insn-temps ( insn -- )
|
||||||
|
|
||||||
! rename-insn-defs DEFINES ${NAME}-insn-defs
|
M: insn ${name}-insn-defs drop ;
|
||||||
! rename-insn-uses DEFINES ${NAME}-insn-uses
|
M: insn ${name}-insn-uses drop ;
|
||||||
! rename-insn-temps DEFINES ${NAME}-insn-temps
|
M: insn ${name}-insn-temps drop ;
|
||||||
|
|
||||||
! WHERE
|
! Instructions with unusual operands
|
||||||
|
|
||||||
GENERIC: ${NAME}-insn-defs ( insn -- )
|
! Special ${name}-insn-defs methods
|
||||||
GENERIC: ${NAME}-insn-uses ( insn -- )
|
M: ##parallel-copy ${name}-insn-defs
|
||||||
GENERIC: ${NAME}-insn-temps ( insn -- )
|
[ [ first2 ${def-quot} dip 2array ] map ] change-values drop ;
|
||||||
|
|
||||||
M: insn ${NAME}-insn-defs drop ;
|
M: ##phi ${name}-insn-defs ${def-quot} change-dst drop ;
|
||||||
M: insn ${NAME}-insn-uses drop ;
|
|
||||||
M: insn ${NAME}-insn-temps drop ;
|
|
||||||
|
|
||||||
! Instructions with unusual operands
|
M: alien-call-insn ${name}-insn-defs
|
||||||
|
[ [ first3 ${def-quot} 2dip 3array ] map ] change-reg-outputs
|
||||||
|
drop ;
|
||||||
|
|
||||||
! Special ${NAME}-insn-defs methods
|
M: ##callback-inputs ${name}-insn-defs
|
||||||
M: ##parallel-copy ${NAME}-insn-defs
|
[ [ first3 ${def-quot} 2dip 3array ] map ] change-reg-outputs
|
||||||
[ [ first2 ${DEF-QUOT} dip 2array ] map ] change-values drop ;
|
[ [ first3 ${def-quot} 2dip 3array ] map ] change-stack-outputs
|
||||||
|
drop ;
|
||||||
|
|
||||||
M: ##phi ${NAME}-insn-defs ${DEF-QUOT} change-dst drop ;
|
! Special ${name}-insn-uses methods
|
||||||
|
M: ##parallel-copy ${name}-insn-uses
|
||||||
|
[ [ first2 ${use-quot} call 2array ] map ] change-values drop ;
|
||||||
|
|
||||||
M: alien-call-insn ${NAME}-insn-defs
|
M: ##phi ${name}-insn-uses
|
||||||
[ [ first3 ${DEF-QUOT} 2dip 3array ] map ] change-reg-outputs
|
[ ${use-quot} assoc-map ] change-inputs drop ;
|
||||||
drop ;
|
|
||||||
|
|
||||||
M: ##callback-inputs ${NAME}-insn-defs
|
M: alien-call-insn ${name}-insn-uses
|
||||||
[ [ first3 ${DEF-QUOT} 2dip 3array ] map ] change-reg-outputs
|
[ [ first3 ${use-quot} 2dip 3array ] map ] change-reg-inputs
|
||||||
[ [ first3 ${DEF-QUOT} 2dip 3array ] map ] change-stack-outputs
|
[ [ first3 ${use-quot} 2dip 3array ] map ] change-stack-inputs
|
||||||
drop ;
|
drop ;
|
||||||
|
|
||||||
! Special ${NAME}-insn-uses methods
|
M: ##alien-indirect ${name}-insn-uses
|
||||||
M: ##parallel-copy ${NAME}-insn-uses
|
${use-quot} change-src call-next-method ;
|
||||||
[ [ first2 ${USE-QUOT} call 2array ] map ] change-values drop ;
|
|
||||||
|
|
||||||
M: ##phi ${NAME}-insn-uses
|
M: ##callback-outputs ${name}-insn-uses
|
||||||
[ ${USE-QUOT} assoc-map ] change-inputs drop ;
|
[ [ first3 ${use-quot} 2dip 3array ] map ] change-reg-inputs
|
||||||
|
drop ;
|
||||||
|
|
||||||
M: alien-call-insn ${NAME}-insn-uses
|
<<
|
||||||
[ [ first3 ${USE-QUOT} 2dip 3array ] map ] change-reg-inputs
|
! Generate methods for everything else
|
||||||
[ [ first3 ${USE-QUOT} 2dip 3array ] map ] change-stack-inputs
|
insn-classes get special-vreg-insns diff [ insn-def-slots empty? ] reject [
|
||||||
drop ;
|
[ \ ${name}-insn-defs create-method-in ]
|
||||||
|
[ insn-def-slots [ name>> ] map ${def-quot} slot-change-quot ] bi
|
||||||
|
define
|
||||||
|
] each
|
||||||
|
|
||||||
M: ##alien-indirect ${NAME}-insn-uses
|
insn-classes get special-vreg-insns diff [ insn-use-slots empty? ] reject [
|
||||||
${USE-QUOT} change-src call-next-method ;
|
[ \ ${name}-insn-uses create-method-in ]
|
||||||
|
[ insn-use-slots [ name>> ] map ${use-quot} slot-change-quot ] bi
|
||||||
|
define
|
||||||
|
] each
|
||||||
|
|
||||||
M: ##callback-outputs ${NAME}-insn-uses
|
insn-classes get [ insn-temp-slots empty? ] reject [
|
||||||
[ [ first3 ${USE-QUOT} 2dip 3array ] map ] change-reg-inputs
|
[ \ ${name}-insn-temps create-method-in ]
|
||||||
drop ;
|
[ insn-temp-slots [ name>> ] map ${temp-quot} slot-change-quot ] bi
|
||||||
|
define
|
||||||
<<
|
] each
|
||||||
! Generate methods for everything else
|
>>
|
||||||
insn-classes get special-vreg-insns diff [ insn-def-slots empty? ] reject [
|
|
||||||
[ \ ${NAME}-insn-defs create-method-in ]
|
|
||||||
[ insn-def-slots [ name>> ] map ${DEF-QUOT} slot-change-quot ] bi
|
|
||||||
define
|
|
||||||
] each
|
|
||||||
|
|
||||||
insn-classes get special-vreg-insns diff [ insn-use-slots empty? ] reject [
|
|
||||||
[ \ ${NAME}-insn-uses create-method-in ]
|
|
||||||
[ insn-use-slots [ name>> ] map ${USE-QUOT} slot-change-quot ] bi
|
|
||||||
define
|
|
||||||
] each
|
|
||||||
|
|
||||||
insn-classes get [ insn-temp-slots empty? ] reject [
|
|
||||||
[ \ ${NAME}-insn-temps create-method-in ]
|
|
||||||
[ insn-temp-slots [ name>> ] map ${TEMP-QUOT} slot-change-quot ] bi
|
|
||||||
define
|
|
||||||
] each
|
|
||||||
>>
|
|
||||||
|
|
||||||
]]
|
]]
|
||||||
|
|
||||||
! SYNTAX: \RENAMING: scan-token scan-object scan-object scan-object define-renaming ;
|
|
||||||
|
|
|
||||||
|
|
@ -3,7 +3,7 @@
|
||||||
USING: functors2 quotations strings ;
|
USING: functors2 quotations strings ;
|
||||||
IN: sorting.functor
|
IN: sorting.functor
|
||||||
|
|
||||||
INLINE-FUNCTOR: sorting ( NAME: name QUOT: string -- ) [[
|
INLINE-FUNCTOR: sorting ( name: name quot: string -- ) [[
|
||||||
: ${NAME}<=> ( obj1 obj2 -- <=> ) ${QUOT} compare ;
|
: ${name}<=> ( obj1 obj2 -- <=> ) ${quot} compare ;
|
||||||
: ${NAME}>=< ( obj1 obj2 -- >=< ) ${NAME}<=> invert-comparison ;
|
: ${name}>=< ( obj1 obj2 -- >=< ) ${name}<=> invert-comparison ;
|
||||||
]]
|
]]
|
||||||
|
|
|
||||||
|
|
@ -34,32 +34,30 @@ MACRO: write-tuple ( class -- quot )
|
||||||
|
|
||||||
PRIVATE>
|
PRIVATE>
|
||||||
|
|
||||||
FUNCTOR: tuple-array ( CLASS: existing-class -- ) [[
|
FUNCTOR: tuple-array ( class: existing-class -- ) [[
|
||||||
|
USING: accessors arrays classes.tuple.private kernel sequences
|
||||||
|
sequences.private tuple-arrays.private ;
|
||||||
|
|
||||||
USING: accessors arrays classes.tuple.private kernel sequences
|
TUPLE: ${class}-array
|
||||||
sequences.private tuple-arrays.private ;
|
{ seq array read-only }
|
||||||
|
{ n array-capacity read-only }
|
||||||
|
{ length array-capacity read-only } ;
|
||||||
|
|
||||||
TUPLE: ${CLASS}-array
|
INSTANCE: ${class}-array sequence
|
||||||
{ seq array read-only }
|
|
||||||
{ n array-capacity read-only }
|
|
||||||
{ length array-capacity read-only } ;
|
|
||||||
|
|
||||||
INSTANCE: ${CLASS}-array sequence
|
: <${class}-array> ( length -- tuple-array )
|
||||||
|
[ \ ${class} [ initial-values <repetition> concat ] [ tuple-arity ] bi ] keep
|
||||||
|
\ ${class}-array boa ; inline
|
||||||
|
|
||||||
: <${CLASS}-array> ( length -- tuple-array )
|
M: ${class}-array length length>> ; inline
|
||||||
[ \ ${CLASS} [ initial-values <repetition> concat ] [ tuple-arity ] bi ] keep
|
|
||||||
\ ${CLASS}-array boa ; inline
|
|
||||||
|
|
||||||
M: ${CLASS}-array length length>> ; inline
|
M: ${class}-array nth-unsafe tuple-slice \ ${class} read-tuple ; inline
|
||||||
|
|
||||||
M: ${CLASS}-array nth-unsafe tuple-slice \ ${CLASS} read-tuple ; inline
|
M: ${class}-array set-nth-unsafe tuple-slice \ ${class} write-tuple ; inline
|
||||||
|
|
||||||
M: ${CLASS}-array set-nth-unsafe tuple-slice \ ${CLASS} write-tuple ; inline
|
M: ${class}-array new-sequence drop <${class}-array> ; inline
|
||||||
|
|
||||||
M: ${CLASS}-array new-sequence drop <${CLASS}-array> ; inline
|
: >${class}-array ( seq -- tuple-array ) 0 <${class}-array> clone-like ;
|
||||||
|
|
||||||
: >${CLASS}-array ( seq -- tuple-array ) 0 <${CLASS}-array> clone-like ;
|
|
||||||
|
|
||||||
M: ${CLASS}-array like drop dup ${CLASS}-array? [ >${CLASS}-array ] unless ; inline
|
|
||||||
|
|
||||||
|
M: ${class}-array like drop dup ${class}-array? [ >${class}-array ] unless ; inline
|
||||||
]]
|
]]
|
||||||
|
|
|
||||||
|
|
@ -14,20 +14,18 @@ IN: annotations
|
||||||
[ { [ word? ] [ vocabulary>> "annotations" = ] } 1&& not ]
|
[ { [ word? ] [ vocabulary>> "annotations" = ] } 1&& not ]
|
||||||
filter ;
|
filter ;
|
||||||
|
|
||||||
INLINE-FUNCTOR: annotation ( NAME: new-word -- ) [[
|
INLINE-FUNCTOR: annotation ( name: new-word -- ) [[
|
||||||
|
USING: annotations kernel sequences tools.crossref ;
|
||||||
|
|
||||||
USING: annotations kernel sequences tools.crossref ;
|
: (${name}) ( str -- ) drop ; inline
|
||||||
|
|
||||||
: (${NAME}) ( str -- ) drop ; inline
|
SYNTAX: !${name} (parse-annotation) \ (${name}) suffix! ;
|
||||||
|
|
||||||
SYNTAX: !${NAME} (parse-annotation) \ (${NAME}) suffix! ;
|
: ${name}s ( -- usages )
|
||||||
|
\ (${name}) (non-annotation-usage) ;
|
||||||
: ${NAME}s ( -- usages )
|
|
||||||
\ (${NAME}) (non-annotation-usage) ;
|
|
||||||
|
|
||||||
: ${NAME}s. ( -- )
|
|
||||||
${NAME}s sorted-definitions. ;
|
|
||||||
|
|
||||||
|
: ${name}s. ( -- )
|
||||||
|
${name}s sorted-definitions. ;
|
||||||
]]
|
]]
|
||||||
|
|
||||||
SYNTAX: \ANNOTATIONS: ";" [ define-annotation ] each-token ;
|
SYNTAX: \ANNOTATIONS: ";" [ define-annotation ] each-token ;
|
||||||
|
|
|
||||||
|
|
@ -210,6 +210,7 @@ ERROR: unexpected-terminator n string slice ;
|
||||||
swap
|
swap
|
||||||
! What ended the FOO: .. ; form?
|
! What ended the FOO: .. ; form?
|
||||||
! Remove the ; from the payload if present
|
! Remove the ; from the payload if present
|
||||||
|
! XXX: probably can remove this, T: is dumb
|
||||||
! Also in stack effects ( T: int -- ) can be ended by -- and )
|
! Also in stack effects ( T: int -- ) can be ended by -- and )
|
||||||
dup ?last {
|
dup ?last {
|
||||||
{ [ dup ";" sequence= ] [ drop unclip-last 3array ] }
|
{ [ dup ";" sequence= ] [ drop unclip-last 3array ] }
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue