From 7771a3e5112d2dfe701e9d616d1180bafc578a08 Mon Sep 17 00:00:00 2001 From: Slava Pestov Date: Sat, 6 Dec 2008 04:57:38 -0600 Subject: [PATCH] :> word work in progress, split up llocals --- basis/locals/definitions/definitions.factor | 57 ++ basis/locals/errors/errors.factor | 31 ++ basis/locals/fry/fry.factor | 18 + basis/locals/locals.factor | 506 +----------------- basis/locals/macros/macros.factor | 16 + basis/locals/parser/parser.factor | 96 ++++ basis/locals/prettyprint/prettyprint.factor | 47 ++ basis/locals/rewrite/closures/closures.factor | 55 ++ .../rewrite/point-free/point-free.factor | 76 +++ basis/locals/rewrite/sugar/sugar.factor | 122 +++++ basis/locals/types/types.factor | 63 +++ 11 files changed, 590 insertions(+), 497 deletions(-) create mode 100644 basis/locals/definitions/definitions.factor create mode 100644 basis/locals/errors/errors.factor create mode 100644 basis/locals/fry/fry.factor create mode 100644 basis/locals/macros/macros.factor create mode 100644 basis/locals/parser/parser.factor create mode 100644 basis/locals/prettyprint/prettyprint.factor create mode 100644 basis/locals/rewrite/closures/closures.factor create mode 100644 basis/locals/rewrite/point-free/point-free.factor create mode 100644 basis/locals/rewrite/sugar/sugar.factor create mode 100644 basis/locals/types/types.factor diff --git a/basis/locals/definitions/definitions.factor b/basis/locals/definitions/definitions.factor new file mode 100644 index 0000000000..99f9d0bd22 --- /dev/null +++ b/basis/locals/definitions/definitions.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors definitions effects generic kernel locals +macros memoize prettyprint prettyprint.backend words ; +IN: locals.definitions + +PREDICATE: lambda-word < word "lambda" word-prop >boolean ; + +M: lambda-word definer drop \ :: \ ; ; + +M: lambda-word definition + "lambda" word-prop body>> ; + +M: lambda-word reset-word + [ call-next-method ] [ f "lambda" set-word-prop ] bi ; + +INTERSECTION: lambda-macro macro lambda-word ; + +M: lambda-macro definer drop \ MACRO:: \ ; ; + +M: lambda-macro definition + "lambda" word-prop body>> ; + +M: lambda-macro reset-word + [ call-next-method ] [ f "lambda" set-word-prop ] bi ; + +INTERSECTION: lambda-method method-body lambda-word ; + +M: lambda-method definer drop \ M:: \ ; ; + +M: lambda-method definition + "lambda" word-prop body>> ; + +M: lambda-method reset-word + [ call-next-method ] [ f "lambda" set-word-prop ] bi ; + +INTERSECTION: lambda-memoized memoized lambda-word ; + +M: lambda-memoized definer drop \ MEMO:: \ ; ; + +M: lambda-memoized definition + "lambda" word-prop body>> ; + +M: lambda-memoized reset-word + [ call-next-method ] [ f "lambda" set-word-prop ] bi ; + +: method-stack-effect ( method -- effect ) + dup "lambda" word-prop vars>> + swap "method-generic" word-prop stack-effect + dup [ out>> ] when + ; + +M: lambda-method synopsis* + dup dup dup definer. + "method-class" word-prop pprint-word + "method-generic" word-prop pprint-word + method-stack-effect effect>string comment. ; diff --git a/basis/locals/errors/errors.factor b/basis/locals/errors/errors.factor new file mode 100644 index 0000000000..9f9c2beecc --- /dev/null +++ b/basis/locals/errors/errors.factor @@ -0,0 +1,31 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel summary ; +IN: locals.errors + +ERROR: >r/r>-in-lambda-error ; + +M: >r/r>-in-lambda-error summary + drop + "Explicit retain stack manipulation is not permitted in lambda bodies" ; + +ERROR: binding-form-in-literal-error ; + +M: binding-form-in-literal-error summary + drop "[let, [let* and [wlet not permitted inside literals" ; + +ERROR: local-writer-in-literal-error ; + +M: local-writer-in-literal-error summary + drop "Local writer words not permitted inside literals" ; + +ERROR: local-word-in-literal-error ; + +M: local-word-in-literal-error summary + drop "Local words not permitted inside literals" ; + +ERROR: bad-lambda-rewrite output ; + +M: bad-lambda-rewrite summary + drop "You have found a bug in locals. Please report." ; + diff --git a/basis/locals/fry/fry.factor b/basis/locals/fry/fry.factor new file mode 100644 index 0000000000..9dc924334c --- /dev/null +++ b/basis/locals/fry/fry.factor @@ -0,0 +1,18 @@ +! 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 make sequences ; +IN: locals.fry + +! Support for mixing locals with fry + +M: binding-form count-inputs body>> count-inputs ; + +M: lambda count-inputs body>> count-inputs ; + +M: lambda deep-fry + clone [ shallow-fry swap ] change-body + [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ; + +M: binding-form deep-fry + clone [ fry '[ @ call ] ] change-body , ; diff --git a/basis/locals/locals.factor b/basis/locals/locals.factor index b78b95bc24..494c72bc03 100644 --- a/basis/locals/locals.factor +++ b/basis/locals/locals.factor @@ -1,397 +1,10 @@ ! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. ! See http://factorcode.org/license.txt for BSD license. -USING: kernel namespaces make sequences sequences.private assocs -math vectors strings classes.tuple generalizations parser words -quotations debugger macros arrays macros splitting combinators -prettyprint.backend definitions prettyprint hashtables -prettyprint.sections sets sequences.private effects -effects.parser generic generic.parser compiler.units accessors -locals.backend memoize macros.expander lexer classes summary fry -fry.private ; +USING: lexer locals.parser locals.types macros memoize parser +sequences vocabs.loader words ; IN: locals -ERROR: >r/r>-in-lambda-error ; - -M: >r/r>-in-lambda-error summary - drop - "Explicit retain stack manipulation is not permitted in lambda bodies" ; - -ERROR: binding-form-in-literal-error ; - -M: binding-form-in-literal-error summary - drop "[let, [let* and [wlet not permitted inside literals" ; - -ERROR: local-writer-in-literal-error ; - -M: local-writer-in-literal-error summary - drop "Local writer words not permitted inside literals" ; - -ERROR: local-word-in-literal-error ; - -M: local-word-in-literal-error summary - drop "Local words not permitted inside literals" ; - -ERROR: bad-lambda-rewrite output ; - -M: bad-lambda-rewrite summary - drop "You have found a bug in locals. Please report." ; - - lambda - -TUPLE: binding-form bindings body ; - -TUPLE: let < binding-form ; - -C: let - -TUPLE: let* < binding-form ; - -C: let* - -TUPLE: wlet < binding-form ; - -C: wlet - -M: lambda expand-macros clone [ expand-macros ] change-body ; - -M: lambda expand-macros* expand-macros literal ; - -M: binding-form expand-macros - clone - [ [ expand-macros ] assoc-map ] change-bindings - [ expand-macros ] change-body ; - -M: binding-form expand-macros* expand-macros literal ; - -PREDICATE: local < word "local?" word-prop ; - -: ( name -- word ) - #! Create a local variable identifier - f - dup t "local?" set-word-prop ; - -PREDICATE: local-word < word "local-word?" word-prop ; - -: ( name -- word ) - f dup t "local-word?" set-word-prop ; - -PREDICATE: local-reader < word "local-reader?" word-prop ; - -: ( name -- word ) - f - dup t "local-reader?" set-word-prop ; - -PREDICATE: local-writer < word "local-writer?" word-prop ; - -: ( reader -- word ) - dup name>> "!" append f { - [ nip t "local-writer?" set-word-prop ] - [ swap "local-reader" set-word-prop ] - [ "local-writer" set-word-prop ] - [ nip ] - } 2cleave ; - -TUPLE: quote local ; - -C: quote - -: local-index ( obj args -- n ) - [ dup quote? [ local>> ] when eq? ] with find drop ; - -: read-local-quot ( obj args -- quot ) - local-index neg [ get-local ] curry ; - -GENERIC# localize 1 ( obj args -- quot ) - -M: local localize read-local-quot ; - -M: quote localize [ local>> ] dip read-local-quot ; - -M: local-word localize read-local-quot [ call ] append ; - -M: local-reader localize read-local-quot [ local-value ] append ; - -M: local-writer localize - [ "local-reader" word-prop ] dip - read-local-quot [ set-local-value ] append ; - -M: object localize drop 1quotation ; - -UNION: special local quote local-word local-reader local-writer ; - -: load-locals-quot ( args -- quot ) - [ [ ] ] [ - dup [ local-reader? ] contains? [ - dup [ local-reader? [ 1array ] [ ] ? ] map spread>quot - ] [ [ ] ] if swap length [ load-locals ] curry append - ] if-empty ; - -: drop-locals-quot ( args -- quot ) - [ [ ] ] [ length [ drop-locals ] curry ] if-empty ; - -: point-free-body ( quot args -- newquot ) - [ but-last-slice ] dip '[ _ localize ] map concat ; - -: point-free-end ( quot args -- newquot ) - over peek special? - [ dup drop-locals-quot [ [ peek ] dip localize ] dip append ] - [ drop-locals-quot swap peek suffix ] - if ; - -: (point-free) ( quot args -- newquot ) - [ nip load-locals-quot ] - [ reverse point-free-body ] - [ reverse point-free-end ] - 2tri [ ] 3append-as ; - -: point-free ( quot args -- newquot ) - over empty? [ nip length '[ _ ndrop ] ] [ (point-free) ] if ; - -UNION: lexical local local-reader local-writer local-word ; - -GENERIC: free-vars* ( form -- ) - -: free-vars ( form -- vars ) - [ free-vars* ] { } make prune ; - -M: local-writer free-vars* "local-reader" word-prop , ; - -M: lexical free-vars* , ; - -M: quote free-vars* , ; - -M: object free-vars* drop ; - -M: quotation free-vars* [ free-vars* ] each ; - -M: lambda free-vars* [ vars>> ] [ body>> ] bi free-vars swap diff % ; - -GENERIC: lambda-rewrite* ( obj -- ) - -GENERIC: local-rewrite* ( obj -- ) - -: lambda-rewrite ( form -- form' ) - expand-macros - [ local-rewrite* ] [ ] make - [ [ lambda-rewrite* ] each ] [ ] make ; - -UNION: block callable lambda ; - -GENERIC: block-vars ( block -- seq ) - -GENERIC: block-body ( block -- quot ) - -M: callable block-vars drop { } ; - -M: callable block-body ; - -M: callable local-rewrite* - [ [ local-rewrite* ] each ] [ ] make , ; - -M: lambda block-vars vars>> ; - -M: lambda block-body body>> ; - -M: lambda local-rewrite* - [ vars>> ] [ body>> ] bi - [ [ local-rewrite* ] each ] [ ] make , ; - -M: block lambda-rewrite* - #! Turn free variables into bound variables, curry them - #! onto the body - dup free-vars [ ] map dup % [ - over block-vars prepend - swap block-body [ [ lambda-rewrite* ] each ] [ ] make - swap point-free , - ] keep length \ curry % ; - -GENERIC: rewrite-literal? ( obj -- ? ) - -M: special rewrite-literal? drop t ; - -M: array rewrite-literal? [ rewrite-literal? ] contains? ; - -M: quotation rewrite-literal? [ rewrite-literal? ] contains? ; - -M: wrapper rewrite-literal? drop t ; - -M: hashtable rewrite-literal? drop t ; - -M: vector rewrite-literal? drop t ; - -M: tuple rewrite-literal? drop t ; - -M: object rewrite-literal? drop f ; - -GENERIC: rewrite-element ( obj -- ) - -: rewrite-elements ( seq -- ) - [ rewrite-element ] each ; - -: rewrite-sequence ( seq -- ) - [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ; - -M: array rewrite-element - dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; - -M: vector rewrite-element rewrite-sequence ; - -M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; - -M: tuple rewrite-element - [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ; - -M: quotation rewrite-element local-rewrite* ; - -M: lambda rewrite-element local-rewrite* ; - -M: binding-form rewrite-element binding-form-in-literal-error ; - -M: local rewrite-element , ; - -M: local-reader rewrite-element , ; - -M: local-writer rewrite-element - local-writer-in-literal-error ; - -M: local-word rewrite-element - local-word-in-literal-error ; - -M: word rewrite-element literalize , ; - -M: wrapper rewrite-element - dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; - -M: object rewrite-element , ; - -M: array local-rewrite* rewrite-element ; - -M: vector local-rewrite* rewrite-element ; - -M: tuple local-rewrite* rewrite-element ; - -M: hashtable local-rewrite* rewrite-element ; - -M: wrapper local-rewrite* rewrite-element ; - -M: word local-rewrite* - dup { >r r> load-locals get-local drop-locals } memq? - [ >r/r>-in-lambda-error ] [ call-next-method ] if ; - -M: object lambda-rewrite* , ; - -M: object local-rewrite* , ; - -: make-local ( name -- word ) - "!" ?tail [ - - dup dup name>> set - ] [ ] if - dup dup name>> set ; - -: make-locals ( seq -- words assoc ) - [ [ make-local ] map ] H{ } make-assoc ; - -: make-local-word ( name def -- word ) - [ [ dup name>> set ] [ ] [ ] tri ] dip - "local-word-def" set-word-prop ; - -: push-locals ( assoc -- ) - use get push ; - -: pop-locals ( assoc -- ) - use get delete ; - -SYMBOL: in-lambda? - -: (parse-lambda) ( assoc end -- quot ) - t in-lambda? [ parse-until ] with-variable - >quotation swap pop-locals ; - -: parse-lambda ( -- lambda ) - "|" parse-tokens make-locals dup push-locals - \ ] (parse-lambda) ; - -: parse-binding ( end -- pair/f ) - scan { - { [ dup not ] [ unexpected-eof ] } - { [ 2dup = ] [ 2drop f ] } - [ nip scan-object 2array ] - } cond ; - -: (parse-bindings) ( end -- ) - dup parse-binding dup [ - first2 [ make-local ] dip 2array , - (parse-bindings) - ] [ 2drop ] if ; - -: parse-bindings ( end -- bindings vars ) - [ - [ (parse-bindings) ] H{ } make-assoc - dup push-locals - ] { } make swap ; - -: parse-bindings* ( end -- words assoc ) - [ - [ - namespace push-locals - - (parse-bindings) - ] { } make-assoc - ] { } make swap ; - -: (parse-wbindings) ( end -- ) - dup parse-binding dup [ - first2 [ make-local-word ] keep 2array , - (parse-wbindings) - ] [ 2drop ] if ; - -: parse-wbindings ( end -- bindings vars ) - [ - [ (parse-wbindings) ] H{ } make-assoc - dup push-locals - ] { } make swap ; - -: let-rewrite ( body bindings -- ) - [ - [ 1array ] dip spin '[ @ @ ] - ] assoc-each local-rewrite* \ call , ; - -M: let local-rewrite* - [ body>> ] [ bindings>> ] bi let-rewrite ; - -M: let* local-rewrite* - [ body>> ] [ bindings>> ] bi let-rewrite ; - -M: wlet local-rewrite* - [ body>> ] [ bindings>> ] bi - [ '[ _ ] ] assoc-map - let-rewrite ; - -: parse-locals ( -- vars assoc ) - "(" expect ")" parse-effect - word [ over "declared-effect" set-word-prop ] when* - in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ; - -: parse-locals-definition ( word -- word quot ) - parse-locals \ ; (parse-lambda) - 2dup "lambda" set-word-prop - lambda-rewrite dup length 1 = [ first ] [ bad-lambda-rewrite ] if ; - -: (::) ( -- word def ) CREATE-WORD parse-locals-definition ; - -: (M::) ( -- word def ) - CREATE-METHOD - [ parse-locals-definition ] with-method-definition ; - -: parsed-lambda ( accum form -- accum ) - in-lambda? get [ parsed ] [ lambda-rewrite over push-all ] if ; - -PRIVATE> +: :> scan parsed ; parsing : [| parse-lambda parsed-lambda ; parsing @@ -415,110 +28,9 @@ PRIVATE> : MEMO:: (::) define-memoized ; parsing -> pprint-vars - \ | pprint-word - f > pprint-elements block> - \ ] pprint-word - block> ; - -: pprint-let ( let word -- ) - pprint-word - [ body>> ] [ bindings>> ] bi - \ | pprint-word - t ] assoc-each - block> - \ | pprint-word - - block> - \ ] pprint-word ; - -M: let pprint* \ [let pprint-let ; - -M: wlet pprint* \ [wlet pprint-let ; - -M: let* pprint* \ [let* pprint-let ; - -PREDICATE: lambda-word < word "lambda" word-prop >boolean ; - -M: lambda-word definer drop \ :: \ ; ; - -M: lambda-word definition - "lambda" word-prop body>> ; - -M: lambda-word reset-word - [ call-next-method ] [ f "lambda" set-word-prop ] bi ; - -INTERSECTION: lambda-macro macro lambda-word ; - -M: lambda-macro definer drop \ MACRO:: \ ; ; - -M: lambda-macro definition - "lambda" word-prop body>> ; - -M: lambda-macro reset-word - [ call-next-method ] [ f "lambda" set-word-prop ] bi ; - -INTERSECTION: lambda-method method-body lambda-word ; - -M: lambda-method definer drop \ M:: \ ; ; - -M: lambda-method definition - "lambda" word-prop body>> ; - -M: lambda-method reset-word - [ call-next-method ] [ f "lambda" set-word-prop ] bi ; - -INTERSECTION: lambda-memoized memoized lambda-word ; - -M: lambda-memoized definer drop \ MEMO:: \ ; ; - -M: lambda-memoized definition - "lambda" word-prop body>> ; - -M: lambda-memoized reset-word - [ call-next-method ] [ f "lambda" set-word-prop ] bi ; - -: method-stack-effect ( method -- effect ) - dup "lambda" word-prop vars>> - swap "method-generic" word-prop stack-effect - dup [ out>> ] when - ; - -M: lambda-method synopsis* - dup dup dup definer. - "method-class" word-prop pprint-word - "method-generic" word-prop pprint-word - method-stack-effect effect>string comment. ; - -PRIVATE> - -! Locals and fry -M: binding-form count-inputs body>> count-inputs ; - -M: lambda count-inputs body>> count-inputs ; - -M: lambda deep-fry - clone [ shallow-fry swap ] change-body - [ [ vars>> length ] keep '[ _ _ mnswap @ ] , ] [ drop [ncurry] % ] 2bi ; - -M: binding-form deep-fry - clone [ fry '[ @ call ] ] change-body , ; +{ + "locals.prettyprint" + "locals.definitions" + "locals.macros" + "locals.fry" +} [ require ] each diff --git a/basis/locals/macros/macros.factor b/basis/locals/macros/macros.factor new file mode 100644 index 0000000000..7bde67a792 --- /dev/null +++ b/basis/locals/macros/macros.factor @@ -0,0 +1,16 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel locals.types macros.expander ; +IN: locals.macros + +M: lambda expand-macros clone [ expand-macros ] change-body ; + +M: lambda expand-macros* expand-macros literal ; + +M: binding-form expand-macros + clone + [ [ expand-macros ] assoc-map ] change-bindings + [ expand-macros ] change-body ; + +M: binding-form expand-macros* expand-macros literal ; + diff --git a/basis/locals/parser/parser.factor b/basis/locals/parser/parser.factor new file mode 100644 index 0000000000..5b2e7c3eeb --- /dev/null +++ b/basis/locals/parser/parser.factor @@ -0,0 +1,96 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays combinators effects.parser +generic.parser kernel lexer locals.errors +locals.rewrite.closures locals.types make namespaces parser +quotations sequences splitting words ; +IN: locals.parser + +: make-local ( name -- word ) + "!" ?tail [ + + dup dup name>> set + ] [ ] if + dup dup name>> set ; + +: make-locals ( seq -- words assoc ) + [ [ make-local ] map ] H{ } make-assoc ; + +: make-local-word ( name def -- word ) + [ [ dup name>> set ] [ ] [ ] tri ] dip + "local-word-def" set-word-prop ; + +: push-locals ( assoc -- ) + use get push ; + +: pop-locals ( assoc -- ) + use get delete ; + +SYMBOL: in-lambda? + +: (parse-lambda) ( assoc end -- quot ) + t in-lambda? [ parse-until ] with-variable + >quotation swap pop-locals ; + +: parse-lambda ( -- lambda ) + "|" parse-tokens make-locals dup push-locals + \ ] (parse-lambda) ; + +: parse-binding ( end -- pair/f ) + scan { + { [ dup not ] [ unexpected-eof ] } + { [ 2dup = ] [ 2drop f ] } + [ nip scan-object 2array ] + } cond ; + +: (parse-bindings) ( end -- ) + dup parse-binding dup [ + first2 [ make-local ] dip 2array , + (parse-bindings) + ] [ 2drop ] if ; + +: parse-bindings ( end -- bindings vars ) + [ + [ (parse-bindings) ] H{ } make-assoc + dup push-locals + ] { } make swap ; + +: parse-bindings* ( end -- words assoc ) + [ + [ + namespace push-locals + + (parse-bindings) + ] { } make-assoc + ] { } make swap ; + +: (parse-wbindings) ( end -- ) + dup parse-binding dup [ + first2 [ make-local-word ] keep 2array , + (parse-wbindings) + ] [ 2drop ] if ; + +: parse-wbindings ( end -- bindings vars ) + [ + [ (parse-wbindings) ] H{ } make-assoc + dup push-locals + ] { } make swap ; + +: parse-locals ( -- vars assoc ) + "(" expect ")" parse-effect + word [ over "declared-effect" set-word-prop ] when* + in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ; + +: parse-locals-definition ( word -- word quot ) + parse-locals \ ; (parse-lambda) + 2dup "lambda" set-word-prop + rewrite-closures dup length 1 = [ first ] [ bad-lambda-rewrite ] if ; + +: (::) ( -- word def ) CREATE-WORD parse-locals-definition ; + +: (M::) ( -- word def ) + CREATE-METHOD + [ parse-locals-definition ] with-method-definition ; + +: parsed-lambda ( accum form -- accum ) + in-lambda? get [ parsed ] [ rewrite-closures over push-all ] if ; diff --git a/basis/locals/prettyprint/prettyprint.factor b/basis/locals/prettyprint/prettyprint.factor new file mode 100644 index 0000000000..255917a0a5 --- /dev/null +++ b/basis/locals/prettyprint/prettyprint.factor @@ -0,0 +1,47 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors assocs kernel locals locals.types +prettyprint.backend prettyprint.sections sequences words ; +IN: locals.prettyprint + +SYMBOL: | + +: pprint-var ( var -- ) + #! Prettyprint a read/write local as its writer, just like + #! in the input syntax: [| x! | ... x 3 + x! ] + dup local-reader? [ + "local-writer" word-prop + ] when pprint-word ; + +: pprint-vars ( vars -- ) [ pprint-var ] each ; + +M: lambda pprint* + > pprint-vars + \ | pprint-word + f > pprint-elements block> + \ ] pprint-word + block> ; + +: pprint-let ( let word -- ) + pprint-word + [ body>> ] [ bindings>> ] bi + \ | pprint-word + t ] assoc-each + block> + \ | pprint-word + + block> + \ ] pprint-word ; + +M: let pprint* \ [let pprint-let ; + +M: wlet pprint* \ [wlet pprint-let ; + +M: let* pprint* \ [let* pprint-let ; + +M: def pprint* + pprint-word local>> pprint-word block> ; diff --git a/basis/locals/rewrite/closures/closures.factor b/basis/locals/rewrite/closures/closures.factor new file mode 100644 index 0000000000..d85155daad --- /dev/null +++ b/basis/locals/rewrite/closures/closures.factor @@ -0,0 +1,55 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors kernel locals.rewrite.point-free +locals.rewrite.sugar locals.types macros.expander make +quotations sequences sets words ; +IN: locals.rewrite.closures + +! Step 2: identify free variables and make them into explicit +! parameters of lambdas which are curried on + +GENERIC: rewrite-closures* ( obj -- ) + +: (rewrite-closures) ( form -- form' ) + [ [ rewrite-closures* ] each ] [ ] make ; + +: rewrite-closures ( form -- form' ) + expand-macros (rewrite-sugar) (rewrite-closures) point-free ; + +GENERIC: defs-vars* ( seq form -- seq' ) + +: defs-vars ( form -- vars ) { } [ defs-vars* ] reduce prune ; + +M: def defs-vars* local>> unquote suffix ; + +M: quotation defs-vars* [ defs-vars* ] each ; + +M: object defs-vars* drop ; + +GENERIC: uses-vars* ( seq form -- seq' ) + +: uses-vars ( form -- vars ) { } [ uses-vars* ] reduce prune ; + +M: local-writer uses-vars* "local-reader" word-prop suffix ; + +M: lexical uses-vars* suffix ; + +M: quote uses-vars* local>> uses-vars* ; + +M: object uses-vars* drop ; + +M: quotation uses-vars* [ uses-vars* ] each ; + +: free-vars ( form -- seq ) + [ uses-vars ] [ defs-vars ] bi diff ; + +M: callable rewrite-closures* + #! Turn free variables into bound variables, curry them + #! onto the body + dup free-vars [ ] map + [ % ] + [ var-defs prepend (rewrite-closures) point-free , ] + [ length \ curry % ] + tri ; + +M: object rewrite-closures* , ; diff --git a/basis/locals/rewrite/point-free/point-free.factor b/basis/locals/rewrite/point-free/point-free.factor new file mode 100644 index 0000000000..1741bf044f --- /dev/null +++ b/basis/locals/rewrite/point-free/point-free.factor @@ -0,0 +1,76 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays fry kernel locals.backend locals.types +math quotations sequences words combinators make ; +IN: locals.rewrite.point-free + +! Step 3: rewrite locals usage within a single quotation into +! retain stack manipulation + +ERROR: bad-local args obj ; + +: local-index ( args obj -- n ) + 2dup '[ unquote _ eq? ] find drop + dup [ 2nip ] [ drop bad-local ] if ; + +: read-local-quot ( args obj -- quot ) + local-index neg [ get-local ] curry ; + +GENERIC: localize ( args obj -- args quot ) + +M: local localize dupd read-local-quot ; + +M: quote localize dupd local>> read-local-quot ; + +M: local-word localize dupd read-local-quot [ call ] append ; + +M: local-reader localize dupd read-local-quot [ local-value ] append ; + +M: local-writer localize + dupd "local-reader" word-prop + read-local-quot [ set-local-value ] append ; + +M: def localize + local>> [ prefix ] [ local-reader? [ 1array >r ] [ >r ] ? ] bi ; + +M: object localize 1quotation ; + +! We special-case all the :> at the start of a quotation +: load-locals-quot ( args -- quot ) + [ [ ] ] [ + dup [ local-reader? ] contains? [ + dup [ local-reader? [ 1array ] [ ] ? ] map + 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 ; + +: 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 ; + +: 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 ; diff --git a/basis/locals/rewrite/sugar/sugar.factor b/basis/locals/rewrite/sugar/sugar.factor new file mode 100644 index 0000000000..05b1e2345e --- /dev/null +++ b/basis/locals/rewrite/sugar/sugar.factor @@ -0,0 +1,122 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors arrays assocs classes classes.tuple fry +generalizations hashtables kernel locals locals.backend +locals.errors locals.types make quotations sequences vectors +words ; +IN: locals.rewrite.sugar + +! Step 1: rewrite [| [let [let* [wlet into :> forms, turn +! literals with locals in them into code which constructs +! the literal after pushing locals on the stack + +GENERIC: rewrite-sugar* ( obj -- ) + +: (rewrite-sugar) ( form -- form' ) + [ rewrite-sugar* ] [ ] make ; + +GENERIC: quotation-rewrite ( form -- form' ) + +M: callable quotation-rewrite [ [ rewrite-sugar* ] each ] [ ] make ; + +: var-defs ( vars -- defs ) [ ] [ ] map-as ; + +M: lambda quotation-rewrite + [ body>> ] [ vars>> var-defs ] bi + prepend quotation-rewrite ; + +M: callable rewrite-sugar* quotation-rewrite , ; + +M: lambda rewrite-sugar* quotation-rewrite , ; + +GENERIC: rewrite-literal? ( obj -- ? ) + +M: special rewrite-literal? drop t ; + +M: array rewrite-literal? [ rewrite-literal? ] contains? ; + +M: quotation rewrite-literal? [ rewrite-literal? ] contains? ; + +M: wrapper rewrite-literal? drop t ; + +M: hashtable rewrite-literal? drop t ; + +M: vector rewrite-literal? drop t ; + +M: tuple rewrite-literal? drop t ; + +M: object rewrite-literal? drop f ; + +GENERIC: rewrite-element ( obj -- ) + +: rewrite-elements ( seq -- ) + [ rewrite-element ] each ; + +: rewrite-sequence ( seq -- ) + [ rewrite-elements ] [ length , ] [ 0 head , ] tri \ nsequence , ; + +M: array rewrite-element + dup rewrite-literal? [ rewrite-sequence ] [ , ] if ; + +M: vector rewrite-element rewrite-sequence ; + +M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ; + +M: tuple rewrite-element + [ tuple-slots rewrite-elements ] [ class literalize , ] bi \ boa , ; + +M: quotation rewrite-element rewrite-sugar* ; + +M: lambda rewrite-element rewrite-sugar* ; + +M: binding-form rewrite-element binding-form-in-literal-error ; + +M: local rewrite-element , ; + +M: local-reader rewrite-element , ; + +M: local-writer rewrite-element + local-writer-in-literal-error ; + +M: local-word rewrite-element + local-word-in-literal-error ; + +M: word rewrite-element literalize , ; + +M: wrapper rewrite-element + dup rewrite-literal? [ wrapped>> rewrite-element ] [ , ] if ; + +M: object rewrite-element , ; + +M: array rewrite-sugar* rewrite-element ; + +M: vector rewrite-sugar* rewrite-element ; + +M: tuple rewrite-sugar* rewrite-element ; + +M: def rewrite-sugar* , ; + +M: hashtable rewrite-sugar* rewrite-element ; + +M: wrapper rewrite-sugar* rewrite-element ; + +M: word rewrite-sugar* + dup { >r r> load-locals get-local drop-locals } memq? + [ >r/r>-in-lambda-error ] [ call-next-method ] if ; + +M: object rewrite-sugar* , ; + +: let-rewrite ( body bindings -- ) + [ quotation-rewrite % , ] assoc-each + quotation-rewrite % ; + +M: let rewrite-sugar* + [ body>> ] [ bindings>> ] bi let-rewrite ; + +M: let* rewrite-sugar* + [ body>> ] [ bindings>> ] bi let-rewrite ; + +M: wlet rewrite-sugar* + [ body>> ] [ bindings>> ] bi + [ '[ _ ] ] assoc-map + let-rewrite ; diff --git a/basis/locals/types/types.factor b/basis/locals/types/types.factor new file mode 100644 index 0000000000..7a8dac1947 --- /dev/null +++ b/basis/locals/types/types.factor @@ -0,0 +1,63 @@ +! Copyright (C) 2007, 2008 Slava Pestov, Eduardo Cavazos. +! See http://factorcode.org/license.txt for BSD license. +USING: accessors combinators kernel sequences words ; +IN: locals.types + +TUPLE: lambda vars body ; + +C: lambda + +TUPLE: binding-form bindings body ; + +TUPLE: let < binding-form ; + +C: let + +TUPLE: let* < binding-form ; + +C: let* + +TUPLE: wlet < binding-form ; + +C: wlet + +TUPLE: quote local ; + +C: quote + +: unquote ( quote -- local ) dup quote? [ local>> ] when ; inline + +TUPLE: def local ; + +C: def + +PREDICATE: local < word "local?" word-prop ; + +: ( name -- word ) + #! Create a local variable identifier + f + dup t "local?" set-word-prop ; + +PREDICATE: local-word < word "local-word?" word-prop ; + +: ( name -- word ) + f dup t "local-word?" set-word-prop ; + +PREDICATE: local-reader < word "local-reader?" word-prop ; + +: ( name -- word ) + f + dup t "local-reader?" set-word-prop ; + +PREDICATE: local-writer < word "local-writer?" word-prop ; + +: ( reader -- word ) + dup name>> "!" append f { + [ nip t "local-writer?" set-word-prop ] + [ swap "local-reader" set-word-prop ] + [ "local-writer" set-word-prop ] + [ nip ] + } 2cleave ; + +UNION: lexical local local-reader local-writer local-word ; +UNION: special lexical quote def ;