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

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
 
 : ${<direct-A>} ( alien len -- specialized-array ) ${A} boa ; inline
 

basis/tuple-arrays/tuple-arrays.factor

@@ -25,52 +25,41 @@ MACRO: write-tuple ( class -- quot )
     [ tuple-arity <iota> <reversed> [ '[ [ _ ] 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>
 
-<FUNCTOR: define-tuple-array ( CLASS -- )
+FUNCTOR: tuple-array ( CLASS: [ check-final ] -- ) [[
 
-CLASS IS ${CLASS}
+USING: accessors arrays classes.tuple.private kernel sequences
+sequences.private tuple-arrays.private ;
 
-CLASS-array DEFINES-CLASS ${CLASS}-array
-CLASS-array? IS ${CLASS-array}?
-
-<CLASS-array> 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 } ;
 
-: <CLASS-array> ( length -- tuple-array )
-    [ \ CLASS [ initial-values <repetition> 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 <repetition> 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 <CLASS-array> ; inline
+M: ${CLASS}-array set-nth-unsafe tuple-slice \ ${CLASS} write-tuple ; inline
 
-: >CLASS-array ( seq -- tuple-array ) 0 <CLASS-array> 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 ;
+]]

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 ;

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

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 )

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