From d096d6b740e85528863c2b870cec8d786e11ef2f Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Thu, 28 Dec 2017 19:15:31 -0800 Subject: [PATCH] functors: no UPPER: in stack effects --- basis/alien/complex/functor/functor.factor | 18 +-- basis/alien/destructors/destructors.factor | 19 ++- .../cfg/renaming/functor/functor.factor | 111 ++++++++---------- basis/sorting/functor/functor.factor | 6 +- basis/tuple-arrays/tuple-arrays.factor | 36 +++--- extra/annotations/annotations.factor | 18 ++- extra/modern/modern.factor | 1 + 7 files changed, 98 insertions(+), 111 deletions(-) diff --git a/basis/alien/complex/functor/functor.factor b/basis/alien/complex/functor/functor.factor index 201a2bac82..89c9d59281 100644 --- a/basis/alien/complex/functor/functor.factor +++ b/basis/alien/complex/functor/functor.factor @@ -3,24 +3,24 @@ USING: functors2 ; 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 ; QUALIFIED: math << - STRUCT: ${T} { real ${N} } { imaginary ${N} } ; + STRUCT: ${t} { real ${n} } { imaginary ${n} } ; - : <${T}> ( z -- alien ) - math:>rect ${T} >c-ptr ; + : <${t}> ( z -- alien ) + math:>rect ${t} >c-ptr ; - : *${T} ( alien -- z ) - ${T} memory>struct [ real>> ] [ imaginary>> ] bi math:rect> ; inline + : *${t} ( alien -- z ) + ${t} memory>struct [ real>> ] [ imaginary>> ] bi math:rect> ; inline >> - \ ${T} lookup-c-type - [ <${T}> ] >>unboxer-quot - [ *${T} ] >>boxer-quot + \ ${t} lookup-c-type + [ <${t}> ] >>unboxer-quot + [ *${t} ] >>boxer-quot complex >>boxed-class drop diff --git a/basis/alien/destructors/destructors.factor b/basis/alien/destructors/destructors.factor index cb8e36765d..0e226eb8ae 100644 --- a/basis/alien/destructors/destructors.factor +++ b/basis/alien/destructors/destructors.factor @@ -5,19 +5,18 @@ IN: alien.destructors TUPLE: alien-destructor alien ; -INLINE-FUNCTOR: destructor ( F: existing-word -- ) [[ -USING: accessors alien.destructors effects generalizations -destructors kernel literals sequences ; +INLINE-FUNCTOR: destructor ( f: existing-word -- ) [[ + USING: accessors alien.destructors effects generalizations + destructors kernel literals sequences ; -TUPLE: ${F}-destructor < alien-destructor ; + TUPLE: ${f}-destructor < alien-destructor ; -: <${F}-destructor> ( alien -- destructor ) - ${F}-destructor boa ; inline + : <${f}-destructor> ( alien -- destructor ) + ${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 - -M: ${F}-destructor dispose alien>> ${F} $[ \ ${F} stack-effect out>> length ] ndrop ; + : |${f} ( alien -- alien ) dup <${f}-destructor> |dispose drop ; inline + M: ${f}-destructor dispose alien>> ${f} $[ \ ${f} stack-effect out>> length ] ndrop ; ]] diff --git a/basis/compiler/cfg/renaming/functor/functor.factor b/basis/compiler/cfg/renaming/functor/functor.factor index cd0d8f2be3..573dc58339 100644 --- a/basis/compiler/cfg/renaming/functor/functor.factor +++ b/basis/compiler/cfg/renaming/functor/functor.factor @@ -9,79 +9,70 @@ IN: compiler.cfg.renaming.functor '[ [ _ ] dip changer-word [ ] 2sequence ] map [ ] join [ 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 -! rename-insn-uses DEFINES ${NAME}-insn-uses -! rename-insn-temps DEFINES ${NAME}-insn-temps + M: insn ${name}-insn-defs drop ; + M: insn ${name}-insn-uses drop ; + M: insn ${name}-insn-temps drop ; -! WHERE + ! Instructions with unusual operands -GENERIC: ${NAME}-insn-defs ( insn -- ) -GENERIC: ${NAME}-insn-uses ( insn -- ) -GENERIC: ${NAME}-insn-temps ( insn -- ) + ! Special ${name}-insn-defs methods + M: ##parallel-copy ${name}-insn-defs + [ [ first2 ${def-quot} dip 2array ] map ] change-values drop ; -M: insn ${NAME}-insn-defs drop ; -M: insn ${NAME}-insn-uses drop ; -M: insn ${NAME}-insn-temps drop ; + M: ##phi ${name}-insn-defs ${def-quot} change-dst 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: ##parallel-copy ${NAME}-insn-defs - [ [ first2 ${DEF-QUOT} dip 2array ] map ] change-values drop ; + M: ##callback-inputs ${name}-insn-defs + [ [ first3 ${def-quot} 2dip 3array ] map ] change-reg-outputs + [ [ 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 - [ [ first3 ${DEF-QUOT} 2dip 3array ] map ] change-reg-outputs - drop ; + M: ##phi ${name}-insn-uses + [ ${use-quot} assoc-map ] change-inputs drop ; -M: ##callback-inputs ${NAME}-insn-defs - [ [ first3 ${DEF-QUOT} 2dip 3array ] map ] change-reg-outputs - [ [ first3 ${DEF-QUOT} 2dip 3array ] map ] change-stack-outputs - drop ; + M: alien-call-insn ${name}-insn-uses + [ [ first3 ${use-quot} 2dip 3array ] map ] change-reg-inputs + [ [ first3 ${use-quot} 2dip 3array ] map ] change-stack-inputs + drop ; -! Special ${NAME}-insn-uses methods -M: ##parallel-copy ${NAME}-insn-uses - [ [ first2 ${USE-QUOT} call 2array ] map ] change-values drop ; + M: ##alien-indirect ${name}-insn-uses + ${use-quot} change-src call-next-method ; -M: ##phi ${NAME}-insn-uses - [ ${USE-QUOT} assoc-map ] change-inputs drop ; + M: ##callback-outputs ${name}-insn-uses + [ [ 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 - [ [ first3 ${USE-QUOT} 2dip 3array ] map ] change-stack-inputs - drop ; + << + ! 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 -M: ##alien-indirect ${NAME}-insn-uses - ${USE-QUOT} change-src call-next-method ; + 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 -M: ##callback-outputs ${NAME}-insn-uses - [ [ first3 ${USE-QUOT} 2dip 3array ] map ] change-reg-inputs - drop ; - -<< -! 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 ->> + 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 ; diff --git a/basis/sorting/functor/functor.factor b/basis/sorting/functor/functor.factor index e9425240fa..df6d3b7a0b 100644 --- a/basis/sorting/functor/functor.factor +++ b/basis/sorting/functor/functor.factor @@ -3,7 +3,7 @@ USING: functors2 quotations strings ; IN: sorting.functor -INLINE-FUNCTOR: sorting ( NAME: name QUOT: string -- ) [[ - : ${NAME}<=> ( obj1 obj2 -- <=> ) ${QUOT} compare ; - : ${NAME}>=< ( obj1 obj2 -- >=< ) ${NAME}<=> invert-comparison ; +INLINE-FUNCTOR: sorting ( name: name quot: string -- ) [[ + : ${name}<=> ( obj1 obj2 -- <=> ) ${quot} compare ; + : ${name}>=< ( obj1 obj2 -- >=< ) ${name}<=> invert-comparison ; ]] diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 6fb39bc886..c193bc7ae4 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -34,32 +34,30 @@ MACRO: write-tuple ( class -- quot ) 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 -sequences.private tuple-arrays.private ; + TUPLE: ${class}-array + { seq array read-only } + { n array-capacity read-only } + { length array-capacity read-only } ; -TUPLE: ${CLASS}-array -{ seq array read-only } -{ n array-capacity read-only } -{ length array-capacity read-only } ; + INSTANCE: ${class}-array sequence -INSTANCE: ${CLASS}-array sequence + : <${class}-array> ( length -- tuple-array ) + [ \ ${class} [ initial-values concat ] [ tuple-arity ] bi ] keep + \ ${class}-array boa ; inline -: <${CLASS}-array> ( length -- tuple-array ) - [ \ ${CLASS} [ initial-values concat ] [ tuple-arity ] bi ] keep - \ ${CLASS}-array boa ; inline + M: ${class}-array length length>> ; 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 ; - -M: ${CLASS}-array like drop dup ${CLASS}-array? [ >${CLASS}-array ] unless ; inline + : >${class}-array ( seq -- tuple-array ) 0 <${class}-array> clone-like ; + M: ${class}-array like drop dup ${class}-array? [ >${class}-array ] unless ; inline ]] diff --git a/extra/annotations/annotations.factor b/extra/annotations/annotations.factor index b624bc7448..68f3a45b22 100644 --- a/extra/annotations/annotations.factor +++ b/extra/annotations/annotations.factor @@ -14,20 +14,18 @@ IN: annotations [ { [ word? ] [ vocabulary>> "annotations" = ] } 1&& not ] 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. ( -- ) - ${NAME}s sorted-definitions. ; + : ${name}s ( -- usages ) + \ (${name}) (non-annotation-usage) ; + : ${name}s. ( -- ) + ${name}s sorted-definitions. ; ]] SYNTAX: \ANNOTATIONS: ";" [ define-annotation ] each-token ; diff --git a/extra/modern/modern.factor b/extra/modern/modern.factor index 46bb9645a5..17adfafcee 100644 --- a/extra/modern/modern.factor +++ b/extra/modern/modern.factor @@ -210,6 +210,7 @@ ERROR: unexpected-terminator n string slice ; swap ! What ended the FOO: .. ; form? ! 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 ) dup ?last { { [ dup ";" sequence= ] [ drop unclip-last 3array ] }