Fix locals conflict

db4
Slava Pestov 2008-12-08 15:28:27 -06:00
commit f6d45158bb
11 changed files with 593 additions and 496 deletions

View File

@ -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
<effect> ;
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. ;

View File

@ -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." ;

View File

@ -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 , ;

View File

@ -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 macros arrays macros splitting combinators
prettyprint.backend prettyprint.custom 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 vocabs.loader words kernel ;
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." ;
<PRIVATE
TUPLE: lambda vars body ;
C: <lambda> lambda
TUPLE: binding-form bindings body ;
TUPLE: let < binding-form ;
C: <let> let
TUPLE: let* < binding-form ;
C: <let*> let*
TUPLE: wlet < binding-form ;
C: <wlet> 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 ;
: <local> ( name -- word )
#! Create a local variable identifier
f <word>
dup t "local?" set-word-prop ;
PREDICATE: local-word < word "local-word?" word-prop ;
: <local-word> ( name -- word )
f <word> dup t "local-word?" set-word-prop ;
PREDICATE: local-reader < word "local-reader?" word-prop ;
: <local-reader> ( name -- word )
f <word>
dup t "local-reader?" set-word-prop ;
PREDICATE: local-writer < word "local-writer?" word-prop ;
: <local-writer> ( reader -- word )
dup name>> "!" append f <word> {
[ 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> 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 <lambda> , ;
M: block lambda-rewrite*
#! Turn free variables into bound variables, curry them
#! onto the body
dup free-vars [ <quote> ] map dup % [
over block-vars prepend
swap block-body [ [ lambda-rewrite* ] each ] [ ] make
swap point-free ,
] keep length \ curry <repetition> % ;
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 [
<local-reader>
dup <local-writer> dup name>> set
] [ <local> ] if
dup dup name>> set ;
: make-locals ( seq -- words assoc )
[ [ make-local ] map ] H{ } make-assoc ;
: make-local-word ( name def -- word )
[ <local-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) <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 -- )
<reversed> [
[ 1array ] dip spin <lambda> '[ @ @ ]
] 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) <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 <local> <def> parsed ; parsing
: [| parse-lambda parsed-lambda ; parsing
@ -415,110 +28,12 @@ PRIVATE>
: MEMO:: (::) define-memoized ; parsing
<PRIVATE
{
"locals.macros"
"locals.fry"
} [ require ] each
! Pretty-printing locals
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*
<flow
\ [| pprint-word
dup vars>> pprint-vars
\ | pprint-word
f <inset body>> pprint-elements block>
\ ] pprint-word
block> ;
: pprint-let ( let word -- )
pprint-word
[ body>> ] [ bindings>> ] bi
\ | pprint-word
t <inset
<block
[ <block [ pprint-var ] dip pprint* block> ] assoc-each
block>
\ | pprint-word
<block pprint-elements block>
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
<effect> ;
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 , ;
"prettyprint" vocab [
"locals.definitions" require
"locals.prettyprint" require
] when

View File

@ -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 ;

View File

@ -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 [
<local-reader>
dup <local-writer> dup name>> set
] [ <local> ] if
dup dup name>> set ;
: make-locals ( seq -- words assoc )
[ [ make-local ] map ] H{ } make-assoc ;
: make-local-word ( name def -- word )
[ <local-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) <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) <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 ;

View File

@ -0,0 +1,48 @@
! 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 prettyprint.custom
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*
<flow
\ [| pprint-word
dup vars>> pprint-vars
\ | pprint-word
f <inset body>> pprint-elements block>
\ ] pprint-word
block> ;
: pprint-let ( let word -- )
pprint-word
[ body>> ] [ bindings>> ] bi
\ | pprint-word
t <inset
<block
[ <block [ pprint-var ] dip pprint* block> ] assoc-each
block>
\ | pprint-word
<block pprint-elements block>
block>
\ ] pprint-word ;
M: let pprint* \ [let pprint-let ;
M: wlet pprint* \ [wlet pprint-let ;
M: let* pprint* \ [let* pprint-let ;
M: def pprint*
<block \ :> pprint-word local>> pprint-word block> ;

View File

@ -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 [ <quote> ] map
[ % ]
[ var-defs prepend (rewrite-closures) point-free , ]
[ length \ curry <repetition> % ]
tri ;
M: object rewrite-closures* , ;

View File

@ -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 <reversed> 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 ;

View File

@ -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 ) <reversed> [ <def> ] [ ] 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 % <def> , ] 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 ;

View File

@ -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> lambda
TUPLE: binding-form bindings body ;
TUPLE: let < binding-form ;
C: <let> let
TUPLE: let* < binding-form ;
C: <let*> let*
TUPLE: wlet < binding-form ;
C: <wlet> wlet
TUPLE: quote local ;
C: <quote> quote
: unquote ( quote -- local ) dup quote? [ local>> ] when ; inline
TUPLE: def local ;
C: <def> def
PREDICATE: local < word "local?" word-prop ;
: <local> ( name -- word )
#! Create a local variable identifier
f <word>
dup t "local?" set-word-prop ;
PREDICATE: local-word < word "local-word?" word-prop ;
: <local-word> ( name -- word )
f <word> dup t "local-word?" set-word-prop ;
PREDICATE: local-reader < word "local-reader?" word-prop ;
: <local-reader> ( name -- word )
f <word>
dup t "local-reader?" set-word-prop ;
PREDICATE: local-writer < word "local-writer?" word-prop ;
: <local-writer> ( reader -- word )
dup name>> "!" append f <word> {
[ 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 ;