From 6bc25c6649e5570a2a07de22992d4ec466e09ec8 Mon Sep 17 00:00:00 2001 From: John Benediktsson Date: Fri, 19 Mar 2021 14:08:38 -0700 Subject: [PATCH] locals: simplify point-free using multi-def. --- core/locals/locals-tests.factor | 4 ++ core/locals/parser/parser-tests.factor | 13 ++++- core/locals/rewrite/closures/closures.factor | 2 + .../rewrite/point-free/point-free.factor | 47 ++++--------------- core/locals/rewrite/sugar/sugar.factor | 17 ++++--- core/locals/types/types.factor | 6 +-- 6 files changed, 41 insertions(+), 48 deletions(-) diff --git a/core/locals/locals-tests.factor b/core/locals/locals-tests.factor index 34723e91e9..3f9b6bf561 100644 --- a/core/locals/locals-tests.factor +++ b/core/locals/locals-tests.factor @@ -458,6 +458,10 @@ M:: integer lambda-method-forget-test ( a -- b ) a ; [| | 0 '[ [let 10 :> A A _ + ] ] call ] call ] unit-test +{ { 1 2 3 4 } { 2 2 8 4 } } [ + 1 2 3 4 [| a! b c! d | { a b c d } a 1 + a! c 5 + c! { a b c d } ] call +] unit-test + ! littledan found this problem { "bar" } [ [let [let "bar" :> foo foo ] :> a a ] ] unit-test { 10 } [ [let 10 :> a [let a :> b b ] ] ] unit-test diff --git a/core/locals/parser/parser-tests.factor b/core/locals/parser/parser-tests.factor index 50ba01c4a3..df0466b8bc 100644 --- a/core/locals/parser/parser-tests.factor +++ b/core/locals/parser/parser-tests.factor @@ -9,7 +9,7 @@ IN: locals.parser.tests ! (::) { "dobiedoo" - [ 1 load-locals 1 drop-locals ] + [ load-local 1 drop-locals ] ( x -- y ) } [ [ @@ -18,6 +18,17 @@ IN: locals.parser.tests [ name>> ] 2dip ] unit-test +{ + "dobiedoo" + [ 2 load-locals 2 drop-locals ] + ( x y -- z ) +} [ + [ + { "dobiedoo ( x y -- z ) ;" } [ (::) ] with-lexer + ] with-compilation-unit + [ name>> ] 2dip +] unit-test + ! parse-def { "um" t } [ [ diff --git a/core/locals/rewrite/closures/closures.factor b/core/locals/rewrite/closures/closures.factor index cb17b3be62..71cc8bbf95 100644 --- a/core/locals/rewrite/closures/closures.factor +++ b/core/locals/rewrite/closures/closures.factor @@ -22,6 +22,8 @@ GENERIC: defs-vars* ( seq form -- seq' ) M: def defs-vars* local>> unquote suffix ; +M: multi-def defs-vars* locals>> [ unquote suffix ] each ; + M: quotation defs-vars* [ defs-vars* ] each ; M: object defs-vars* drop ; diff --git a/core/locals/rewrite/point-free/point-free.factor b/core/locals/rewrite/point-free/point-free.factor index f9e026d262..090bc817b4 100644 --- a/core/locals/rewrite/point-free/point-free.factor +++ b/core/locals/rewrite/point-free/point-free.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: accessors arrays combinators kernel locals.backend -locals.errors locals.types make math quotations sequences words ; +USING: accessors arrays combinators fry.private kernel +locals.backend locals.errors locals.types make math quotations +sequences words ; IN: locals.rewrite.point-free ! Step 3: rewrite locals usage within a single quotation into @@ -32,44 +33,16 @@ M: def localize [ local-reader? [ 1array load-local ] [ load-local ] ? ] bi ; -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-empty ; - -: load-locals-index ( quot -- n ) - [ [ dup def? [ local>> local-reader? ] [ drop t ] if ] find drop ] - [ length ] bi or ; +M: multi-def localize + locals>> + [ prepend ] + [ [ [ local-reader? ] dip '[ [ 1array ] _ [ndip] ] [ [ ] ] if ] map-index concat ] + [ length [ load-locals ] curry ] tri append ; -: point-free-start ( quot -- args rest ) - dup load-locals-index - cut [ [ local>> ] map dup load-locals-quot % ] dip ; - -: point-free-body ( args quot -- args ) - [ localize % ] each ; +M: object localize 1quotation ; : drop-locals-quot ( args -- ) [ length , [ drop-locals ] % ] unless-empty ; -: point-free-end ( args obj -- ) - dup special? - [ localize % drop-locals-quot ] - [ [ drop-locals-quot ] [ , ] bi* ] - if ; - : point-free ( quot -- newquot ) - [ - point-free-start - [ drop-locals-quot ] [ - unclip-last - [ point-free-body ] - [ point-free-end ] - bi* - ] if-empty - ] [ ] make ; + [ { } swap [ localize % ] each drop-locals-quot ] [ ] make ; diff --git a/core/locals/rewrite/sugar/sugar.factor b/core/locals/rewrite/sugar/sugar.factor index 6689f959e7..5ce22c567f 100644 --- a/core/locals/rewrite/sugar/sugar.factor +++ b/core/locals/rewrite/sugar/sugar.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: accessors arrays assocs classes classes.tuple fry sequences.generalizations hashtables kernel locals locals.backend -locals.errors locals.types make quotations sequences vectors +locals.errors locals.types make math quotations sequences vectors words ; IN: locals.rewrite.sugar @@ -19,11 +19,15 @@ GENERIC: quotation-rewrite ( form -- form' ) M: callable quotation-rewrite [ [ rewrite-sugar* ] each ] [ ] make ; -: var-defs ( vars -- defs ) [ ] [ ] map-as ; +: var-defs ( vars -- defs ) + dup length 1 > [ + 1quotation + ] [ + [ ] [ ] map-as + ] if ; M: lambda quotation-rewrite - [ body>> ] [ vars>> var-defs ] bi - prepend quotation-rewrite ; + [ body>> ] [ vars>> var-defs ] bi prepend quotation-rewrite ; M: callable rewrite-sugar* quotation-rewrite , ; @@ -85,8 +89,7 @@ M: local-writer rewrite-element M: word rewrite-element , ; : rewrite-wrapper ( wrapper -- ) - dup rewrite-literal? - [ wrapped>> rewrite-element ] [ , ] if ; + dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; M: wrapper rewrite-element rewrite-wrapper \ , ; @@ -101,7 +104,7 @@ M: tuple rewrite-sugar* rewrite-element ; M: def rewrite-sugar* , ; -M: multi-def rewrite-sugar* locals>> [ , ] each ; +M: multi-def rewrite-sugar* , ; M: hashtable rewrite-sugar* rewrite-element ; diff --git a/core/locals/types/types.factor b/core/locals/types/types.factor index 1c2c27a067..0d9ba36962 100644 --- a/core/locals/types/types.factor +++ b/core/locals/types/types.factor @@ -30,7 +30,7 @@ PREDICATE: local < word "local?" word-prop ; : ( name -- word ) ! Create a local variable identifier - f + dup t "local?" set-word-prop ; M: local literalize ; @@ -38,7 +38,7 @@ M: local literalize ; PREDICATE: local-reader < word "local-reader?" word-prop ; : ( name -- word ) - f + dup t "local-reader?" set-word-prop ; M: local-reader literalize ; @@ -46,7 +46,7 @@ M: local-reader literalize ; PREDICATE: local-writer < word "local-writer?" word-prop ; : ( reader -- word ) - dup name>> "!" append f { + dup name>> "!" append { [ nip t "local-writer?" set-word-prop ] [ swap "local-reader" set-word-prop ] [ "local-writer" set-word-prop ] -- 2.34.1