--- /dev/null
+! 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. ;
--- /dev/null
+! 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." ;
+
--- /dev/null
+! 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 , ;
! 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
: MEMO:: (::) define-memoized ; parsing
-<PRIVATE
-
-! 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 ;
+{
+ "locals.macros"
+ "locals.fry"
+} [ require ] each
-M: binding-form deep-fry
- clone [ fry '[ @ call ] ] change-body , ;
+"prettyprint" vocab [
+ "locals.definitions" require
+ "locals.prettyprint" require
+] when
--- /dev/null
+! 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 ;
+
--- /dev/null
+! 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 ;
--- /dev/null
+! 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> ;
--- /dev/null
+! 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* , ;
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
--- /dev/null
+! 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 ;
projects / factor.git / commitdiff