diff --git a/core/bootstrap/syntax.factor b/core/bootstrap/syntax.factor index a4e87f28d8..e7e90d8dd0 100755 --- a/core/bootstrap/syntax.factor +++ b/core/bootstrap/syntax.factor @@ -21,6 +21,7 @@ IN: bootstrap.syntax "C:" "CHAR:" "DEFER:" + "ERROR:" "F{" "FV{" "FORGET:" diff --git a/extra/locals/locals-docs.factor b/extra/locals/locals-docs.factor index 62f2eac513..372a567550 100644 --- a/extra/locals/locals-docs.factor +++ b/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: [| } diff --git a/extra/locals/locals-tests.factor b/extra/locals/locals-tests.factor index bd1e62f22a..4ee9b48bb7 100755 --- a/extra/locals/locals-tests.factor +++ b/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 + diff --git a/extra/locals/locals.factor b/extra/locals/locals.factor index 9f96a3444d..cc1785ff62 100755 --- a/extra/locals/locals.factor +++ b/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 -TUPLE: let bindings vars body ; +TUPLE: let bindings body ; C: let -TUPLE: wlet bindings vars body ; +TUPLE: let* bindings body ; + +C: let* + +TUPLE: wlet bindings body ; C: 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 , ; M: block lambda-rewrite* @@ -187,24 +191,18 @@ M: object local-rewrite* , ; ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -: make-locals ( seq -- words assoc ) - [ - "!" ?tail [ ] [ ] if - ] map dup [ - dup - [ dup word-name set ] each - [ - dup local-reader? [ - dup word-name set - ] [ - drop - ] if - ] each - ] H{ } make-assoc ; +: make-local ( name -- word ) + "!" ?tail [ + + dup dup word-name set + ] [ ] if + dup dup word-name set ; -: make-local-words ( seq -- words assoc ) - [ dup ] { } map>assoc - dup values swap ; +: make-locals ( seq -- words assoc ) + [ [ make-local ] map ] H{ } make-assoc ; + +: make-local-word ( name -- 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) ; + "|" parse-tokens make-locals dup push-locals + \ ] (parse-lambda) ; -: (parse-bindings) ( -- ) +: parse-binding ( -- pair/f ) scan dup "|" = [ - drop + drop f ] [ scan { { "[" [ \ ] parse-until >quotation ] } { "[|" [ parse-lambda ] } - } case 2array , - (parse-bindings) + } case 2array ] if ; -: parse-bindings ( -- alist ) - scan "|" assert= [ (parse-bindings) ] { } make dup keys ; +: (parse-bindings) ( -- ) + 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 -- ) + [ + >r 1array r> spin [ call ] curry compose + ] assoc-each local-rewrite* \ call , ; M: let local-rewrite* - { let-bindings let-vars let-body } get-slots -rot - [ ] 2apply - [ - 1array -rot second -rot - [ call ] curry compose - ] 2each local-rewrite* \ call , ; + { body>> bindings>> } get-slots let-rewrite ; + +M: let* local-rewrite* + { body>> bindings>> } get-slots let-rewrite ; M: wlet local-rewrite* - dup wlet-bindings values over wlet-vars rot wlet-body - [ call ] curry compose local-rewrite* \ call , ; + { body>> bindings>> } get-slots + [ [ ] 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) @@ -263,14 +295,17 @@ PRIVATE> : [| parse-lambda parsed ; parsing : [let - parse-bindings - make-locals \ ] (parse-lambda) - parsed ; parsing + scan "|" assert= parse-bindings +\ ] (parse-lambda) parsed ; parsing + +: [let* + scan "|" assert= parse-bindings* + >r \ ] parse-until >quotation parsed r> pop-locals ; + parsing : [wlet - parse-bindings - make-local-words \ ] (parse-lambda) - parsed ; parsing + scan "|" assert= parse-wbindings + \ ] (parse-lambda) parsed ; parsing MACRO: with-locals ( form -- quot ) lambda-rewrite ; @@ -297,31 +332,30 @@ SYMBOL: | M: lambda pprint* > pprint-vars \ | pprint-word - f + f > pprint-elements block> \ ] pprint-word block> ; -: pprint-let ( body vars bindings -- ) +: pprint-let ( let word -- ) + pprint-word + { body>> bindings>> } get-slots \ | pprint-word t r pprint-var r> pprint* block> ] 2each + [ r pprint-var r> pprint* block> ] assoc-each block> \ | pprint-word - block> ; - -M: let pprint* - \ [let pprint-word - { let-body let-vars let-bindings } get-slots pprint-let + block> \ ] pprint-word ; -M: wlet pprint* - \ [wlet pprint-word - { wlet-body wlet-vars wlet-bindings } get-slots pprint-let - \ ] pprint-word ; +M: let pprint* \ [let pprint-let ; + +M: wlet pprint* \ [wlet pprint-let ; + +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 ;