From ec05bf7be9a6af20c5f662ff50654c295a7116bc Mon Sep 17 00:00:00 2001 From: Doug Coleman Date: Sat, 25 Nov 2017 00:56:08 -0600 Subject: [PATCH] core: Add support for quotations inside stack-effects. Disabled: Preconditions for functors are awkward to implement without creating new syntax. Instead, allow stack effects of the form ( x: [ 1 + ] -- y ) everywhere. --- basis/help/markup/markup.factor | 4 +- .../specialized-arrays.factor | 6 +-- basis/tuple-arrays/tuple-arrays.factor | 45 +++++++------------ core/effects/effects.factor | 4 +- core/effects/parser/parser.factor | 6 +-- core/functors2/functors2.factor | 11 +++-- core/words/words.factor | 18 ++++++++ 7 files changed, 52 insertions(+), 42 deletions(-) diff --git a/basis/help/markup/markup.factor b/basis/help/markup/markup.factor index fb8b3d29dc..f1b2a38762 100644 --- a/basis/help/markup/markup.factor +++ b/basis/help/markup/markup.factor @@ -4,7 +4,7 @@ USING: accessors arrays assocs classes colors colors.constants combinators combinators.smart compiler.units definitions definitions.icons effects fry generic hash-sets hashtables help.stylesheet help.topics io io.styles kernel locals make math -namespaces parser present prettyprint prettyprint.stylesheet +math.parser namespaces parser present prettyprint prettyprint.stylesheet quotations see sequences sequences.private sets slots sorting splitting strings urls vectors vocabs vocabs.loader words words.symbol ; @@ -38,10 +38,12 @@ SYMBOL: blank-line GENERIC: print-element ( element -- ) +M: quotation print-element unparse print-element ; M: simple-element print-element [ print-element ] each ; M: string print-element [ write ] ($span) ; M: array print-element unclip execute( arg -- ) ; M: word print-element { } swap execute( arg -- ) ; +! M: number print-element number>string print-element ; M: effect print-element effect>string print-element ; M: f print-element drop ; diff --git a/basis/specialized-arrays/specialized-arrays.factor b/basis/specialized-arrays/specialized-arrays.factor index edd18a5d33..0c1b1947fc 100644 --- a/basis/specialized-arrays/specialized-arrays.factor +++ b/basis/specialized-arrays/specialized-arrays.factor @@ -7,10 +7,10 @@ sequences.private vocabs.generated vocabs.loader vocabs.parser words math.parser arrays ; IN: specialized-arrays -MIXIN: specialized-array +MIXIN: specialized-array-mixin MIXIN: specialized-array2 -INSTANCE: specialized-array sequence +INSTANCE: specialized-array-mixin sequence INSTANCE: specialized-array2 sequence : (underlying) ( n c-type -- array ) @@ -57,7 +57,7 @@ TUPLE: ${A} { underlying c-ptr read-only } { length array-capacity read-only } ; final -INSTANCE: ${A} specialized-array2 +INSTANCE: ${A} specialized-array-mixin : ${} ( alien len -- specialized-array ) ${A} boa ; inline diff --git a/basis/tuple-arrays/tuple-arrays.factor b/basis/tuple-arrays/tuple-arrays.factor index 39b7057591..0c562303ea 100644 --- a/basis/tuple-arrays/tuple-arrays.factor +++ b/basis/tuple-arrays/tuple-arrays.factor @@ -25,52 +25,41 @@ MACRO: write-tuple ( class -- quot ) [ tuple-arity [ '[ [ _ ] dip set-nth-unsafe ] ] map '[ _ cleave ] ] bi '[ _ dip @ ] ; -: check-final ( class -- ) +: check-final ( class -- class ) { { [ dup tuple-class? not ] [ not-a-tuple ] } { [ dup final-class? not ] [ not-final ] } - [ drop ] + [ ] } cond ; PRIVATE> - DEFINES <${CLASS}-array> ->CLASS-array DEFINES >${CLASS}-array - -WHERE - -CLASS check-final - -TUPLE: CLASS-array +TUPLE: ${CLASS}-array { seq array read-only } { n array-capacity read-only } { length array-capacity read-only } ; -: ( length -- tuple-array ) - [ \ CLASS [ initial-values concat ] [ tuple-arity ] bi ] keep - \ CLASS-array boa ; inline +INSTANCE: ${CLASS}-array sequence -M: CLASS-array length length>> ; inline +: <${CLASS}-array> ( length -- tuple-array ) + [ \ ${CLASS} [ initial-values concat ] [ tuple-arity ] bi ] keep + \ ${CLASS}-array boa ; inline -M: CLASS-array nth-unsafe tuple-slice \ CLASS read-tuple ; inline +M: ${CLASS}-array length length>> ; inline -M: CLASS-array set-nth-unsafe tuple-slice \ CLASS write-tuple ; inline +M: ${CLASS}-array nth-unsafe tuple-slice \ ${CLASS} read-tuple ; inline -M: CLASS-array new-sequence drop ; inline +M: ${CLASS}-array set-nth-unsafe tuple-slice \ ${CLASS} write-tuple ; inline -: >CLASS-array ( seq -- tuple-array ) 0 clone-like ; +M: ${CLASS}-array new-sequence drop <${CLASS}-array> ; inline -M: CLASS-array like drop dup CLASS-array? [ >CLASS-array ] unless ; inline +: >${CLASS}-array ( seq -- tuple-array ) 0 <${CLASS}-array> clone-like ; -INSTANCE: CLASS-array sequence +M: ${CLASS}-array like drop dup ${CLASS}-array? [ >${CLASS}-array ] unless ; inline -;FUNCTOR> - -SYNTAX: \TUPLE-ARRAY: scan-word define-tuple-array ; +]] diff --git a/core/effects/effects.factor b/core/effects/effects.factor index 636c7125ad..7a040cdf10 100644 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays classes combinators kernel make math -math.order math.parser sequences sequences.private strings words ; +math.order math.parser quotations sequences sequences.private +strings words ; IN: effects TUPLE: effect @@ -51,6 +52,7 @@ TUPLE: effect GENERIC: effect>string ( obj -- str ) M: string effect>string ; +M: quotation effect>string [ effect>string ] map " " join "[ " " ]" surround ; M: object effect>string drop "object" ; M: word effect>string name>> ; M: integer effect>string number>string ; diff --git a/core/effects/parser/parser.factor b/core/effects/parser/parser.factor index 46629023ed..06397c80bb 100644 --- a/core/effects/parser/parser.factor +++ b/core/effects/parser/parser.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2008, 2010 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators continuations effects -kernel lexer make namespaces parser sequences sets -splitting vocabs.parser words ; +USING: accessors arrays combinators continuations effects kernel +lexer make namespaces parser sequences sets splitting +vocabs.parser words ; IN: effects.parser DEFER: parse-effect diff --git a/core/functors2/functors2.factor b/core/functors2/functors2.factor index 7f7d10e5bb..0db9242c0b 100644 --- a/core/functors2/functors2.factor +++ b/core/functors2/functors2.factor @@ -1,10 +1,9 @@ ! Copyright (C) 2017 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors ascii assocs combinators -generalizations interpolate io.streams.string kernel -make math.parser namespaces parser quotations sequences -sequences.generalizations vocabs.generated vocabs.parser -words ; +USING: accessors arrays ascii assocs combinators generalizations +interpolate io.streams.string kernel make math.parser namespaces +parser quotations sequences sequences.generalizations +vocabs.generated vocabs.parser words ; QUALIFIED: sets IN: functors2 @@ -16,7 +15,7 @@ ERROR: not-all-unique seq ; : effect-in>drop-variables ( effect -- quot ) in>> ensure-unique - [ '[ name>> _ set ] ] map + [ '[ name>> _ dup array? [ first ] when set ] ] map '[ _ spread ] ; inline : make-in-drop-variables ( def effect -- def effect ) diff --git a/core/words/words.factor b/core/words/words.factor index cee910b3b0..def69b95eb 100644 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -119,7 +119,25 @@ M: word parent-word drop f ; 2tri ] if ; +![[ +: inline-quotation? ( obj -- ? ) + { [ dup array? [ length>> 2 >= ] [ drop f ] if ] [ second quotation? ] } 1&& ; + +: effect>inline-quotations ( effect -- quot/f ) + in>> + [ dup inline-quotation? [ last ] [ drop [ ] ] if ] map + dup [ length 0 > ] any? [ '[ _ spread ] ] [ drop f ] if ; + +: apply-inlined-effects ( def effect -- def effect ) + dup effect>inline-quotations dup [ + swap [ prepose ] dip + ] [ + drop + ] if ; +]] + : define-declared ( word def effect -- ) + ! apply-inlined-effects [ nip swap set-stack-effect ] [ drop define ] 3bi ; : make-deprecated ( word -- )