steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

functors: no UPPER: in stack effects

modern-harvey2
Doug Coleman 2017-12-28 19:15:31 -08:00
parent 92f7613545
commit d096d6b740
7 changed files with 98 additions and 111 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
basis/alien/complex/functor/functor.factor
View File

@ -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

19
basis/alien/destructors/destructors.factor
View File

@ -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 ;
]] ]]

97
basis/compiler/cfg/renaming/functor/functor.factor
View File

@ -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
! Special ${NAME}-insn-defs methods
M: ##parallel-copy ${NAME}-insn-defs
[ [ first2 ${DEF-QUOT} dip 2array ] map ] change-values drop ;
M: ##phi ${NAME}-insn-defs ${DEF-QUOT} change-dst drop ;
M: alien-call-insn ${NAME}-insn-defs
[ [ first3 ${DEF-QUOT} 2dip 3array ] map ] change-reg-outputs
drop ; drop ;
M: ##callback-inputs ${NAME}-insn-defs M: ##callback-inputs ${name}-insn-defs
[ [ first3 ${DEF-QUOT} 2dip 3array ] map ] change-reg-outputs [ [ first3 ${def-quot} 2dip 3array ] map ] change-reg-outputs
[ [ first3 ${DEF-QUOT} 2dip 3array ] map ] change-stack-outputs [ [ first3 ${def-quot} 2dip 3array ] map ] change-stack-outputs
drop ; drop ;
! Special ${NAME}-insn-uses methods ! Special ${name}-insn-uses methods
M: ##parallel-copy ${NAME}-insn-uses M: ##parallel-copy ${name}-insn-uses
[ [ first2 ${USE-QUOT} call 2array ] map ] change-values drop ; [ [ first2 ${use-quot} call 2array ] map ] change-values drop ;
M: ##phi ${NAME}-insn-uses M: ##phi ${name}-insn-uses
[ ${USE-QUOT} assoc-map ] change-inputs drop ; [ ${use-quot} assoc-map ] change-inputs drop ;
M: alien-call-insn ${NAME}-insn-uses M: alien-call-insn ${name}-insn-uses
[ [ first3 ${USE-QUOT} 2dip 3array ] map ] change-reg-inputs [ [ first3 ${use-quot} 2dip 3array ] map ] change-reg-inputs
[ [ first3 ${USE-QUOT} 2dip 3array ] map ] change-stack-inputs [ [ first3 ${use-quot} 2dip 3array ] map ] change-stack-inputs
drop ; drop ;
M: ##alien-indirect ${NAME}-insn-uses M: ##alien-indirect ${name}-insn-uses
${USE-QUOT} change-src call-next-method ; ${use-quot} change-src call-next-method ;
M: ##callback-outputs ${NAME}-insn-uses M: ##callback-outputs ${name}-insn-uses
[ [ first3 ${USE-QUOT} 2dip 3array ] map ] change-reg-inputs [ [ first3 ${use-quot} 2dip 3array ] map ] change-reg-inputs
drop ; drop ;
<< <<
! Generate methods for everything else ! Generate methods for everything else
insn-classes get special-vreg-insns diff [ insn-def-slots empty? ] reject [ insn-classes get special-vreg-insns diff [ insn-def-slots empty? ] reject [
[ \ ${NAME}-insn-defs create-method-in ] [ \ ${name}-insn-defs create-method-in ]
[ insn-def-slots [ name>> ] map ${DEF-QUOT} slot-change-quot ] bi [ insn-def-slots [ name>> ] map ${def-quot} slot-change-quot ] bi
define define
] each ] each
insn-classes get special-vreg-insns diff [ insn-use-slots empty? ] reject [ insn-classes get special-vreg-insns diff [ insn-use-slots empty? ] reject [
[ \ ${NAME}-insn-uses create-method-in ] [ \ ${name}-insn-uses create-method-in ]
[ insn-use-slots [ name>> ] map ${USE-QUOT} slot-change-quot ] bi [ insn-use-slots [ name>> ] map ${use-quot} slot-change-quot ] bi
define define
] each ] each
insn-classes get [ insn-temp-slots empty? ] reject [ insn-classes get [ insn-temp-slots empty? ] reject [
[ \ ${NAME}-insn-temps create-method-in ] [ \ ${name}-insn-temps create-method-in ]
[ insn-temp-slots [ name>> ] map ${TEMP-QUOT} slot-change-quot ] bi [ insn-temp-slots [ name>> ] map ${temp-quot} slot-change-quot ] bi
define define
] each ] each
>> >>
]] ]]
! SYNTAX: \RENAMING: scan-token scan-object scan-object scan-object define-renaming ;

6
basis/sorting/functor/functor.factor
View File

@ -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 ;
]] ]]

36
basis/tuple-arrays/tuple-arrays.factor
View File

@ -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
]] ]]

18
extra/annotations/annotations.factor
View File

@ -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 ;

1
extra/modern/modern.factor
View File

@ -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 ] }