factor: Working on making locals-everywhere, array literals constructed

by ``output>array``, and fry with arrays.

We need to expand macros before doing the locals transform ``rewrite-closures`` and fry needs to happen in the locals pass because the locals pass touches the retainstack as part of the transform and we only want to do this once. We defer fry by making a <fryable> which rewrite-closures transforms.

Fixes things like the following that used to break because the locals
transform happened before fry.

::: bar ( a b -- a ) '[ |[ a | a _ + ] call ] call ;

Also we can use fry in case/cond now since macro-expansion happens
first.

Things like this work:
::: foo ( a b c -- a ) :> ( a b c ) c q{{ a b c a b + c _ }} ;
1 2 4 foo ...
{ 1 2 4 3 4 4 }

Triple colon will become colon soon.

Finally, there is a potential issue with macros changing the order of
fry underscore expansion since fry happens later. We need to rewrite fry
internally as 0_ 1_ 2_ so order is preserved everywhere in the expanded
macro.

basis/listener/listener.factor

@@ -129,7 +129,9 @@ t error-summary? set-global
     input-stream get prompt prompt.
 
     [
-        read-quot [
+        read-quot
+        [
+            ! [ rewrite-closures ] prepose
             '[ [ datastack _ with-datastack ] with-ctrl-break ]
             [ call-error-hook datastack ]
             recover

core/bootstrap/syntax.factor

@@ -164,5 +164,12 @@ IN: bootstrap.syntax
         "VARIABLES-FUNCTOR:"
         "STARTUP-HOOK:"
         "SHUTDOWN-HOOK:"
+
+        "]]"
+        "}}"
+        ":::"
+        "q[["
+        "{{"
+        "q{{"
     } [ "syntax" create-word drop ] each
 ] with-compilation-unit

core/fry/fry.factor

@@ -1,9 +1,13 @@
 ! Copyright (C) 2009 Slava Pestov, Eduardo Cavazos, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors combinators kernel locals.backend math
-quotations sequences sets splitting words ;
+math.parser quotations sequences sequences.private sets
+splitting words ;
 IN: fry
 
+TUPLE: fryable quot ;
+C: <fryable> fryable
+
 ERROR: >r/r>-in-fry-error ;
 
 GENERIC: fry ( quot -- quot' )
@@ -115,7 +119,7 @@ TUPLE: dredge-fry-state
 : push-subquot ( tail elt state -- )
     [ fry swap >quotation count-inputs [ndip] ] dip prequot>> push-all ; inline
 
-: (dredge-fry-subquot) ( n state i elt -- )
+: dredge-fry-subquot ( n state i elt -- )
     rot {
         [ nip in-quot-slices ] ! head tail i elt state
         [ [ 2drop swap ] dip push-head-slice ]
@@ -123,21 +127,36 @@ TUPLE: dredge-fry-state
         [ [ 1 + ] [ drop ] [ ] tri* dredge-fry ]
     } 3cleave ; inline recursive
 
-: (dredge-fry-simple) ( n state -- )
+: dredge-fry-simple ( n state -- )
     [ in-quot>> swap tail-slice ] [ quot>> ] bi push-all ; inline recursive
 
 : dredge-fry ( n dredge-fry -- )
     2dup in-quot>> [ fried? ] find-from
-    [ (dredge-fry-subquot) ]
-    [ drop (dredge-fry-simple) ] if* ; inline recursive
+    [ dredge-fry-subquot ]
+    [ drop dredge-fry-simple ] if* ; inline recursive
 
 PRIVATE>
 
 M: callable fry ( quot -- quot' )
-    [ [ [ ] ] ] [
+    [
+        [ [ ] ]
+    ] [
         0 swap <dredge-fry>
         [ dredge-fry ] [
             [ prequot>> >quotation ]
             [ quot>> >quotation shallow-fry ] bi append
         ] bi
     ] if-empty ;
+
+: number-underscores ( quot -- quot' )
+    0 swap [
+        dup \ _ eq? [
+            drop [ 1 + ] keep
+            number>string "_" append
+        ] [
+
+        ] if
+    ] map nip ;
+
+: fry-to-locals ( quot -- quot' )
+    check-fry mark-composes ;

core/locals/fry/fry.factor

@@ -1,7 +1,7 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
 USING: accessors fry fry.private generalizations kernel
-locals.types sequences ;
+locals.types macros.expander sequences ;
 IN: locals.fry
 
 ! Support for mixing locals with fry
@@ -17,5 +17,9 @@ M: lambda fry
 M: let fry
     clone [ fry ] change-body ;
 
+M: fryable condomize? drop t ;
+M: fryable call quot>> call ;
+
 INSTANCE: lambda fried
 INSTANCE: let    fried
+INSTANCE: fryable fried

core/locals/parser/parser.factor

@@ -98,3 +98,21 @@ M: lambda-parser parse-quotation ( -- quotation )
             parse-locals-method-definition drop
         ] with-method-definition
     ] with-definition ;
+
+: (:::) ( -- word def effect )
+    [
+        scan-new-word scan-effect
+        { } H{ } [ \ ; parse-until >quotation ] with-lambda-scope
+        <lambda> rewrite-closures
+        dup length 1 = [ "rewritten closures length not 1" throw ] unless first
+    ] with-definition swap ;
+
+
+: (M:::) ( -- word def )
+    [
+        scan-new-method
+        [
+            [ parse-definition ]
+            parse-locals-method-definition drop
+        ] with-method-definition
+    ] with-definition ;

core/locals/rewrite/closures/closures.factor

@@ -1,6 +1,6 @@
 ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: accessors kernel locals.rewrite.point-free
+USING: accessors fry kernel locals.rewrite.point-free
 locals.rewrite.sugar locals.types macros.expander make
 quotations sequences sets words ;
 IN: locals.rewrite.closures
@@ -24,6 +24,8 @@ M: def defs-vars* local>> unquote suffix ;
 
 M: quotation defs-vars* [ defs-vars* ] each ;
 
+M: fryable defs-vars* quot>> defs-vars* ;
+
 M: object defs-vars* drop ;
 
 GENERIC: uses-vars* ( seq form -- seq' )
@@ -40,6 +42,8 @@ M: object uses-vars* drop ;
 
 M: quotation uses-vars* [ uses-vars* ] each ;
 
+M: fryable uses-vars* quot>> uses-vars* ;
+
 : free-vars ( form -- seq )
     [ uses-vars ] [ defs-vars ] bi diff ;
 
@@ -52,4 +56,6 @@ M: callable rewrite-closures*
     [ length \ curry <repetition> % ]
     tri ;
 
+M: fryable rewrite-closures* quot>> fry rewrite-closures* \ call , ;
+
 M: object rewrite-closures* , ;

core/locals/rewrite/point-free/point-free.factor

@@ -37,11 +37,15 @@ M: object localize 1quotation ;
 
 ! We special-case all the :> at the start of a quotation
 : load-locals-quot ( args -- quot )
-    [ [ ] ] [
+    [
+        [ ]
+    ] [
         dup [ local-reader? ] any? [
             dup [ local-reader? [ 1array ] [ ] ? ] map
             deep-spread>quot
-        ] [ [ ] ] if swap length [ load-locals ] curry append
+        ] [
+            [ ]
+        ] if swap length [ load-locals ] curry append
     ] if-empty ;
 
 : load-locals-index ( quot -- n )

core/locals/rewrite/sugar/sugar.factor

@@ -29,6 +29,8 @@ M: callable rewrite-sugar* quotation-rewrite , ;
 
 M: lambda rewrite-sugar* quotation-rewrite , ;
 
+M: fryable rewrite-sugar* , ;
+
 GENERIC: rewrite-literal? ( obj -- ? )
 
 M: special rewrite-literal? drop t ;

core/syntax/modern/modern.factor

@@ -180,3 +180,5 @@ ERROR: no-paren-container-word payload word ;
 \ lookup-char "ch" set-container-word
 \ no-op "data-stack" set-lower-colon-word
 ! USE: urls \ >url "url" set-container-word
+
+

core/syntax/syntax.factor

@@ -4,16 +4,17 @@ USING: accessors arrays assocs byte-arrays byte-vectors classes
 classes.algebra.private classes.builtin classes.error
 classes.intersection classes.maybe classes.mixin classes.parser
 classes.predicate classes.singleton classes.tuple
-classes.tuple.parser classes.union combinators compiler.units
-definitions delegate delegate.private effects effects.parser factor
-fry functors2 generic generic.hook generic.math generic.parser
-generic.standard hash-sets hashtables hashtables.identity hints
-init interpolate io.pathnames kernel lexer locals.errors
-locals.parser locals.types macros math memoize multiline
-namespaces parser quotations sbufs sequences slots source-files
-splitting stack-checker strings strings.parser system typed
-vectors vocabs.parser vocabs.platforms words words.alias
-words.constant words.inlined words.symbol ;
+classes.tuple.parser classes.union combinators combinators.smart
+compiler.units definitions delegate delegate.private effects
+effects.parser factor fry functors2 generic generic.hook
+generic.math generic.parser generic.standard hash-sets
+hashtables hashtables.identity hints init interpolate
+io.pathnames kernel lexer locals.errors locals.parser
+locals.types macros math memoize multiline namespaces parser
+quotations sbufs sequences slots source-files splitting
+stack-checker strings strings.parser system typed vectors
+vocabs.parser vocabs.platforms words words.alias words.constant
+words.inlined words.symbol ;
 IN: bootstrap.syntax
 
 ! These words are defined as a top-level form, instead of with
@@ -456,4 +457,29 @@ IN: bootstrap.syntax
     "VARIABLES-FUNCTOR:" [
         scan-new-word scan-effect scan-object scan-object make-variable-functor
     ] define-core-syntax
+
+    ":::" [
+        (:::) apply-inlined-effects define-declared
+    ] define-core-syntax
+
+    {
+        "}}" "]]"
+    } [ define-delimiter ] each
+
+    "q[[" [
+        \ ]] parse-until >quotation <fryable> suffix!
+    ] define-core-syntax
+
+
+    "q{{" [
+        \ }} parse-until >quotation [ output>array ] curry
+        <fryable> suffix! \ call suffix!
+    ] define-core-syntax
+
+    "{{" [
+        \ }}
+        [ >quotation [ output>array ] curry [ call ] curry ]
+        [ parse-until ] dip call append!
+    ] define-core-syntax
+
 ] with-compilation-unit