Merge branch 'master' of git://factorcode.org/git/factor

core/bootstrap/syntax.factor

@@ -21,6 +21,7 @@ IN: bootstrap.syntax
     "C:"
     "CHAR:"
     "DEFER:"
+    "ERROR:"
     "F{"
     "FV{"
     "FORGET:"

extra/locals/locals-docs.factor

@@ -25,7 +25,7 @@ $with-locals-note ;
 
 HELP: [let
 { $syntax "[let | binding1 [ value1... ]\n       binding2 [ value2... ]\n       ... |\n    body... ]" }
-{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
+{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated in parallel, and may not refer to other bindings within the same " { $link POSTPONE: [let } " form; for Lisp programmers, this means that " { $link POSTPONE: [let } " is equivalent to the Lisp " { $snippet "let" } ", not " { $snippet "let*" } "." }
 { $examples
     { $example
         "USING: kernel locals math math.functions prettyprint sequences ;"
@@ -38,6 +38,24 @@ HELP: [let
 }
 $with-locals-note ;
 
+HELP: [let*
+{ $syntax "[let* | binding1 [ value1... ]\n       binding2 [ value2... ]\n       ... |\n    body... ]" }
+{ $description "Introduces a set of lexical bindings and evaluates the body. The values are evaluated sequentially, and may refer to previous bindings from the same " { $link POSTPONE: [let* } " form; for Lisp programmers, this means that " { $link POSTPONE: [let* } " is equivalent to the Lisp " { $snippet "let*" } ", not " { $snippet "let" } "." }
+{ $examples
+    { $example
+        "USING: kernel locals math math.functions prettyprint sequences ;"
+        ":: frobnicate ( n seq -- newseq )"
+        "    [let* | a [ n 3 + ]"
+        "            b [ a 4 * ] |"
+        "        seq [ b / ] map ] ;"
+        "1 { 32 48 } frobnicate ."
+        "{ 2 3 }"
+    }
+}
+$with-locals-note ;
+
+{ POSTPONE: [let POSTPONE: [let* } related-words
+
 HELP: [wlet
 { $syntax "[wlet | binding1 [ body1... ]\n        binding2 [ body2... ]\n        ... |\n     body... ]" }
 { $description "Introduces a set of lexically-scoped non-recursive local functions. The bodies may not refer to other bindings within the same " { $link POSTPONE: [wlet } " form; for Lisp programmers, this means that Factor's " { $link POSTPONE: [wlet } " is equivalent to the Lisp " { $snippet "flet" } ", not " { $snippet "labels" } "." }
@@ -106,6 +124,7 @@ $nl
 { $subsection with-locals }
 "Lexical binding forms:"
 { $subsection POSTPONE: [let }
+{ $subsection POSTPONE: [let* }
 { $subsection POSTPONE: [wlet }
 "Lambda abstractions:"
 { $subsection POSTPONE: [| }

extra/locals/locals-tests.factor

@@ -195,3 +195,36 @@ DEFER: xyzzy
 ] unit-test
 
 [ 5 ] [ 10 xyzzy ] unit-test
+
+:: let*-test-1 ( a -- b )
+    [let* | b [ a 1+ ]
+            c [ b 1+ ] |
+        a b c 3array ] ;
+
+[ { 1 2 3 } ] [ 1 let*-test-1 ] unit-test
+
+:: let*-test-2 ( a -- b )
+    [let* | b [ a 1+ ]
+            c! [ b 1+ ] |
+        a b c 3array ] ;
+
+[ { 1 2 3 } ] [ 1 let*-test-2 ] unit-test
+
+:: let*-test-3 ( a -- b )
+    [let* | b [ a 1+ ]
+            c! [ b 1+ ] |
+        c 1+ c!  a b c 3array ] ;
+
+[ { 1 2 4 } ] [ 1 let*-test-3 ] unit-test
+
+:: let*-test-4 ( a b -- c d )
+    [let | a [ b ]
+           b [ a ] |
+        [let* | a'  [ a  ]
+                a'' [ a' ]
+                b'  [ b  ]
+                b'' [ b' ] |
+            a'' b'' ] ] ;
+
+[ "xxx" "yyy" ] [ "yyy" "xxx" let*-test-4 ] unit-test
+

extra/locals/locals.factor

@@ -5,7 +5,7 @@ inference.transforms parser words quotations debugger macros
 arrays macros splitting combinators prettyprint.backend
 definitions prettyprint hashtables combinators.lib
 prettyprint.sections sequences.private effects generic
-compiler.units combinators.cleave ;
+compiler.units combinators.cleave new-slots accessors ;
 IN: locals
 
 ! Inspired by
@@ -17,11 +17,15 @@ TUPLE: lambda vars body ;
 
 C: <lambda> lambda
 
-TUPLE: let bindings vars body ;
+TUPLE: let bindings body ;
 
 C: <let> let
 
-TUPLE: wlet bindings vars body ;
+TUPLE: let* bindings body ;
+
+C: <let*> let*
+
+TUPLE: wlet bindings body ;
 
 C: <wlet> wlet
 
@@ -137,7 +141,7 @@ M: object free-vars drop { } ;
 M: quotation free-vars { } [ add-if-free ] reduce ;
 
 M: lambda free-vars
-    dup lambda-vars swap lambda-body free-vars seq-diff ;
+    dup vars>> swap body>> free-vars seq-diff ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 ! lambda-rewrite
@@ -164,12 +168,12 @@ M: callable block-body ;
 M: callable local-rewrite*
     [ [ local-rewrite* ] each ] [ ] make , ;
 
-M: lambda block-vars lambda-vars ;
+M: lambda block-vars vars>> ;
 
-M: lambda block-body lambda-body ;
+M: lambda block-body body>> ;
 
 M: lambda local-rewrite*
-    dup lambda-vars swap lambda-body
+    dup vars>> swap body>>
     [ local-rewrite* \ call , ] [ ] make <lambda> , ;
 
 M: block lambda-rewrite*
@@ -187,24 +191,18 @@ M: object local-rewrite* , ;
 
 ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
 
-: make-locals ( seq -- words assoc )
+: make-local ( name -- word )
-    [
+    "!" ?tail [
-        "!" ?tail [ <local-reader> ] [ <local> ] if
+        <local-reader>
-    ] map dup [
+        dup <local-writer> dup word-name set
-        dup
+    ] [ <local> ] if
-        [ dup word-name set ] each
+    dup dup word-name set ;
-        [
-            dup local-reader? [
-                <local-writer> dup word-name set
-            ] [
-                drop
-            ] if
-        ] each
-    ] H{ } make-assoc ;
 
-: make-local-words ( seq -- words assoc )
+: make-locals ( seq -- words assoc )
-    [ dup <local-word> ] { } map>assoc
+    [ [ make-local ] map ] H{ } make-assoc ;
-    dup values swap ;
+
+: make-local-word ( name -- word )
+    <local-word> dup dup word-name set ;
 
 : push-locals ( assoc -- )
     use get push ;
@@ -213,41 +211,75 @@ M: object local-rewrite* , ;
     use get delete ;
 
 : (parse-lambda) ( assoc end -- quot )
-    over push-locals parse-until >quotation swap pop-locals ;
+    parse-until >quotation swap pop-locals ;
 
 : parse-lambda ( -- lambda )
-    "|" parse-tokens make-locals \ ] (parse-lambda) <lambda> ;
+    "|" parse-tokens make-locals dup push-locals
+    \ ] (parse-lambda) <lambda> ;
 
-: (parse-bindings) ( -- )
+: parse-binding ( -- pair/f )
     scan dup "|" = [
-        drop
+        drop f
     ] [
         scan {
             { "[" [ \ ] parse-until >quotation ] }
             { "[|" [ parse-lambda ] }
-        } case 2array ,
+        } case 2array
-        (parse-bindings)
     ] if ;
 
-: parse-bindings ( -- alist )
+: (parse-bindings) ( -- )
-    scan "|" assert= [ (parse-bindings) ] { } make dup keys ;
+    parse-binding [
+        first2 >r make-local r> 2array ,
+        (parse-bindings)
+    ] when* ;
+
+: parse-bindings ( -- bindings vars )
+    [
+        [ (parse-bindings) ] H{ } make-assoc
+        dup push-locals
+    ] { } make swap ;
+
+: parse-bindings* ( -- words assoc )
+    [
+        [
+            namespace push-locals
+
+            (parse-bindings)
+        ] { } make-assoc
+    ] { } make swap ;
+
+: (parse-wbindings) ( -- )
+    parse-binding [
+        first2 >r make-local-word r> 2array ,
+        (parse-wbindings)
+    ] when* ;
+
+: parse-wbindings ( -- bindings vars )
+    [
+        [ (parse-wbindings) ] H{ } make-assoc
+        dup push-locals
+    ] { } make swap ;
+
+: let-rewrite ( body bindings -- )
+    <reversed> [
+        >r 1array r> spin <lambda> [ call ] curry compose
+    ] assoc-each local-rewrite* \ call , ;
 
 M: let local-rewrite*
-    { let-bindings let-vars let-body } get-slots -rot
+    { body>> bindings>> } get-slots let-rewrite ;
-    [ <reversed> ] 2apply
+
-    [
+M: let* local-rewrite*
-        1array -rot second -rot <lambda>
+    { body>> bindings>> } get-slots let-rewrite ;
-        [ call ] curry compose
-    ] 2each local-rewrite* \ call , ;
 
 M: wlet local-rewrite*
-    dup wlet-bindings values over wlet-vars rot wlet-body
+    { body>> bindings>> } get-slots
-    <lambda> [ call ] curry compose local-rewrite* \ call , ;
+    [ [ ] curry ] assoc-map
+    let-rewrite ;
 
-: parse-locals
+: parse-locals ( -- vars assoc )
     parse-effect
     word [ over "declared-effect" set-word-prop ] when*
-    effect-in make-locals ;
+    effect-in make-locals dup push-locals ;
 
 : parse-locals-definition ( word -- word quot )
     scan "(" assert= parse-locals \ ; (parse-lambda) <lambda>
@@ -263,14 +295,17 @@ PRIVATE>
 : [| parse-lambda parsed ; parsing
 
 : [let
-    parse-bindings
+    scan "|" assert= parse-bindings
-    make-locals \ ] (parse-lambda)
+\ ] (parse-lambda) <let> parsed ; parsing
-    <let> parsed ; parsing
+
+: [let*
+    scan "|" assert= parse-bindings*
+    >r \ ] parse-until >quotation <let*> parsed r> pop-locals ;
+    parsing
 
 : [wlet
-    parse-bindings
+    scan "|" assert= parse-wbindings
-    make-local-words \ ] (parse-lambda)
+    \ ] (parse-lambda) <wlet> parsed ; parsing
-    <wlet> parsed ; parsing
 
 MACRO: with-locals ( form -- quot ) lambda-rewrite ;
 
@@ -297,31 +332,30 @@ SYMBOL: |
 M: lambda pprint*
     <flow
     \ [| pprint-word
-    dup lambda-vars pprint-vars
+    dup vars>> pprint-vars
     \ | pprint-word
-    f <inset lambda-body pprint-elements block>
+    f <inset body>> pprint-elements block>
     \ ] pprint-word
     block> ;
 
-: pprint-let ( body vars bindings -- )
+: pprint-let ( let word -- )
+    pprint-word
+    { body>> bindings>> } get-slots
     \ | pprint-word
     t <inset
     <block
-    values [ <block >r pprint-var r> pprint* block> ] 2each
+    [ <block >r pprint-var r> pprint* block> ] assoc-each
     block>
     \ | pprint-word
     <block pprint-elements block>
-    block> ;
+    block>
-
-M: let pprint*
-    \ [let pprint-word
-    { let-body let-vars let-bindings } get-slots pprint-let
     \ ] pprint-word ;
 
-M: wlet pprint*
+M: let pprint* \ [let pprint-let ;
-    \ [wlet pprint-word
+
-    { wlet-body wlet-vars wlet-bindings } get-slots pprint-let
+M: wlet pprint* \ [wlet pprint-let ;
-    \ ] pprint-word ;
+
+M: let* pprint* \ [let* pprint-let ;
 
 PREDICATE: word lambda-word
     "lambda" word-prop >boolean ;
@@ -329,7 +363,7 @@ PREDICATE: word lambda-word
 M: lambda-word definer drop \ :: \ ; ;
 
 M: lambda-word definition
-    "lambda" word-prop lambda-body ;
+    "lambda" word-prop body>> ;
 
 : lambda-word-synopsis ( word -- )
     dup definer.
@@ -345,7 +379,7 @@ PREDICATE: macro lambda-macro
 M: lambda-macro definer drop \ MACRO:: \ ; ;
 
 M: lambda-macro definition
-    "lambda" word-prop lambda-body ;
+    "lambda" word-prop body>> ;
 
 M: lambda-macro synopsis* lambda-word-synopsis ;
 
@@ -355,10 +389,10 @@ PREDICATE: method-body lambda-method
 M: lambda-method definer drop \ M:: \ ; ;
 
 M: lambda-method definition
-    "lambda" word-prop lambda-body ;
+    "lambda" word-prop body>> ;
 
 : method-stack-effect ( method -- effect )
-    dup "lambda" word-prop lambda-vars
+    dup "lambda" word-prop vars>>
     swap "method-generic" word-prop stack-effect
     dup [ effect-out ] when
     <effect> ;