Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
d1df44637c
|
|
@ -406,9 +406,7 @@ big-endian on
|
|||
[
|
||||
3 ds-reg 0 LWZ
|
||||
3 3 1 SRAWI
|
||||
4 4 LI
|
||||
4 3 4 SUBF
|
||||
rs-reg 3 4 LWZX
|
||||
rs-reg 3 3 LWZX
|
||||
3 ds-reg 0 STW
|
||||
] f f f \ get-local define-sub-primitive
|
||||
|
||||
|
|
|
|||
|
|
@ -382,9 +382,7 @@ big-endian off
|
|||
[
|
||||
arg0 ds-reg [] MOV ! load local number
|
||||
fixnum>slot@ ! turn local number into offset
|
||||
arg1 bootstrap-cell MOV ! load base
|
||||
arg1 arg0 SUB ! turn it into a stack offset
|
||||
arg0 rs-reg arg1 [+] MOV ! load local value
|
||||
arg0 rs-reg arg0 [+] MOV ! load local value
|
||||
ds-reg [] arg0 MOV ! push to stack
|
||||
] f f f \ get-local define-sub-primitive
|
||||
|
||||
|
|
|
|||
|
|
@ -1,13 +1,11 @@
|
|||
USING: help help.syntax help.markup ;
|
||||
IN: editors.emacs
|
||||
|
||||
ARTICLE: { "emacs" "emacs" } "Integration with Emacs"
|
||||
|
||||
"Put this in your .emacs file:"
|
||||
|
||||
ARTICLE: "editors.emacs" "Integration with Emacs"
|
||||
"Put this in your " { $snippet ".emacs" } " file:"
|
||||
{ $code "(server-start)" }
|
||||
|
||||
"If you would like a new window to open when you ask Factor to edit an object, put this in your .emacs file:"
|
||||
|
||||
"If you would like a new window to open when you ask Factor to edit an object, put this in your " { $snippet ".emacs" } " file:"
|
||||
{ $code "(setq server-window 'switch-to-buffer-other-frame)" }
|
||||
|
||||
{ $see-also "editor" } ;
|
||||
|
||||
ABOUT: "editors.emacs"
|
||||
|
|
@ -75,12 +75,6 @@ ARTICLE: "fry.philosophy" "Fried quotation philosophy"
|
|||
"[let | a [ ] b [ ] | [ 3 a + 4 b / ] ]"
|
||||
} ;
|
||||
|
||||
ARTICLE: "fry.limitations" "Fried quotation limitations"
|
||||
"As with " { $vocab-link "locals" } ", fried quotations cannot contain " { $link >r } " and " { $link r> } ". This is not a real limitation in practice, since " { $link dip } " can be used instead."
|
||||
$nl
|
||||
"An error thrown if a fried quotation contains calls to " { $link >r } " and " { $link r> } ":"
|
||||
{ $subsection >r/r>-in-fry-error } ;
|
||||
|
||||
ARTICLE: "fry" "Fried quotations"
|
||||
"The " { $vocab-link "fry" } " vocabulary implements " { $emphasis "fried quotation" } ". Conceptually, fried quotations are quotations with ``holes'' (more formally, " { $emphasis "fry specifiers" } "), and the holes are filled in when the fried quotation is pushed on the stack."
|
||||
$nl
|
||||
|
|
@ -92,7 +86,6 @@ $nl
|
|||
"The holes are filled in with the top of stack going in the rightmost hole, the second item on the stack going in the second hole from the right, and so on."
|
||||
{ $subsection "fry.examples" }
|
||||
{ $subsection "fry.philosophy" }
|
||||
{ $subsection "fry.limitations" }
|
||||
"Fry is implemented as a parsing word which reads a quotation and scans for occurrences of " { $link _ } " and " { $link @ } "; these words are not actually executed, and doing so raises an error (this can happen if they're accidentally used outside of a fry)."
|
||||
$nl
|
||||
"Fried quotations can also be constructed without using a parsing word; this is useful when meta-programming:"
|
||||
|
|
|
|||
|
|
@ -28,11 +28,6 @@ M: >r/r>-in-fry-error summary
|
|||
dup { >r r> load-locals get-local drop-locals } intersect
|
||||
empty? [ >r/r>-in-fry-error ] unless ;
|
||||
|
||||
: shallow-fry ( quot -- quot' )
|
||||
check-fry
|
||||
[ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
|
||||
{ _ } split [ length 1- [ncurry] ] [ spread>quot ] bi prefix ;
|
||||
|
||||
PREDICATE: fry-specifier < word { _ @ } memq? ;
|
||||
|
||||
GENERIC: count-inputs ( quot -- n )
|
||||
|
|
@ -41,15 +36,21 @@ M: callable count-inputs [ count-inputs ] sigma ;
|
|||
M: fry-specifier count-inputs drop 1 ;
|
||||
M: object count-inputs drop 0 ;
|
||||
|
||||
GENERIC: deep-fry ( obj -- )
|
||||
|
||||
: shallow-fry ( quot -- quot' curry# )
|
||||
check-fry
|
||||
[ [ deep-fry ] each ] [ ] make
|
||||
[ dup \ @ = [ drop [ _ call ] ] [ 1array ] if ] map concat
|
||||
{ _ } split [ spread>quot ] [ length 1- ] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: fry ( quot -- quot' )
|
||||
[
|
||||
[
|
||||
dup callable? [
|
||||
[ count-inputs \ _ <repetition> % ] [ fry % ] bi
|
||||
] [ , ] if
|
||||
] each
|
||||
] [ ] make shallow-fry ;
|
||||
: fry ( quot -- quot' ) shallow-fry [ncurry] swap prefix ;
|
||||
|
||||
M: callable deep-fry
|
||||
[ count-inputs \ _ <repetition> % ] [ fry % ] bi ;
|
||||
|
||||
M: object deep-fry , ;
|
||||
|
||||
: '[ \ ] parse-until fry over push-all ; parsing
|
||||
|
|
|
|||
|
|
@ -17,6 +17,15 @@ HELP: narray
|
|||
{ $description "A generalization of " { $link 1array } ", "
|
||||
{ $link 2array } ", " { $link 3array } " and " { $link 4array } " "
|
||||
"that constructs an array from the top " { $snippet "n" } " elements of the stack."
|
||||
}
|
||||
{ $examples
|
||||
"Some core words expressed in terms of " { $link narray } ":"
|
||||
{ $table
|
||||
{ { $link 1array } { $snippet "1 narray" } }
|
||||
{ { $link 2array } { $snippet "2 narray" } }
|
||||
{ { $link 3array } { $snippet "3 narray" } }
|
||||
{ { $link 4array } { $snippet "4 narray" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
{ nsequence narray } related-words
|
||||
|
|
@ -26,6 +35,15 @@ HELP: firstn
|
|||
{ $description "A generalization of " { $link first } ", "
|
||||
{ $link first2 } ", " { $link first3 } " and " { $link first4 } " "
|
||||
"that pushes the first " { $snippet "n" } " elements of a sequence on the stack."
|
||||
}
|
||||
{ $examples
|
||||
"Some core words expressed in terms of " { $link firstn } ":"
|
||||
{ $table
|
||||
{ { $link first } { $snippet "1 firstn" } }
|
||||
{ { $link first2 } { $snippet "2 firstn" } }
|
||||
{ { $link first3 } { $snippet "3 firstn" } }
|
||||
{ { $link first4 } { $snippet "4 firstn" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: npick
|
||||
|
|
@ -37,8 +55,13 @@ HELP: npick
|
|||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 npick .s" "1\n2\n3\n4\n1" }
|
||||
}
|
||||
{ $see-also dup over pick } ;
|
||||
"Some core words expressed in terms of " { $link npick } ":"
|
||||
{ $table
|
||||
{ { $link dup } { $snippet "1 npick" } }
|
||||
{ { $link over } { $snippet "2 npick" } }
|
||||
{ { $link pick } { $snippet "3 npick" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: ndup
|
||||
{ $values { "n" integer } }
|
||||
|
|
@ -49,8 +72,13 @@ HELP: ndup
|
|||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 ndup .s" "1\n2\n3\n4\n1\n2\n3\n4" }
|
||||
}
|
||||
{ $see-also dup 2dup 3dup } ;
|
||||
"Some core words expressed in terms of " { $link ndup } ":"
|
||||
{ $table
|
||||
{ { $link dup } { $snippet "1 ndup" } }
|
||||
{ { $link 2dup } { $snippet "2 ndup" } }
|
||||
{ { $link 3dup } { $snippet "3 ndup" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: nnip
|
||||
{ $values { "n" integer } }
|
||||
|
|
@ -60,8 +88,12 @@ HELP: nnip
|
|||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 nnip .s" "4" }
|
||||
}
|
||||
{ $see-also nip 2nip } ;
|
||||
"Some core words expressed in terms of " { $link nnip } ":"
|
||||
{ $table
|
||||
{ { $link nip } { $snippet "1 nnip" } }
|
||||
{ { $link 2nip } { $snippet "2 nnip" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: ndrop
|
||||
{ $values { "n" integer } }
|
||||
|
|
@ -71,8 +103,13 @@ HELP: ndrop
|
|||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 3 ndrop .s" "1" }
|
||||
}
|
||||
{ $see-also drop 2drop 3drop } ;
|
||||
"Some core words expressed in terms of " { $link ndrop } ":"
|
||||
{ $table
|
||||
{ { $link drop } { $snippet "1 ndrop" } }
|
||||
{ { $link 2drop } { $snippet "2 ndrop" } }
|
||||
{ { $link 3drop } { $snippet "3 ndrop" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: nrot
|
||||
{ $values { "n" integer } }
|
||||
|
|
@ -81,8 +118,12 @@ HELP: nrot
|
|||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrot .s" "2\n3\n4\n1" }
|
||||
}
|
||||
{ $see-also rot -nrot } ;
|
||||
"Some core words expressed in terms of " { $link nrot } ":"
|
||||
{ $table
|
||||
{ { $link swap } { $snippet "1 nrot" } }
|
||||
{ { $link rot } { $snippet "2 nrot" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: -nrot
|
||||
{ $values { "n" integer } }
|
||||
|
|
@ -91,8 +132,12 @@ HELP: -nrot
|
|||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 -nrot .s" "4\n1\n2\n3" }
|
||||
}
|
||||
{ $see-also rot nrot } ;
|
||||
"Some core words expressed in terms of " { $link -nrot } ":"
|
||||
{ $table
|
||||
{ { $link swap } { $snippet "1 -nrot" } }
|
||||
{ { $link -rot } { $snippet "2 -nrot" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: nrev
|
||||
{ $values { "n" integer } }
|
||||
|
|
@ -100,11 +145,11 @@ HELP: nrev
|
|||
}
|
||||
{ $examples
|
||||
{ $example "USING: prettyprint generalizations ;" "1 2 3 4 4 nrev .s" "4\n3\n2\n1" }
|
||||
}
|
||||
{ $see-also rot nrot } ;
|
||||
"The " { $link spin } " word is equivalent to " { $snippet "3 nrev" } "."
|
||||
} ;
|
||||
|
||||
HELP: ndip
|
||||
{ $values { "quot" quotation } { "n" number } }
|
||||
{ $values { "quot" quotation } { "n" integer } }
|
||||
{ $description "A generalization of " { $link dip } " that can work "
|
||||
"for any stack depth. The quotation will be called with a stack that "
|
||||
"has 'n' items removed first. The 'n' items are then put back on the "
|
||||
|
|
@ -113,30 +158,93 @@ HELP: ndip
|
|||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 [ dup ] 1 ndip .s" "1\n1\n2" }
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 [ drop ] 2 ndip .s" "2\n3" }
|
||||
}
|
||||
{ $see-also dip 2dip } ;
|
||||
"Some core words expressed in terms of " { $link ndip } ":"
|
||||
{ $table
|
||||
{ { $link dip } { $snippet "1 ndip" } }
|
||||
{ { $link 2dip } { $snippet "2 ndip" } }
|
||||
{ { $link 3dip } { $snippet "3 ndip" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: nslip
|
||||
{ $values { "n" number } }
|
||||
{ $values { "n" integer } }
|
||||
{ $description "A generalization of " { $link slip } " that can work "
|
||||
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
|
||||
"removed from the stack, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations prettyprint ;" "[ 99 ] 1 2 3 4 5 5 nslip .s" "99\n1\n2\n3\n4\n5" }
|
||||
}
|
||||
{ $see-also slip nkeep } ;
|
||||
"Some core words expressed in terms of " { $link nslip } ":"
|
||||
{ $table
|
||||
{ { $link slip } { $snippet "1 nslip" } }
|
||||
{ { $link 2slip } { $snippet "2 nslip" } }
|
||||
{ { $link 3slip } { $snippet "3 nslip" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: nkeep
|
||||
{ $values { "quot" quotation } { "n" number } }
|
||||
{ $values { "quot" quotation } { "n" integer } }
|
||||
{ $description "A generalization of " { $link keep } " that can work "
|
||||
"for any stack depth. The first " { $snippet "n" } " items after the quotation will be "
|
||||
"saved, the quotation called, and the items restored."
|
||||
}
|
||||
{ $examples
|
||||
{ $example "USING: generalizations kernel prettyprint ;" "1 2 3 4 5 [ drop drop drop drop drop 99 ] 5 nkeep .s" "99\n1\n2\n3\n4\n5" }
|
||||
}
|
||||
{ $see-also keep nslip } ;
|
||||
"Some core words expressed in terms of " { $link nkeep } ":"
|
||||
{ $table
|
||||
{ { $link keep } { $snippet "1 nkeep" } }
|
||||
{ { $link 2keep } { $snippet "2 nkeep" } }
|
||||
{ { $link 3keep } { $snippet "3 nkeep" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: ncurry
|
||||
{ $values { "quot" quotation } { "n" integer } }
|
||||
{ $description "A generalization of " { $link curry } " that can work for any stack depth."
|
||||
}
|
||||
{ $examples
|
||||
"Some core words expressed in terms of " { $link ncurry } ":"
|
||||
{ $table
|
||||
{ { $link curry } { $snippet "1 ncurry" } }
|
||||
{ { $link 2curry } { $snippet "2 ncurry" } }
|
||||
{ { $link 3curry } { $snippet "3 ncurry" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: nwith
|
||||
{ $values { "quot" quotation } { "n" integer } }
|
||||
{ $description "A generalization of " { $link with } " that can work for any stack depth."
|
||||
}
|
||||
{ $examples
|
||||
"Some core words expressed in terms of " { $link nwith } ":"
|
||||
{ $table
|
||||
{ { $link with } { $snippet "1 nwith" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: napply
|
||||
{ $values { "quot" quotation } { "n" integer } }
|
||||
{ $description "A generalization of " { $link bi@ } " and " { $link tri@ } " that can work for any stack depth."
|
||||
}
|
||||
{ $examples
|
||||
"Some core words expressed in terms of " { $link napply } ":"
|
||||
{ $table
|
||||
{ { $link bi@ } { $snippet "1 napply" } }
|
||||
{ { $link tri@ } { $snippet "2 napply" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
HELP: mnswap
|
||||
{ $values { "m" integer } { "n" integer } }
|
||||
{ $description "Swaps the top " { $snippet "m" } " stack elements with the " { $snippet "n" } " elements directly underneath." }
|
||||
{ $examples
|
||||
"Some core words expressed in terms of " { $link mnswap } ":"
|
||||
{ $table
|
||||
{ { $link swap } { $snippet "1 1 mnswap" } }
|
||||
{ { $link rot } { $snippet "2 1 mnswap" } }
|
||||
{ { $link -rot } { $snippet "1 2 mnswap" } }
|
||||
}
|
||||
} ;
|
||||
|
||||
ARTICLE: "generalizations" "Generalized shuffle words and combinators"
|
||||
"The " { $vocab-link "generalizations" } " vocabulary defines a number of stack shuffling words and combinators for use in "
|
||||
|
|
@ -155,12 +263,14 @@ $nl
|
|||
{ $subsection nnip }
|
||||
{ $subsection ndrop }
|
||||
{ $subsection nrev }
|
||||
{ $subsection mnswap }
|
||||
"Generalized combinators:"
|
||||
{ $subsection ndip }
|
||||
{ $subsection nslip }
|
||||
{ $subsection nkeep }
|
||||
{ $subsection napply }
|
||||
"Generalized quotation construction:"
|
||||
{ $subsection ncurry }
|
||||
{ $subsection nwith }
|
||||
{ $subsection napply } ;
|
||||
{ $subsection nwith } ;
|
||||
|
||||
ABOUT: "generalizations"
|
||||
|
|
|
|||
|
|
@ -38,3 +38,7 @@ IN: generalizations.tests
|
|||
[ "a" ] [ { "a" } 1 firstn ] unit-test
|
||||
|
||||
[ [ 1 2 ] ] [ 1 2 2 [ ] nsequence ] unit-test
|
||||
|
||||
[ 4 5 1 2 3 ] [ 1 2 3 4 5 2 3 mnswap ] unit-test
|
||||
|
||||
[ 1 2 3 4 5 6 ] [ 1 2 3 4 5 6 2 4 mnswap 4 2 mnswap ] unit-test
|
||||
|
|
|
|||
|
|
@ -13,14 +13,14 @@ IN: generalizations
|
|||
|
||||
>>
|
||||
|
||||
MACRO: nsequence ( n seq -- quot )
|
||||
MACRO: nsequence ( n seq -- )
|
||||
[
|
||||
[ drop <reversed> ] [ '[ _ _ new-sequence ] ] 2bi
|
||||
[ '[ @ [ _ swap set-nth-unsafe ] keep ] ] reduce
|
||||
] keep
|
||||
'[ @ _ like ] ;
|
||||
|
||||
MACRO: narray ( n -- quot )
|
||||
MACRO: narray ( n -- )
|
||||
'[ _ { } nsequence ] ;
|
||||
|
||||
MACRO: firstn ( n -- )
|
||||
|
|
@ -30,7 +30,7 @@ MACRO: firstn ( n -- )
|
|||
bi prefix '[ _ cleave ]
|
||||
] if ;
|
||||
|
||||
MACRO: npick ( n -- quot )
|
||||
MACRO: npick ( n -- )
|
||||
1- [ dup ] [ '[ _ dip swap ] ] repeat ;
|
||||
|
||||
MACRO: ndup ( n -- )
|
||||
|
|
@ -51,7 +51,7 @@ MACRO: nnip ( n -- )
|
|||
MACRO: ntuck ( n -- )
|
||||
2 + '[ dup _ -nrot ] ;
|
||||
|
||||
MACRO: nrev ( n -- quot )
|
||||
MACRO: nrev ( n -- )
|
||||
1 [a,b] [ ] [ '[ @ _ -nrot ] ] reduce ;
|
||||
|
||||
MACRO: ndip ( quot n -- )
|
||||
|
|
@ -73,3 +73,6 @@ MACRO: napply ( n -- )
|
|||
2 [a,b]
|
||||
[ [ 1- ] [ ] bi '[ _ ntuck _ nslip ] ]
|
||||
map concat >quotation [ call ] append ;
|
||||
|
||||
MACRO: mnswap ( m n -- )
|
||||
1+ '[ _ -nrot ] <repetition> spread>quot ;
|
||||
|
|
|
|||
|
|
@ -1,39 +1,14 @@
|
|||
IN: locals.backend.tests
|
||||
USING: tools.test locals.backend kernel arrays ;
|
||||
|
||||
[ 3 ] [ 3 >r 1 get-local r> drop ] unit-test
|
||||
|
||||
[ 4 ] [ 3 4 >r >r 2 get-local 2 drop-locals ] unit-test
|
||||
|
||||
: get-local-test-1 ( -- x ) 3 >r 1 get-local r> drop ;
|
||||
: get-local-test-1 ( -- x ) 3 1 load-locals 0 get-local 1 drop-locals ;
|
||||
|
||||
\ get-local-test-1 must-infer
|
||||
|
||||
[ 3 ] [ get-local-test-1 ] unit-test
|
||||
|
||||
: get-local-test-2 ( -- x ) 3 4 >r >r 2 get-local 2 drop-locals ;
|
||||
: get-local-test-2 ( -- x ) 3 4 2 load-locals -1 get-local 2 drop-locals ;
|
||||
|
||||
\ get-local-test-2 must-infer
|
||||
|
||||
[ 4 ] [ get-local-test-2 ] unit-test
|
||||
|
||||
: get-local-test-3 ( -- a b ) 3 4 >r >r 2 get-local r> r> 2array ;
|
||||
|
||||
\ get-local-test-3 must-infer
|
||||
|
||||
[ 4 { 3 4 } ] [ get-local-test-3 ] unit-test
|
||||
|
||||
: get-local-test-4 ( -- a b )
|
||||
3 4 >r >r r> r> dup swap >r swap >r r> r> 2array ;
|
||||
|
||||
\ get-local-test-4 must-infer
|
||||
|
||||
[ 4 { 3 4 } ] [ get-local-test-4 ] unit-test
|
||||
|
||||
[ 1 2 ] [ 1 2 2 load-locals r> r> ] unit-test
|
||||
|
||||
: load-locals-test-1 ( -- a b ) 1 2 2 load-locals r> r> ;
|
||||
|
||||
\ load-locals-test-1 must-infer
|
||||
|
||||
[ 1 2 ] [ load-locals-test-1 ] unit-test
|
||||
[ 3 ] [ get-local-test-2 ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,11 +1,8 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math.private kernel slots.private sequences effects words ;
|
||||
USING: slots.private ;
|
||||
IN: locals.backend
|
||||
|
||||
: load-locals ( n -- )
|
||||
dup 0 eq? [ drop ] [ swap >r 1 fixnum-fast load-locals ] if ;
|
||||
|
||||
: local-value 2 slot ; inline
|
||||
|
||||
: set-local-value 2 set-slot ; inline
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: help.syntax help.markup kernel macros prettyprint
|
||||
memoize combinators arrays ;
|
||||
memoize combinators arrays generalizations ;
|
||||
IN: locals
|
||||
|
||||
HELP: [|
|
||||
|
|
@ -131,10 +131,40 @@ $nl
|
|||
$nl
|
||||
"Unlike some languages such as Python and Java, writing to mutable locals in outer scopes is fully supported and has the expected semantics." ;
|
||||
|
||||
ARTICLE: "locals-fry" "Locals and fry"
|
||||
"Locals integrate with " { $link "fry" } " so that mixing locals with fried quotations gives intuitive results."
|
||||
$nl
|
||||
"Recall that the following two code snippets are equivalent:"
|
||||
{ $code "'[ sq _ + ]" }
|
||||
{ $code "[ [ sq ] dip + ] curry" }
|
||||
"The semantics of " { $link dip } " and " { $link curry } " are such that the first example behaves as if the top of the stack as ``inserted'' in the ``hole'' in the quotation's second element."
|
||||
$nl
|
||||
"Conceptually, " { $link curry } " is defined so that the following two code snippets are equivalent:"
|
||||
{ $code "3 [ - ] curry" }
|
||||
{ $code "[ 3 - ]" }
|
||||
"With lambdas, " { $link curry } " behaves differently. Rather than prepending an element, it fills in named parameters from right to left. The following two snippets are equivalent:"
|
||||
{ $code "3 [| a b | a b - ] curry" }
|
||||
{ $code "[| a | a 3 - ]" }
|
||||
"Because of this, the behavior of fry changes when applied to a lambda, to ensure that conceptually, fry behaves as with quotations. So the following snippets are no longer equivalent:"
|
||||
{ $code "'[ [| a | _ a - ] ]" }
|
||||
{ $code "'[ [| a | a - ] curry ] call" }
|
||||
"Instead, the first line above expands into something like the following:"
|
||||
{ $code "[ [ swap [| a | a - ] ] curry call ]" }
|
||||
"This ensures that the fried value appears ``underneath'' the local variable " { $snippet "a" } " when the quotation calls."
|
||||
$nl
|
||||
"The precise behavior is the following. When frying a lambda, a stack shuffle (" { $link mnswap } ") is prepended to the lambda so that the " { $snippet "m" } " curried values, which start off at the top of the stack, are transposed with the " { $snippet "n" } " inputs to the lambda." ;
|
||||
|
||||
ARTICLE: "locals-limitations" "Limitations of locals"
|
||||
"The first limitation is also shared by " { $vocab-link "fry" } ": the " { $link >r } " and " { $link r> } " words may not be used together with locals. Instead, use the " { $link dip } " combinator. An error is thrown at parse time if an attempt is made to use " { $link >r } " and " { $link r> } " inside a lambda body:"
|
||||
{ $subsection >r/r>-in-lambda-error }
|
||||
"Another limitation concerns combinators implemented as macros. Locals can only be used with such combinators if the input array immediately precedes the combinator call. For example, the following will work:"
|
||||
"There are two main limitations of the current locals implementation, and both concern macros."
|
||||
{ $heading "Macro expansions with free variables" }
|
||||
"The expansion of a macro cannot reference local variables bound in the outer scope. For example, the following macro is invalid:"
|
||||
{ $code "MACRO:: twice ( quot -- ) [ quot call quot call ] ;" }
|
||||
"The following is fine, though:"
|
||||
{ $code "MACRO:: twice ( quot -- ) quot quot '[ @ @ ] ;" }
|
||||
{ $heading "Static stack effect inference and macros" }
|
||||
"Recall that a macro will only expand at compile-time, and the word containing it will only get a static stack effect, if all inputs to the macro are literal. When locals are used, there is an additional restriction; the literals must immediately precede the macro call, lexically."
|
||||
$nl
|
||||
"For example, all of the following three examples are equivalent semantically, but only the first will have a static stack effect and compile with the optimizing compiler:"
|
||||
{ $code
|
||||
":: good-cond-usage ( a -- ... )"
|
||||
" {"
|
||||
|
|
@ -143,7 +173,7 @@ ARTICLE: "locals-limitations" "Limitations of locals"
|
|||
" { [ a 0 = ] [ ... ] }"
|
||||
" } cond ;"
|
||||
}
|
||||
"But not the following:"
|
||||
"The following two will not, and will run slower as a result:"
|
||||
{ $code
|
||||
": my-cond ( alist -- ) cond ; inline"
|
||||
""
|
||||
|
|
@ -154,6 +184,14 @@ ARTICLE: "locals-limitations" "Limitations of locals"
|
|||
" { [ a 0 = ] [ ... ] }"
|
||||
" } my-cond ;"
|
||||
}
|
||||
{ $code
|
||||
":: bad-cond-usage ( a -- ... )"
|
||||
" {"
|
||||
" { [ a 0 < ] [ ... ] }"
|
||||
" { [ a 0 > ] [ ... ] }"
|
||||
" { [ a 0 = ] [ ... ] }"
|
||||
" } swap swap cond ;"
|
||||
}
|
||||
"The reason is that locals are rewritten into stack code at parse time, whereas macro expansion is performed later during compile time. To circumvent this problem, the " { $vocab-link "macros.expander" } " vocabulary is used to rewrite simple macro usages prior to local transformation, however "{ $vocab-link "macros.expander" } " does not deal with more complicated cases where the literal inputs to the macro do not immediately precede the macro call in the source." ;
|
||||
|
||||
ARTICLE: "locals" "Local variables and lexical closures"
|
||||
|
|
@ -174,6 +212,7 @@ $nl
|
|||
"Additional topics:"
|
||||
{ $subsection "locals-literals" }
|
||||
{ $subsection "locals-mutable" }
|
||||
{ $subsection "locals-fry" }
|
||||
{ $subsection "locals-limitations" }
|
||||
"Locals complement dynamically scoped variables implemented in the " { $vocab-link "namespaces" } " vocabulary." ;
|
||||
|
||||
|
|
|
|||
|
|
@ -398,7 +398,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
|||
|
||||
[ ] [ [ { integer lambda-method-forget-test } forget ] with-compilation-unit ] unit-test
|
||||
|
||||
[ { [ 10 ] } ] [ 10 [| A | { [ A ] } ] call ] unit-test
|
||||
[ 10 ] [ 10 [| A | { [ A ] } ] call first call ] unit-test
|
||||
|
||||
[
|
||||
"USING: locals fry math ; [ 0 '[ [let | A [ 10 ] | A _ + ] ] ]" eval
|
||||
|
|
@ -431,14 +431,53 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
|
|||
|
||||
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
|
||||
|
||||
! :: wlet-&&-test ( a -- ? )
|
||||
! [wlet | is-integer? [ a integer? ]
|
||||
! is-even? [ a even? ]
|
||||
! >10? [ a 10 > ] |
|
||||
! { [ is-integer? ] [ is-even? ] [ >10? ] } &&
|
||||
! ] ;
|
||||
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval ] must-fail
|
||||
|
||||
! [ f ] [ 1.5 wlet-&&-test ] unit-test
|
||||
! [ f ] [ 3 wlet-&&-test ] unit-test
|
||||
! [ f ] [ 8 wlet-&&-test ] unit-test
|
||||
! [ t ] [ 12 wlet-&&-test ] unit-test
|
||||
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval ] must-fail
|
||||
|
||||
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval ] must-fail
|
||||
|
||||
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval ] must-fail
|
||||
|
||||
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval ] must-fail
|
||||
|
||||
:: wlet-&&-test ( a -- ? )
|
||||
[wlet | is-integer? [ a integer? ]
|
||||
is-even? [ a even? ]
|
||||
>10? [ a 10 > ] |
|
||||
{ [ is-integer? ] [ is-even? ] [ >10? ] } &&
|
||||
] ;
|
||||
|
||||
\ wlet-&&-test must-infer
|
||||
[ f ] [ 1.5 wlet-&&-test ] unit-test
|
||||
[ f ] [ 3 wlet-&&-test ] unit-test
|
||||
[ f ] [ 8 wlet-&&-test ] unit-test
|
||||
[ t ] [ 12 wlet-&&-test ] unit-test
|
||||
|
||||
: fry-locals-test-1 ( -- n )
|
||||
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
|
||||
|
||||
\ fry-locals-test-1 must-infer
|
||||
[ 10 ] [ fry-locals-test-1 ] unit-test
|
||||
|
||||
:: fry-locals-test-2 ( -- n )
|
||||
[let | | 6 '[ [let | A [ 4 ] | A _ + ] ] call ] ;
|
||||
|
||||
\ fry-locals-test-2 must-infer
|
||||
[ 10 ] [ fry-locals-test-2 ] unit-test
|
||||
|
||||
[ 1 ] [ 3 4 [| | '[ [ _ swap - ] call ] call ] call ] unit-test
|
||||
[ -1 ] [ 3 4 [| | [| a | a - ] call ] call ] unit-test
|
||||
[ -1 ] [ 3 4 [| | [| a | a - ] curry call ] call ] unit-test
|
||||
[ -1 ] [ 3 4 [| a | a - ] curry call ] unit-test
|
||||
[ 1 ] [ 3 4 [| | '[ [| a | _ a - ] call ] call ] call ] unit-test
|
||||
[ -1 ] [ 3 4 [| | '[ [| a | a _ - ] call ] call ] call ] unit-test
|
||||
|
||||
[ { 1 2 3 4 } ] [
|
||||
1 3 2 4
|
||||
[| | '[ [| a b | a _ b _ 4array ] call ] call ] call
|
||||
] unit-test
|
||||
|
||||
[ 10 ] [
|
||||
[| | 0 '[ [let | A [ 10 ] | A _ + ] ] call ] call
|
||||
] unit-test
|
||||
|
|
@ -6,18 +6,36 @@ 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 ;
|
||||
locals.backend memoize macros.expander lexer classes summary fry
|
||||
fry.private ;
|
||||
IN: locals
|
||||
|
||||
! Inspired by
|
||||
! http://cat-language.googlecode.com/svn/trunk/CatPointFreeForm.cs
|
||||
|
||||
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 ;
|
||||
|
|
@ -85,60 +103,53 @@ C: <quote> quote
|
|||
[ dup quote? [ local>> ] when eq? ] with find drop ;
|
||||
|
||||
: read-local-quot ( obj args -- quot )
|
||||
local-index 1+ [ get-local ] curry ;
|
||||
local-index neg [ get-local ] curry ;
|
||||
|
||||
: localize-writer ( obj args -- quot )
|
||||
>r "local-reader" word-prop r>
|
||||
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 ;
|
||||
|
||||
: localize ( obj args -- quot )
|
||||
{
|
||||
{ [ over local? ] [ read-local-quot ] }
|
||||
{ [ over quote? ] [ >r local>> r> read-local-quot ] }
|
||||
{ [ over local-word? ] [ read-local-quot [ call ] append ] }
|
||||
{ [ over local-reader? ] [ read-local-quot [ local-value ] append ] }
|
||||
{ [ over local-writer? ] [ localize-writer ] }
|
||||
{ [ over \ lambda eq? ] [ 2drop [ ] ] }
|
||||
{ [ t ] [ drop 1quotation ] }
|
||||
} cond ;
|
||||
M: object localize drop 1quotation ;
|
||||
|
||||
UNION: special local quote local-word local-reader local-writer ;
|
||||
|
||||
: load-locals-quot ( args -- quot )
|
||||
[
|
||||
[ ]
|
||||
] [
|
||||
[ [ ] ] [
|
||||
dup [ local-reader? ] contains? [
|
||||
<reversed> [
|
||||
local-reader? [ 1array >r ] [ >r ] ?
|
||||
] map concat
|
||||
] [
|
||||
length [ load-locals ] curry >quotation
|
||||
] if
|
||||
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 )
|
||||
>r but-last-slice r> [ localize ] curry map concat ;
|
||||
[ but-last-slice ] dip '[ _ localize ] map concat ;
|
||||
|
||||
: point-free-end ( quot args -- newquot )
|
||||
over peek special?
|
||||
[ dup drop-locals-quot >r >r peek r> localize r> append ]
|
||||
[ dup drop-locals-quot nip swap peek suffix ]
|
||||
[ 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 ]
|
||||
[ point-free-body ]
|
||||
[ point-free-end ]
|
||||
2tri 3append >quotation ;
|
||||
[ reverse point-free-body ]
|
||||
[ reverse point-free-end ]
|
||||
2tri [ ] 3append-as ;
|
||||
|
||||
: point-free ( quot args -- newquot )
|
||||
over empty?
|
||||
[ nip length \ drop <repetition> >quotation ]
|
||||
[ (point-free) ] if ;
|
||||
over empty? [ nip length '[ _ ndrop ] ] [ (point-free) ] if ;
|
||||
|
||||
UNION: lexical local local-reader local-writer local-word ;
|
||||
|
||||
|
|
@ -227,9 +238,6 @@ GENERIC: rewrite-element ( obj -- )
|
|||
M: array rewrite-element
|
||||
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
|
||||
|
||||
M: quotation rewrite-element
|
||||
dup rewrite-literal? [ rewrite-sequence ] [ , ] if ;
|
||||
|
||||
M: vector rewrite-element rewrite-sequence ;
|
||||
|
||||
M: hashtable rewrite-element >alist rewrite-sequence \ >hashtable , ;
|
||||
|
|
@ -237,12 +245,22 @@ 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
|
||||
|
|
@ -278,8 +296,9 @@ M: object local-rewrite* , ;
|
|||
: make-locals ( seq -- words assoc )
|
||||
[ [ make-local ] map ] H{ } make-assoc ;
|
||||
|
||||
: make-local-word ( name -- word )
|
||||
<local-word> dup dup name>> set ;
|
||||
: 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 ;
|
||||
|
|
@ -328,7 +347,7 @@ SYMBOL: in-lambda?
|
|||
|
||||
: (parse-wbindings) ( -- )
|
||||
parse-binding [
|
||||
first2 >r make-local-word r> 2array ,
|
||||
first2 [ make-local-word ] keep 2array ,
|
||||
(parse-wbindings)
|
||||
] when* ;
|
||||
|
||||
|
|
@ -340,7 +359,7 @@ SYMBOL: in-lambda?
|
|||
|
||||
: let-rewrite ( body bindings -- )
|
||||
<reversed> [
|
||||
>r 1array r> spin <lambda> [ call ] curry compose
|
||||
[ 1array ] dip spin <lambda> '[ @ @ ]
|
||||
] assoc-each local-rewrite* \ call , ;
|
||||
|
||||
M: let local-rewrite*
|
||||
|
|
@ -351,7 +370,7 @@ M: let* local-rewrite*
|
|||
|
||||
M: wlet local-rewrite*
|
||||
[ body>> ] [ bindings>> ] bi
|
||||
[ [ ] curry ] assoc-map
|
||||
[ '[ _ ] ] assoc-map
|
||||
let-rewrite ;
|
||||
|
||||
: parse-locals ( -- vars assoc )
|
||||
|
|
@ -359,11 +378,6 @@ M: wlet local-rewrite*
|
|||
word [ over "declared-effect" set-word-prop ] when*
|
||||
in>> [ dup pair? [ first ] when ] map make-locals dup push-locals ;
|
||||
|
||||
ERROR: bad-lambda-rewrite output ;
|
||||
|
||||
M: bad-lambda-rewrite summary
|
||||
drop "You have found a bug in locals. Please report." ;
|
||||
|
||||
: parse-locals-definition ( word -- word quot )
|
||||
"(" expect parse-locals \ ; (parse-lambda) <lambda>
|
||||
2dup "lambda" set-word-prop
|
||||
|
|
@ -431,7 +445,7 @@ M: lambda pprint*
|
|||
\ | pprint-word
|
||||
t <inset
|
||||
<block
|
||||
[ <block >r pprint-var r> pprint* block> ] assoc-each
|
||||
[ <block [ pprint-var ] dip pprint* block> ] assoc-each
|
||||
block>
|
||||
\ | pprint-word
|
||||
<block pprint-elements block>
|
||||
|
|
@ -497,3 +511,15 @@ M: lambda-method synopsis*
|
|||
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 , ;
|
||||
|
|
|
|||
|
|
@ -134,11 +134,11 @@ M: object infer-call*
|
|||
|
||||
: infer-load-locals ( -- )
|
||||
pop-literal nip
|
||||
consume-d dup reverse copy-values dup output-r
|
||||
[ [ f f ] dip ] [ reverse swap zip ] 2bi #shuffle, ;
|
||||
consume-d dup copy-values dup output-r
|
||||
[ [ f f ] dip ] [ swap zip ] 2bi #shuffle, ;
|
||||
|
||||
: infer-get-local ( -- )
|
||||
[let* | n [ pop-literal nip ]
|
||||
[let* | n [ pop-literal nip 1 swap - ]
|
||||
in-r [ n consume-r ]
|
||||
out-d [ in-r first copy-value 1array ]
|
||||
out-r [ in-r copy-values ] |
|
||||
|
|
@ -186,6 +186,9 @@ M: object infer-call*
|
|||
: infer-local-writer ( word -- )
|
||||
(( value -- )) apply-word/effect ;
|
||||
|
||||
: infer-local-word ( word -- )
|
||||
"local-word-def" word-prop infer-quot-here ;
|
||||
|
||||
{
|
||||
>r r> declare call (call) slip 2slip 3slip curry compose
|
||||
execute (execute) if dispatch <tuple-boa> (throw)
|
||||
|
|
@ -209,6 +212,7 @@ M: object infer-call*
|
|||
{ [ dup local? ] [ infer-local-reader ] }
|
||||
{ [ dup local-reader? ] [ infer-local-reader ] }
|
||||
{ [ dup local-writer? ] [ infer-local-writer ] }
|
||||
{ [ dup local-word? ] [ infer-local-word ] }
|
||||
{ [ dup recursive-word? ] [ call-recursive-word ] }
|
||||
[ dup infer-word apply-word/effect ]
|
||||
} cond ;
|
||||
|
|
|
|||
|
|
@ -94,7 +94,10 @@ IN: stack-checker.transforms
|
|||
[ "method-class" word-prop ]
|
||||
[ "method-generic" word-prop ] bi
|
||||
[ inlined-dependency depends-on ] bi@
|
||||
] [ next-method-quot ] bi
|
||||
] [
|
||||
[ next-method-quot ]
|
||||
[ '[ _ no-next-method ] ] bi or
|
||||
] bi
|
||||
] 1 define-transform
|
||||
|
||||
! Constructors
|
||||
|
|
|
|||
|
|
@ -343,6 +343,9 @@ IN: tools.deploy.shaker
|
|||
: compress-strings ( -- )
|
||||
[ string? ] [ ] "strings" compress ;
|
||||
|
||||
: compress-wrappers ( -- )
|
||||
[ wrapper? ] [ ] "wrappers" compress ;
|
||||
|
||||
: finish-deploy ( final-image -- )
|
||||
"Finishing up" show
|
||||
>r { } set-datastack r>
|
||||
|
|
@ -391,7 +394,8 @@ SYMBOL: deploy-vocab
|
|||
r> strip-words
|
||||
compress-byte-arrays
|
||||
compress-quotations
|
||||
compress-strings ;
|
||||
compress-strings
|
||||
compress-wrappers ;
|
||||
|
||||
: (deploy) ( final-image vocab config -- )
|
||||
#! Does the actual work of a deployment in the slave
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ SYMBOL: selection
|
|||
|
||||
: gadget-copy ( gadget clipboard -- )
|
||||
over gadget-selection?
|
||||
[ >r [ gadget-selection ] keep r> copy-clipboard ]
|
||||
[ [ [ gadget-selection ] keep ] dip copy-clipboard ]
|
||||
[ 2drop ]
|
||||
if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ command-line kernel memory namespaces cocoa.messages
|
|||
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
|
||||
cocoa.windows cocoa.classes cocoa.application sequences system
|
||||
ui ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
|
||||
ui.cocoa.views core-foundation threads math.geometry.rect ;
|
||||
ui.cocoa.views core-foundation threads math.geometry.rect fry ;
|
||||
IN: ui.cocoa
|
||||
|
||||
TUPLE: handle view window ;
|
||||
|
|
@ -15,7 +15,7 @@ C: <handle> handle
|
|||
SINGLETON: cocoa-ui-backend
|
||||
|
||||
M: cocoa-ui-backend do-events ( -- )
|
||||
[ NSApp [ do-event ] curry loop ui-wait ] with-autorelease-pool ;
|
||||
[ NSApp '[ _ do-event ] loop ui-wait ] with-autorelease-pool ;
|
||||
|
||||
TUPLE: pasteboard handle ;
|
||||
|
||||
|
|
|
|||
|
|
@ -25,7 +25,7 @@ CLASS: {
|
|||
}
|
||||
|
||||
{ "application:openFiles:" "void" { "id" "SEL" "id" "id" }
|
||||
[ >r 3drop r> finder-run-files ]
|
||||
[ [ 3drop ] dip finder-run-files ]
|
||||
}
|
||||
|
||||
{ "newFactorWorkspace:" "id" { "id" "SEL" "id" }
|
||||
|
|
|
|||
|
|
@ -8,7 +8,7 @@ core-foundation threads combinators math.geometry.rect ;
|
|||
IN: ui.cocoa.views
|
||||
|
||||
: send-mouse-moved ( view event -- )
|
||||
over >r mouse-location r> window move-hand fire-motion ;
|
||||
[ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
|
||||
|
||||
: button ( event -- n )
|
||||
#! Cocoa -> Factor UI button mapping
|
||||
|
|
@ -85,18 +85,19 @@ IN: ui.cocoa.views
|
|||
mouse-location rot window send-button-up ;
|
||||
|
||||
: send-wheel$ ( view event -- )
|
||||
over >r
|
||||
dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
|
||||
mouse-location
|
||||
r> window send-wheel ;
|
||||
[
|
||||
dup -> deltaX sgn neg over -> deltaY sgn neg 2array -rot
|
||||
mouse-location
|
||||
] [ drop window ] 2bi send-wheel ;
|
||||
|
||||
: send-action$ ( view event gesture -- junk )
|
||||
>r drop window r> send-action f ;
|
||||
[ drop window ] dip send-action f ;
|
||||
|
||||
: add-resize-observer ( observer object -- )
|
||||
>r "updateFactorGadgetSize:"
|
||||
"NSViewFrameDidChangeNotification" <NSString>
|
||||
r> add-observer ;
|
||||
[
|
||||
"updateFactorGadgetSize:"
|
||||
"NSViewFrameDidChangeNotification" <NSString>
|
||||
] dip add-observer ;
|
||||
|
||||
: string-or-nil? ( NSString -- ? )
|
||||
[ CF>string NSStringPboardType = ] [ t ] if* ;
|
||||
|
|
@ -109,7 +110,7 @@ IN: ui.cocoa.views
|
|||
] if ;
|
||||
|
||||
: NSRect>rect ( NSRect world -- rect )
|
||||
>r dup NSRect-x over NSRect-y r>
|
||||
[ dup NSRect-x over NSRect-y ] dip
|
||||
rect-dim second swap - 2array
|
||||
over NSRect-w rot NSRect-h 2array
|
||||
<rect> ;
|
||||
|
|
@ -256,7 +257,7 @@ CLASS: {
|
|||
{ "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
|
||||
[
|
||||
! We return either self or nil
|
||||
>r >r over window-focus r> r>
|
||||
[ over window-focus ] 2dip
|
||||
valid-service? [ drop ] [ 2drop f ] if
|
||||
]
|
||||
}
|
||||
|
|
@ -278,7 +279,7 @@ CLASS: {
|
|||
{ "readSelectionFromPasteboard:" "char" { "id" "SEL" "id" }
|
||||
[
|
||||
pasteboard-string dup [
|
||||
>r drop window-focus r> swap user-input 1
|
||||
[ drop window-focus ] dip swap user-input 1
|
||||
] [
|
||||
3drop 0
|
||||
] if
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays definitions kernel sequences strings
|
||||
math assocs words generic namespaces make assocs quotations
|
||||
splitting ui.gestures unicode.case unicode.categories tr ;
|
||||
splitting ui.gestures unicode.case unicode.categories tr fry ;
|
||||
IN: ui.commands
|
||||
|
||||
SYMBOL: +nullary+
|
||||
|
|
@ -37,7 +37,7 @@ GENERIC: command-word ( command -- word )
|
|||
[
|
||||
commands>>
|
||||
[ drop ] assoc-filter
|
||||
[ [ invoke-command ] curry swap set ] assoc-each
|
||||
[ '[ _ invoke-command ] swap set ] assoc-each
|
||||
] each
|
||||
] H{ } make-assoc ;
|
||||
|
||||
|
|
|
|||
|
|
@ -111,7 +111,7 @@ M: freetype-renderer open-font ( font -- open-font )
|
|||
freetype drop open-fonts get [ <font> ] cache ;
|
||||
|
||||
: load-glyph ( font char -- glyph )
|
||||
>r handle>> dup r> 0 FT_Load_Char
|
||||
[ handle>> dup ] dip 0 FT_Load_Char
|
||||
freetype-error face-glyph ;
|
||||
|
||||
: char-width ( open-font char -- w )
|
||||
|
|
@ -174,7 +174,7 @@ M: freetype-renderer string-height ( open-font string -- h )
|
|||
bi 2array ;
|
||||
|
||||
: <char-sprite> ( open-font char -- sprite )
|
||||
over >r render-glyph dup r> glyph-texture-loc
|
||||
over [ render-glyph dup ] dip glyph-texture-loc
|
||||
over glyph-size pick glyph-texture-size <sprite>
|
||||
[ bitmap>texture ] keep [ init-sprite ] keep ;
|
||||
|
||||
|
|
@ -206,7 +206,7 @@ M: freetype-renderer string-height ( open-font string -- h )
|
|||
fonts>> [ open-font H{ } clone 2array ] cache first2 ;
|
||||
|
||||
M: freetype-renderer draw-string ( font string loc -- )
|
||||
>r >r world get font-sprites r> r> (draw-string) ;
|
||||
[ world get font-sprites ] 2dip (draw-string) ;
|
||||
|
||||
: run-char-widths ( open-font string -- widths )
|
||||
char-widths [ scan-sums ] [ 2 v/n ] bi v+ ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors kernel sequences models ui.gadgets math.geometry.rect ;
|
||||
USING: accessors kernel sequences models ui.gadgets
|
||||
math.geometry.rect fry ;
|
||||
IN: ui.gadgets.books
|
||||
|
||||
TUPLE: book < gadget ;
|
||||
|
|
@ -25,6 +26,6 @@ M: book model-changed ( model book -- )
|
|||
M: book pref-dim* ( book -- dim ) children>> pref-dims max-dim ;
|
||||
|
||||
M: book layout* ( book -- )
|
||||
[ children>> ] [ dim>> ] bi [ >>dim drop ] curry each ;
|
||||
[ children>> ] [ dim>> ] bi '[ _ >>dim drop ] each ;
|
||||
|
||||
M: book focusable-child* ( book -- child/t ) current-page ;
|
||||
|
|
|
|||
|
|
@ -152,6 +152,13 @@ M: mock-gadget ungraft*
|
|||
{ { f f } { f t } { t f } { t t } } [ notify-combo ] assoc-each
|
||||
] with-string-writer print
|
||||
|
||||
[ { { 10 30 } } ] [
|
||||
<gadget> { 0 1 } >>orientation
|
||||
{ { 10 20 } }
|
||||
{ { 100 30 } }
|
||||
orient
|
||||
] unit-test
|
||||
|
||||
\ <gadget> must-infer
|
||||
\ unparent must-infer
|
||||
\ add-gadget must-infer
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors arrays hashtables kernel models math namespaces
|
||||
make sequences quotations math.vectors combinators sorting
|
||||
binary-search vectors dlists deques models threads
|
||||
concurrency.flags math.order math.geometry.rect ;
|
||||
concurrency.flags math.order math.geometry.rect fry ;
|
||||
IN: ui.gadgets
|
||||
|
||||
SYMBOL: ui-notify-flag
|
||||
|
|
@ -56,9 +56,7 @@ M: gadget model-changed 2drop ;
|
|||
2dup eq? [
|
||||
2drop { 0 0 }
|
||||
] [
|
||||
over rect-loc >r
|
||||
>r parent>> r> relative-loc
|
||||
r> v+
|
||||
over rect-loc [ [ parent>> ] dip relative-loc ] dip v+
|
||||
] if ;
|
||||
|
||||
GENERIC: user-input* ( str gadget -- ? )
|
||||
|
|
@ -73,7 +71,7 @@ M: gadget children-on nip children>> ;
|
|||
[ swap loc>> v- ] dip v. 0 <=> ;
|
||||
|
||||
: (fast-children-on) ( dim axis children -- i )
|
||||
-rot [ ((fast-children-on)) ] 2curry search drop ;
|
||||
-rot '[ _ _ ((fast-children-on)) ] search drop ;
|
||||
|
||||
: fast-children-on ( rect axis children -- from to )
|
||||
[ [ rect-loc ] 2dip (fast-children-on) 0 or ]
|
||||
|
|
@ -95,10 +93,10 @@ M: gadget children-on nip children>> ;
|
|||
: dim-sum ( seq -- dim ) { 0 0 } [ v+ ] reduce ;
|
||||
|
||||
: orient ( gadget seq1 seq2 -- seq )
|
||||
>r >r orientation>> r> r> [ pick set-axis ] 2map nip ;
|
||||
rot orientation>> '[ _ set-axis ] 2map ;
|
||||
|
||||
: each-child ( gadget quot -- )
|
||||
>r children>> r> each ; inline
|
||||
[ children>> ] dip each ; inline
|
||||
|
||||
! Selection protocol
|
||||
GENERIC: gadget-selection? ( gadget -- ? )
|
||||
|
|
@ -310,18 +308,18 @@ SYMBOL: in-layout?
|
|||
[ parent>> ] follow ;
|
||||
|
||||
: each-parent ( gadget quot -- ? )
|
||||
>r parents r> all? ; inline
|
||||
[ parents ] dip all? ; inline
|
||||
|
||||
: find-parent ( gadget quot -- parent )
|
||||
>r parents r> find nip ; inline
|
||||
[ parents ] dip find nip ; inline
|
||||
|
||||
: screen-loc ( gadget -- loc )
|
||||
parents { 0 0 } [ rect-loc v+ ] reduce ;
|
||||
|
||||
: (screen-rect) ( gadget -- loc ext )
|
||||
dup parent>> [
|
||||
>r rect-extent r> (screen-rect)
|
||||
>r tuck v+ r> vmin >r v+ r>
|
||||
[ rect-extent ] dip (screen-rect)
|
||||
[ tuck v+ ] dip vmin [ v+ ] dip
|
||||
] [
|
||||
rect-extent
|
||||
] if* ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors math namespaces opengl opengl.gl sequences
|
||||
math.vectors ui.gadgets ui.gadgets.grids ui.render math.geometry.rect ;
|
||||
USING: kernel accessors math namespaces opengl opengl.gl
|
||||
sequences math.vectors ui.gadgets ui.gadgets.grids ui.render
|
||||
math.geometry.rect fry ;
|
||||
IN: ui.gadgets.grid-lines
|
||||
|
||||
TUPLE: grid-lines color ;
|
||||
|
|
@ -19,8 +20,8 @@ SYMBOL: grid-dim
|
|||
|
||||
: draw-grid-lines ( gaps orientation -- )
|
||||
[ grid get swap grid-positions grid get rect-dim suffix ] dip
|
||||
[ [ v- ] curry map ] keep
|
||||
[ swap grid-line-from/to gl-line ] curry each ;
|
||||
[ '[ _ v- ] map ] keep
|
||||
'[ _ swap grid-line-from/to gl-line ] each ;
|
||||
|
||||
M: grid-lines draw-boundary
|
||||
color>> gl-color [
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math namespaces make sequences words io
|
||||
io.streams.string math.vectors ui.gadgets columns accessors
|
||||
math.geometry.rect locals ;
|
||||
math.geometry.rect locals fry ;
|
||||
IN: ui.gadgets.grids
|
||||
|
||||
TUPLE: grid < gadget
|
||||
|
|
@ -48,21 +48,18 @@ grid
|
|||
dupd add-gaps dim-sum v+ ;
|
||||
|
||||
M: grid pref-dim*
|
||||
dup gap>> swap compute-grid >r over r>
|
||||
gap-sum >r gap-sum r> (pair-up) ;
|
||||
dup gap>> swap compute-grid [ over ] dip
|
||||
[ gap-sum ] 2bi@ (pair-up) ;
|
||||
|
||||
: do-grid ( dims grid quot -- )
|
||||
-rot grid>>
|
||||
[ [ pick call ] 2each ] 2each
|
||||
drop ; inline
|
||||
[ grid>> ] dip '[ _ 2each ] 2each ; inline
|
||||
|
||||
: grid-positions ( grid dims -- locs )
|
||||
>r gap>> dup r> add-gaps swap [ v+ ] accumulate nip ;
|
||||
[ gap>> dup ] dip add-gaps swap [ v+ ] accumulate nip ;
|
||||
|
||||
: position-grid ( grid horiz vert -- )
|
||||
pick >r
|
||||
>r over r> grid-positions >r grid-positions r>
|
||||
pair-up r> [ (>>loc) ] do-grid ;
|
||||
pick [ [ over ] dip [ grid-positions ] 2bi@ pair-up ] dip
|
||||
[ (>>loc) ] do-grid ;
|
||||
|
||||
: resize-grid ( grid horiz vert -- )
|
||||
pick fill?>> [
|
||||
|
|
|
|||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov.
|
||||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays ui.gadgets.buttons ui.gadgets.borders
|
||||
ui.gadgets.labels ui.gadgets.panes ui.gadgets.scrollers
|
||||
|
|
@ -19,10 +19,10 @@ TUPLE: labelled-gadget < track content ;
|
|||
M: labelled-gadget focusable-child* content>> ;
|
||||
|
||||
: <labelled-scroller> ( gadget title -- gadget )
|
||||
>r <scroller> r> <labelled-gadget> ;
|
||||
[ <scroller> ] dip <labelled-gadget> ;
|
||||
|
||||
: <labelled-pane> ( model quot scrolls? title -- gadget )
|
||||
>r >r <pane-control> r> >>scrolls? r>
|
||||
[ [ <pane-control> ] dip >>scrolls? ] dip
|
||||
<labelled-scroller> ;
|
||||
|
||||
: <close-box> ( quot -- button/f )
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ TUPLE: label < gadget text font color ;
|
|||
|
||||
: set-label-string ( string label -- )
|
||||
CHAR: \n pick memq? [
|
||||
>r string-lines r> (>>text)
|
||||
[ string-lines ] dip (>>text)
|
||||
] [
|
||||
(>>text)
|
||||
] if ; inline
|
||||
|
|
|
|||
|
|
@ -33,7 +33,7 @@ TUPLE: list < pack index presenter color hook ;
|
|||
hook>> [ [ list? ] find-parent ] prepend ;
|
||||
|
||||
: <list-presentation> ( hook elt presenter -- gadget )
|
||||
keep >r >label text-theme r>
|
||||
keep [ >label text-theme ] dip
|
||||
<presentation>
|
||||
swap >>hook ; inline
|
||||
|
||||
|
|
@ -42,7 +42,7 @@ TUPLE: list < pack index presenter color hook ;
|
|||
[ presenter>> ]
|
||||
[ control-value ]
|
||||
tri [
|
||||
>r 2dup r> swap <list-presentation>
|
||||
[ 2dup ] dip swap <list-presentation>
|
||||
] map 2nip ;
|
||||
|
||||
M: list model-changed
|
||||
|
|
@ -113,8 +113,8 @@ M: list focusable-child* drop t ;
|
|||
select-gadget ;
|
||||
|
||||
: list-page ( list vec -- )
|
||||
>r dup selected-rect rect-bounds 2 v/n v+
|
||||
over visible-dim r> v* v+ swap select-at ;
|
||||
[ dup selected-rect rect-bounds 2 v/n v+ over visible-dim ] dip
|
||||
v* v+ swap select-at ;
|
||||
|
||||
: list-page-up ( list -- ) { 0 -1 } list-page ;
|
||||
|
||||
|
|
|
|||
|
|
@ -8,13 +8,13 @@ math.geometry.rect ;
|
|||
IN: ui.gadgets.menus
|
||||
|
||||
: menu-loc ( world menu -- loc )
|
||||
>r rect-dim r> pref-dim [v-] hand-loc get-global vmin ;
|
||||
[ rect-dim ] [ pref-dim ] bi* [v-] hand-loc get-global vmin ;
|
||||
|
||||
TUPLE: menu-glass < gadget ;
|
||||
|
||||
: <menu-glass> ( menu world -- glass )
|
||||
menu-glass new-gadget
|
||||
>r over menu-loc >>loc r>
|
||||
[ over menu-loc >>loc ] dip
|
||||
swap add-gadget ;
|
||||
|
||||
M: menu-glass layout* gadget-child prefer ;
|
||||
|
|
|
|||
|
|
@ -19,10 +19,10 @@ TUPLE: pack < gadget
|
|||
{ 0 0 } [ v+ over v+ ] accumulate 2nip ;
|
||||
|
||||
: aligned-locs ( gadget sizes -- seq )
|
||||
[ >r dup align>> swap rect-dim r> v- n*v ] with map ;
|
||||
[ [ dup align>> swap rect-dim ] dip v- n*v ] with map ;
|
||||
|
||||
: packed-locs ( gadget sizes -- seq )
|
||||
over gap>> over gap-locs >r dupd aligned-locs r> orient ;
|
||||
over gap>> over gap-locs [ dupd aligned-locs ] dip orient ;
|
||||
|
||||
: round-dims ( seq -- newseq )
|
||||
{ 0 0 } swap
|
||||
|
|
@ -31,8 +31,9 @@ TUPLE: pack < gadget
|
|||
|
||||
: pack-layout ( pack sizes -- )
|
||||
round-dims over children>>
|
||||
>r dupd packed-dims r> 2dup [ (>>dim) ] 2each
|
||||
>r packed-locs r> [ (>>loc) ] 2each ;
|
||||
[ dupd packed-dims ] dip
|
||||
[ [ (>>dim) ] 2each ]
|
||||
[ [ packed-locs ] dip [ (>>loc) ] 2each ] 2bi ;
|
||||
|
||||
: <pack> ( orientation -- pack )
|
||||
pack new-gadget
|
||||
|
|
@ -48,7 +49,7 @@ TUPLE: pack < gadget
|
|||
[ dim-sum ] keep length 1 [-] rot n*v v+ ;
|
||||
|
||||
: pack-pref-dim ( gadget sizes -- dim )
|
||||
over gap>> over gap-dims >r max-dim r>
|
||||
over gap>> over gap-dims [ max-dim ] dip
|
||||
rot orientation>> set-axis ;
|
||||
|
||||
M: pack pref-dim*
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ opengl combinators math.vectors sorting splitting
|
|||
io.streams.nested assocs ui.gadgets.presentations
|
||||
ui.gadgets.slots ui.gadgets.grids ui.gadgets.grid-lines
|
||||
classes.tuple models continuations destructors accessors
|
||||
math.geometry.rect ;
|
||||
math.geometry.rect fry ;
|
||||
IN: ui.gadgets.panes
|
||||
|
||||
TUPLE: pane < pack
|
||||
|
|
@ -59,7 +59,7 @@ M: pane gadget-selection ( pane -- string/f )
|
|||
GENERIC: draw-selection ( loc obj -- )
|
||||
|
||||
: if-fits ( rect quot -- )
|
||||
>r clip get over intersects? r> [ drop ] if ; inline
|
||||
[ clip get over intersects? ] dip [ drop ] if ; inline
|
||||
|
||||
M: gadget draw-selection ( loc gadget -- )
|
||||
swap offset-rect [
|
||||
|
|
@ -135,8 +135,8 @@ M: style-stream write-gadget
|
|||
|
||||
: with-pane ( pane quot -- )
|
||||
over scroll>top
|
||||
over pane-clear >r <pane-stream> r>
|
||||
over >r with-output-stream* r> ?nl ; inline
|
||||
over pane-clear [ <pane-stream> ] dip
|
||||
over [ with-output-stream* ] dip ?nl ; inline
|
||||
|
||||
: make-pane ( quot -- gadget )
|
||||
<pane> [ swap with-pane ] keep smash-pane ; inline
|
||||
|
|
@ -154,7 +154,7 @@ M: pane-control model-changed ( model pane-control -- )
|
|||
swap >>model ;
|
||||
|
||||
: do-pane-stream ( pane-stream quot -- )
|
||||
>r pane>> r> keep scroll-pane ; inline
|
||||
[ pane>> ] dip keep scroll-pane ; inline
|
||||
|
||||
M: pane-stream stream-nl
|
||||
[ pane-nl drop ] do-pane-stream ;
|
||||
|
|
@ -178,7 +178,7 @@ M: pane-stream make-span-stream
|
|||
! Character styles
|
||||
|
||||
: apply-style ( style gadget key quot -- style gadget )
|
||||
>r pick at r> when* ; inline
|
||||
[ pick at ] dip when* ; inline
|
||||
|
||||
: apply-foreground-style ( style gadget -- style gadget )
|
||||
foreground [ >>color ] apply-style ;
|
||||
|
|
@ -228,7 +228,7 @@ M: pane-stream make-span-stream
|
|||
border-width [ <border> ] apply-style ;
|
||||
|
||||
: apply-printer-style ( style gadget -- style gadget )
|
||||
presented-printer [ [ make-pane ] curry >>printer ] apply-style ;
|
||||
presented-printer [ '[ _ make-pane ] >>printer ] apply-style ;
|
||||
|
||||
: style-pane ( style pane -- pane )
|
||||
apply-border-width-style
|
||||
|
|
@ -284,10 +284,10 @@ M: pane-stream make-cell-stream
|
|||
pane-cell-stream new-nested-pane-stream ;
|
||||
|
||||
M: pane-stream stream-write-table
|
||||
>r
|
||||
swap [ [ pane>> smash-pane ] map ] map
|
||||
styled-grid
|
||||
r> print-gadget ;
|
||||
[
|
||||
swap [ [ pane>> smash-pane ] map ] map
|
||||
styled-grid
|
||||
] dip print-gadget ;
|
||||
|
||||
! Stream utilities
|
||||
M: pack dispose drop ;
|
||||
|
|
@ -309,7 +309,7 @@ M: paragraph stream-write
|
|||
drop ;
|
||||
|
||||
: gadget-write1 ( char gadget -- )
|
||||
>r 1string r> stream-write ;
|
||||
[ 1string ] dip stream-write ;
|
||||
|
||||
M: pack stream-write1 gadget-write1 ;
|
||||
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ TUPLE: presentation < button object hook ;
|
|||
|
||||
: invoke-presentation ( presentation command -- )
|
||||
over dup hook>> call
|
||||
>r object>> r> invoke-command ;
|
||||
[ object>> ] dip invoke-command ;
|
||||
|
||||
: invoke-primary ( presentation -- )
|
||||
dup object>> primary-operation
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ USING: accessors arrays ui.gestures ui.gadgets ui.gadgets.buttons
|
|||
ui.gadgets.frames ui.gadgets.grids math.order
|
||||
ui.gadgets.theme ui.render kernel math namespaces sequences
|
||||
vectors models models.range math.vectors math.functions
|
||||
quotations colors math.geometry.rect ;
|
||||
quotations colors math.geometry.rect fry ;
|
||||
IN: ui.gadgets.sliders
|
||||
|
||||
TUPLE: elevator < gadget direction ;
|
||||
|
|
@ -104,13 +104,14 @@ elevator H{
|
|||
|
||||
: layout-thumb-loc ( slider -- )
|
||||
dup thumb-loc (layout-thumb)
|
||||
>r [ floor ] map r> (>>loc) ;
|
||||
[ [ floor ] map ] dip (>>loc) ;
|
||||
|
||||
: layout-thumb-dim ( slider -- )
|
||||
dup dup thumb-dim (layout-thumb) >r
|
||||
>r dup rect-dim r>
|
||||
rot orientation>> set-axis [ ceiling ] map
|
||||
r> (>>dim) ;
|
||||
dup dup thumb-dim (layout-thumb)
|
||||
[
|
||||
[ dup rect-dim ] dip
|
||||
rot orientation>> set-axis [ ceiling ] map
|
||||
] dip (>>dim) ;
|
||||
|
||||
: layout-thumb ( slider -- )
|
||||
dup layout-thumb-loc layout-thumb-dim ;
|
||||
|
|
@ -121,13 +122,13 @@ M: elevator layout*
|
|||
: slide-by-line ( amount slider -- ) [ line>> * ] keep slide-by ;
|
||||
|
||||
: <slide-button> ( vector polygon amount -- button )
|
||||
>r gray swap <polygon-gadget> r>
|
||||
[ swap find-slider slide-by-line ] curry <repeat-button>
|
||||
[ gray swap <polygon-gadget> ] dip
|
||||
'[ _ swap find-slider slide-by-line ] <repeat-button>
|
||||
swap >>orientation ;
|
||||
|
||||
: elevator, ( gadget orientation -- gadget )
|
||||
tuck <elevator> >>elevator
|
||||
swap <thumb> >>thumb
|
||||
swap <thumb> >>thumb
|
||||
dup elevator>> over thumb>> add-gadget
|
||||
@center grid-add ;
|
||||
|
||||
|
|
|
|||
|
|
@ -16,4 +16,4 @@ IN: ui.gadgets.status-bar
|
|||
open-world-window ;
|
||||
|
||||
: show-summary ( object gadget -- )
|
||||
>r [ summary ] [ "" ] if* r> show-status ;
|
||||
[ [ summary ] [ "" ] if* ] dip show-status ;
|
||||
|
|
|
|||
|
|
@ -52,7 +52,7 @@ M: world request-focus-on ( child gadget -- )
|
|||
M: world layout*
|
||||
dup call-next-method
|
||||
dup glass>> [
|
||||
>r dup rect-dim r> (>>dim)
|
||||
[ dup rect-dim ] dip (>>dim)
|
||||
] when* drop ;
|
||||
|
||||
M: world focusable-child* gadget-child ;
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ SYMBOL: operations
|
|||
operations get [ predicate>> call ] with filter ;
|
||||
|
||||
: find-operation ( obj quot -- command )
|
||||
>r object-operations r> find-last nip ; inline
|
||||
[ object-operations ] dip find-last nip ; inline
|
||||
|
||||
: primary-operation ( obj -- operation )
|
||||
[ command>> +primary+ word-prop ] find-operation ;
|
||||
|
|
|
|||
|
|
@ -12,7 +12,7 @@ SYMBOL: viewport-translation
|
|||
|
||||
: flip-rect ( rect -- loc dim )
|
||||
rect-bounds [
|
||||
>r { 1 -1 } v* r> { 0 -1 } v* v+
|
||||
[ { 1 -1 } v* ] dip { 0 -1 } v* v+
|
||||
viewport-translation get v+
|
||||
] keep ;
|
||||
|
||||
|
|
@ -79,9 +79,7 @@ DEFER: draw-gadget
|
|||
>absolute clip [ rect-intersect ] change ;
|
||||
|
||||
: with-clipping ( gadget quot -- )
|
||||
clip get >r
|
||||
over change-clip do-clip call
|
||||
r> clip set do-clip ; inline
|
||||
clip get [ over change-clip do-clip call ] dip clip set do-clip ; inline
|
||||
|
||||
: draw-gadget ( gadget -- )
|
||||
{
|
||||
|
|
@ -200,7 +198,7 @@ M: polygon draw-interior
|
|||
|
||||
: <polygon-gadget> ( color points -- gadget )
|
||||
dup max-dim
|
||||
>r <polygon> <gadget> r> >>dim
|
||||
[ <polygon> <gadget> ] dip >>dim
|
||||
swap >>interior ;
|
||||
|
||||
! Font rendering
|
||||
|
|
@ -242,7 +240,7 @@ HOOK: free-fonts font-renderer ( world -- )
|
|||
[
|
||||
[
|
||||
2dup { 0 0 } draw-string
|
||||
>r open-font r> string-height
|
||||
[ open-font ] dip string-height
|
||||
0.0 swap 0.0 glTranslated
|
||||
] with each
|
||||
] with-translation
|
||||
|
|
|
|||
|
|
@ -1,12 +1,11 @@
|
|||
! Copyright (C) 2007 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.gadgets colors kernel ui.render namespaces
|
||||
models models.mapping sequences ui.gadgets.buttons
|
||||
ui.gadgets.packs ui.gadgets.labels tools.deploy.config
|
||||
namespaces ui.gadgets.editors ui.gadgets.borders ui.gestures
|
||||
ui.commands assocs ui.gadgets.tracks ui ui.tools.listener
|
||||
tools.deploy vocabs ui.tools.workspace system accessors ;
|
||||
|
||||
USING: ui.gadgets colors kernel ui.render namespaces models
|
||||
models.mapping sequences ui.gadgets.buttons ui.gadgets.packs
|
||||
ui.gadgets.labels tools.deploy.config namespaces
|
||||
ui.gadgets.editors ui.gadgets.borders ui.gestures ui.commands
|
||||
assocs ui.gadgets.tracks ui ui.tools.listener tools.deploy
|
||||
vocabs ui.tools.workspace system accessors fry ;
|
||||
IN: ui.tools.deploy
|
||||
|
||||
TUPLE: deploy-gadget < pack vocab settings ;
|
||||
|
|
@ -83,7 +82,7 @@ TUPLE: deploy-gadget < pack vocab settings ;
|
|||
|
||||
: com-deploy ( gadget -- )
|
||||
dup com-save
|
||||
dup find-deploy-vocab [ deploy ] curry call-listener
|
||||
dup find-deploy-vocab '[ _ deploy ] call-listener
|
||||
close-window ;
|
||||
|
||||
: com-help ( -- )
|
||||
|
|
|
|||
|
|
@ -7,7 +7,7 @@ quotations sequences strings threads listener classes.tuple
|
|||
ui.commands ui.gadgets ui.gadgets.editors ui.gadgets.status-bar
|
||||
ui.gadgets.presentations ui.gadgets.worlds ui.gestures
|
||||
definitions calendar concurrency.flags concurrency.mailboxes
|
||||
ui.tools.workspace accessors sets destructors ;
|
||||
ui.tools.workspace accessors sets destructors fry ;
|
||||
IN: ui.tools.interactor
|
||||
|
||||
! If waiting is t, we're waiting for user input, and invoking
|
||||
|
|
@ -88,7 +88,7 @@ M: interactor model-changed
|
|||
[ editor-string ] keep
|
||||
[ interactor-input. ] 2keep
|
||||
[ add-interactor-history ] keep
|
||||
[ clear-input ] curry "Clearing input" spawn drop ;
|
||||
'[ _ clear-input ] "Clearing input" spawn drop ;
|
||||
|
||||
: interactor-eof ( interactor -- )
|
||||
dup interactor-busy? [
|
||||
|
|
@ -126,7 +126,7 @@ M: interactor stream-read
|
|||
swap dup zero? [
|
||||
2drop ""
|
||||
] [
|
||||
>r interactor-read dup [ "\n" join ] when r> short head
|
||||
[ interactor-read dup [ "\n" join ] when ] dip short head
|
||||
] if ;
|
||||
|
||||
M: interactor stream-read-partial
|
||||
|
|
|
|||
|
|
@ -28,7 +28,7 @@ M: listener-gadget focusable-child*
|
|||
input>> ;
|
||||
|
||||
M: listener-gadget call-tool* ( input listener -- )
|
||||
>r string>> r> input>> set-editor-string ;
|
||||
[ string>> ] dip input>> set-editor-string ;
|
||||
|
||||
M: listener-gadget tool-scroller
|
||||
output>> find-scroller ;
|
||||
|
|
@ -95,13 +95,13 @@ M: engine-word word-completion-string
|
|||
: use-if-necessary ( word seq -- )
|
||||
over vocabulary>> over and [
|
||||
2dup [ assoc-stack ] keep = [ 2drop ] [
|
||||
>r vocabulary>> vocab-words r> push
|
||||
[ vocabulary>> vocab-words ] dip push
|
||||
] if
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: insert-word ( word -- )
|
||||
get-workspace listener>> input>>
|
||||
[ >r word-completion-string r> user-input* drop ]
|
||||
[ [ word-completion-string ] dip user-input* drop ]
|
||||
[ interactor-use use-if-necessary ]
|
||||
2bi ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: ui.tools.workspace kernel quotations tools.profiler
|
||||
ui.commands ui.gadgets ui.gadgets.panes ui.gadgets.scrollers
|
||||
ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors ;
|
||||
ui.gadgets.tracks ui.gestures ui.gadgets.buttons accessors fry ;
|
||||
IN: ui.tools.profiler
|
||||
|
||||
TUPLE: profiler-gadget < track pane ;
|
||||
|
|
@ -14,7 +14,7 @@ TUPLE: profiler-gadget < track pane ;
|
|||
dup pane>> <scroller> 1 track-add ;
|
||||
|
||||
: with-profiler-pane ( gadget quot -- )
|
||||
>r pane>> r> with-pane ;
|
||||
[ pane>> ] dip with-pane ;
|
||||
|
||||
: com-full-profile ( gadget -- )
|
||||
[ profile. ] with-profiler-pane ;
|
||||
|
|
@ -39,10 +39,10 @@ profiler-gadget "toolbar" f {
|
|||
GENERIC: profiler-presentation ( obj -- quot )
|
||||
|
||||
M: usage-profile profiler-presentation
|
||||
word>> [ usage-profile. ] curry ;
|
||||
word>> '[ _ usage-profile. ] ;
|
||||
|
||||
M: vocab-profile profiler-presentation
|
||||
vocab>> [ vocab-profile. ] curry ;
|
||||
vocab>> '[ _ vocab-profile. ] ;
|
||||
|
||||
M: f profiler-presentation
|
||||
drop [ vocabs-profile. ] ;
|
||||
|
|
|
|||
|
|
@ -19,7 +19,7 @@ IN: ui.tools.search.tests
|
|||
] with-grafted-gadget ;
|
||||
|
||||
: test-live-search ( gadget quot -- ? )
|
||||
>r update-live-search dup assert-non-empty r> all? ;
|
||||
[ update-live-search dup assert-non-empty ] dip all? ;
|
||||
|
||||
[ t ] [
|
||||
"swp" all-words f <definition-search>
|
||||
|
|
|
|||
|
|
@ -9,7 +9,7 @@ ui.gadgets.books ui.gadgets.buttons ui.gadgets.labelled
|
|||
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
|
||||
ui.gadgets.presentations ui.gestures words vocabs.loader
|
||||
tools.test tools.vocabs ui.gadgets.buttons ui.gadgets.status-bar
|
||||
mirrors ;
|
||||
mirrors fry ;
|
||||
IN: ui.tools
|
||||
|
||||
: <workspace-tabs> ( workspace -- tabs )
|
||||
|
|
@ -93,7 +93,7 @@ workspace "workflow" f {
|
|||
] workspace-window-hook set-global
|
||||
|
||||
: inspect-continuation ( traceback -- )
|
||||
control-value [ inspect ] curry call-listener ;
|
||||
control-value '[ _ inspect ] call-listener ;
|
||||
|
||||
traceback-gadget "toolbar" f {
|
||||
{ T{ key-down f f "v" } variables }
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ ui.tools.listener ui.tools.traceback ui.gadgets.buttons
|
|||
ui.gadgets.status-bar ui.gadgets.tracks ui.commands ui.gadgets
|
||||
models models.filter ui.tools.workspace ui.gestures
|
||||
ui.gadgets.labels ui threads namespaces make tools.walker assocs
|
||||
combinators ;
|
||||
combinators fry ;
|
||||
IN: ui.tools.walker
|
||||
|
||||
TUPLE: walker-gadget < track
|
||||
|
|
@ -53,7 +53,7 @@ M: walker-gadget focusable-child*
|
|||
] "" make ;
|
||||
|
||||
: <thread-status> ( model thread -- gadget )
|
||||
[ walker-state-string ] curry <filter> <label-control> ;
|
||||
'[ _ walker-state-string ] <filter> <label-control> ;
|
||||
|
||||
: <walker-gadget> ( status continuation thread -- gadget )
|
||||
{ 0 1 } walker-gadget new-track
|
||||
|
|
@ -89,7 +89,7 @@ walker-gadget "toolbar" f {
|
|||
} cond ;
|
||||
|
||||
: find-walker-window ( thread -- world/f )
|
||||
[ swap walker-for-thread? ] curry find-window ;
|
||||
'[ _ swap walker-for-thread? ] find-window ;
|
||||
|
||||
: walker-window ( status continuation thread -- )
|
||||
[ <walker-gadget> ] [ name>> ] bi open-status-window ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: classes continuations help help.topics kernel models
|
||||
sequences assocs arrays namespaces accessors math.vectors ui
|
||||
sequences assocs arrays namespaces accessors math.vectors fry ui
|
||||
ui.backend ui.tools.debugger ui.gadgets ui.gadgets.books
|
||||
ui.gadgets.buttons ui.gadgets.labelled ui.gadgets.panes
|
||||
ui.gadgets.scrollers ui.gadgets.tracks ui.gadgets.worlds
|
||||
|
|
@ -33,7 +33,7 @@ M: gadget tool-scroller drop f ;
|
|||
set-model ;
|
||||
|
||||
: get-workspace* ( quot -- workspace )
|
||||
[ >r dup workspace? r> [ drop f ] if ] curry find-window
|
||||
'[ dup workspace? _ [ drop f ] if ] find-window
|
||||
[ dup raise-window gadget-child ]
|
||||
[ workspace-window* ] if* ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -288,7 +288,7 @@ SYMBOL: nc-buttons
|
|||
: mouse-wheel ( lParam -- array ) >lo-hi [ sgn neg ] map ;
|
||||
|
||||
: mouse-absolute>relative ( lparam handle -- array )
|
||||
>r >lo-hi r>
|
||||
[ >lo-hi ] dip
|
||||
"RECT" <c-object> [ GetWindowRect win32-error=0/f ] keep
|
||||
get-RECT-top-left 2array v- ;
|
||||
|
||||
|
|
@ -297,7 +297,7 @@ SYMBOL: nc-buttons
|
|||
[ <button-down> ] [ <button-up> ] if ;
|
||||
|
||||
: prepare-mouse ( hWnd uMsg wParam lParam -- button coordinate world )
|
||||
nip >r mouse-event>gesture r> >lo-hi rot window ;
|
||||
[ drop mouse-event>gesture ] dip >lo-hi rot window ;
|
||||
|
||||
: set-capture ( hwnd -- )
|
||||
mouse-captured get [
|
||||
|
|
@ -312,10 +312,10 @@ SYMBOL: nc-buttons
|
|||
mouse-captured off ;
|
||||
|
||||
: handle-wm-buttondown ( hWnd uMsg wParam lParam -- )
|
||||
>r >r
|
||||
over set-capture
|
||||
dup message>button drop nc-buttons get delete
|
||||
r> r> prepare-mouse send-button-down ;
|
||||
[
|
||||
over set-capture
|
||||
dup message>button drop nc-buttons get delete
|
||||
] 2dip prepare-mouse send-button-down ;
|
||||
|
||||
: handle-wm-buttonup ( hWnd uMsg wParam lParam -- )
|
||||
mouse-captured get [ release-capture ] when
|
||||
|
|
@ -337,9 +337,10 @@ SYMBOL: nc-buttons
|
|||
TrackMouseEvent drop
|
||||
>lo-hi swap window move-hand fire-motion ;
|
||||
|
||||
: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
|
||||
>r nip r>
|
||||
pick mouse-absolute>relative >r mouse-wheel r> rot window send-wheel ;
|
||||
:: handle-wm-mousewheel ( hWnd uMsg wParam lParam -- )
|
||||
lParam mouse-wheel
|
||||
hWnd mouse-absolute>relative
|
||||
hWnd window send-wheel ;
|
||||
|
||||
: handle-wm-cancelmode ( hWnd uMsg wParam lParam -- )
|
||||
#! message sent if windows needs application to stop dragging
|
||||
|
|
@ -456,10 +457,11 @@ M: windows-ui-backend do-events
|
|||
|
||||
: create-window ( rect -- hwnd )
|
||||
make-adjusted-RECT
|
||||
>r class-name-ptr get-global f r>
|
||||
>r >r >r ex-style r> r>
|
||||
[ class-name-ptr get-global f ] dip
|
||||
[
|
||||
[ ex-style ] 2dip
|
||||
{ WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags
|
||||
r> get-RECT-dimensions
|
||||
] dip get-RECT-dimensions
|
||||
f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ;
|
||||
|
||||
: show-window ( hWnd -- )
|
||||
|
|
@ -515,7 +517,7 @@ M: windows-ui-backend raise-window* ( world -- )
|
|||
M: windows-ui-backend set-title ( string world -- )
|
||||
handle>>
|
||||
dup title>> [ free ] when*
|
||||
>r utf16n malloc-string r>
|
||||
[ utf16n malloc-string ] dip
|
||||
2dup (>>title)
|
||||
hWnd>> WM_SETTEXT 0 roll alien-address SendMessage drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -79,7 +79,7 @@ M: world configure-event
|
|||
: key-down-event>gesture ( event world -- string gesture )
|
||||
dupd
|
||||
handle>> xic>> lookup-string
|
||||
>r swap event-modifiers r> key-code <key-down> ;
|
||||
[ swap event-modifiers ] dip key-code <key-down> ;
|
||||
|
||||
M: world key-down-event
|
||||
[ key-down-event>gesture ] keep
|
||||
|
|
@ -92,18 +92,18 @@ M: world key-down-event
|
|||
dup event-modifiers swap 0 XLookupKeysym key-code <key-up> ;
|
||||
|
||||
M: world key-up-event
|
||||
>r key-up-event>gesture r> world-focus propagate-gesture ;
|
||||
[ key-up-event>gesture ] dip world-focus propagate-gesture ;
|
||||
|
||||
: mouse-event>gesture ( event -- modifiers button loc )
|
||||
dup event-modifiers over XButtonEvent-button
|
||||
rot mouse-event-loc ;
|
||||
|
||||
M: world button-down-event
|
||||
>r mouse-event>gesture >r <button-down> r> r>
|
||||
[ mouse-event>gesture [ <button-down> ] dip ] dip
|
||||
send-button-down ;
|
||||
|
||||
M: world button-up-event
|
||||
>r mouse-event>gesture >r <button-up> r> r>
|
||||
[ mouse-event>gesture [ <button-up> ] dip ] dip
|
||||
send-button-up ;
|
||||
|
||||
: mouse-event>scroll-direction ( event -- pair )
|
||||
|
|
@ -115,7 +115,7 @@ M: world button-up-event
|
|||
} at ;
|
||||
|
||||
M: world wheel-event
|
||||
>r dup mouse-event>scroll-direction swap mouse-event-loc r>
|
||||
[ dup mouse-event>scroll-direction swap mouse-event-loc ] dip
|
||||
send-wheel ;
|
||||
|
||||
M: world enter-event motion-event ;
|
||||
|
|
@ -123,7 +123,7 @@ M: world enter-event motion-event ;
|
|||
M: world leave-event 2drop forget-rollover ;
|
||||
|
||||
M: world motion-event
|
||||
>r dup XMotionEvent-x swap XMotionEvent-y 2array r>
|
||||
[ dup XMotionEvent-x swap XMotionEvent-y 2array ] dip
|
||||
move-hand fire-motion ;
|
||||
|
||||
M: world focus-in-event
|
||||
|
|
@ -158,7 +158,7 @@ M: world selection-notify-event
|
|||
[ XSelectionRequestEvent-requestor ] keep
|
||||
[ XSelectionRequestEvent-property ] keep
|
||||
[ XSelectionRequestEvent-target ] keep
|
||||
>r 8 PropModeReplace r>
|
||||
[ 8 PropModeReplace ] dip
|
||||
[
|
||||
XSelectionRequestEvent-selection
|
||||
clipboard-for-atom contents>>
|
||||
|
|
@ -208,8 +208,7 @@ M: x-clipboard copy-clipboard
|
|||
(>>contents) ;
|
||||
|
||||
M: x-clipboard paste-clipboard
|
||||
>r find-world handle>> window>>
|
||||
r> atom>> convert-selection ;
|
||||
[ find-world handle>> window>> ] dip atom>> convert-selection ;
|
||||
|
||||
: init-clipboard ( -- )
|
||||
XA_PRIMARY <x-clipboard> selection set-global
|
||||
|
|
@ -219,14 +218,13 @@ M: x-clipboard paste-clipboard
|
|||
dup [ 127 <= ] all? [ XStoreName drop ] [ 3drop ] if ;
|
||||
|
||||
: set-title-new ( dpy window string -- )
|
||||
>r
|
||||
XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace
|
||||
r> utf8 encode dup length XChangeProperty drop ;
|
||||
[ XA_NET_WM_NAME XA_UTF8_STRING 8 PropModeReplace ] dip
|
||||
utf8 encode dup length XChangeProperty drop ;
|
||||
|
||||
M: x11-ui-backend set-title ( string world -- )
|
||||
handle>> window>> swap dpy get -rot
|
||||
3dup set-title-old set-title-new ;
|
||||
|
||||
|
||||
M: x11-ui-backend set-fullscreen* ( ? world -- )
|
||||
handle>> window>> "XClientMessageEvent" <c-object>
|
||||
tuck set-XClientMessageEvent-window
|
||||
|
|
@ -237,8 +235,7 @@ M: x11-ui-backend set-fullscreen* ( ? world -- )
|
|||
"_NET_WM_STATE" x-atom over set-XClientMessageEvent-message_type
|
||||
32 over set-XClientMessageEvent-format
|
||||
"_NET_WM_STATE_FULLSCREEN" x-atom over set-XClientMessageEvent-data1
|
||||
>r dpy get root get 0 SubstructureNotifyMask r> XSendEvent drop ;
|
||||
|
||||
[ dpy get root get 0 SubstructureNotifyMask ] dip XSendEvent drop ;
|
||||
|
||||
M: x11-ui-backend (open-window) ( world -- )
|
||||
dup gadget-window
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
|
||||
USING: kernel arrays alien alien.c-types alien.strings
|
||||
alien.syntax math math.bitwise words sequences namespaces
|
||||
continuations io.encodings.ascii ;
|
||||
continuations io io.encodings.ascii ;
|
||||
IN: x11.xlib
|
||||
|
||||
LIBRARY: xlib
|
||||
|
|
@ -1359,8 +1359,8 @@ SYMBOL: scr
|
|||
SYMBOL: root
|
||||
|
||||
: init-locale ( -- )
|
||||
LC_ALL "" setlocale [ "setlocale() failed" throw ] unless
|
||||
XSupportsLocale [ "XSupportsLocale() failed" throw ] unless ;
|
||||
LC_ALL "" setlocale [ "setlocale() failed" print flush ] unless
|
||||
XSupportsLocale [ "XSupportsLocale() failed" print flush ] unless ;
|
||||
|
||||
: flush-dpy ( -- ) dpy get XFlush drop ;
|
||||
|
||||
|
|
@ -1381,4 +1381,4 @@ SYMBOL: root
|
|||
: close-x ( -- ) dpy get XCloseDisplay drop ;
|
||||
|
||||
: with-x ( display-string quot -- )
|
||||
>r initialize-x r> [ close-x ] [ ] cleanup ;
|
||||
[ initialize-x ] dip [ close-x ] [ ] cleanup ;
|
||||
|
|
|
|||
|
|
@ -534,6 +534,7 @@ tuple
|
|||
{ "unimplemented" "kernel.private" }
|
||||
{ "gc-reset" "memory" }
|
||||
{ "jit-compile" "quotations" }
|
||||
{ "load-locals" "locals.backend" }
|
||||
}
|
||||
[ [ first2 ] dip make-primitive ] each-index
|
||||
|
||||
|
|
|
|||
|
|
@ -165,3 +165,19 @@ HELP: (call-next-method)
|
|||
{ $values { "method" method-body } }
|
||||
{ $description "Low-level word implementing " { $link POSTPONE: call-next-method } "." }
|
||||
{ $notes "In most cases, " { $link POSTPONE: call-next-method } " should be used instead." } ;
|
||||
|
||||
HELP: no-next-method
|
||||
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
|
||||
{ $examples
|
||||
"The following code throws this error:"
|
||||
{ $code
|
||||
"GENERIC: error-test ( object -- )"
|
||||
""
|
||||
"M: number error-test 3 + call-next-method ;"
|
||||
""
|
||||
"M: integer error-test recip call-next-method ;"
|
||||
""
|
||||
"123 error-test"
|
||||
}
|
||||
"This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
|
||||
} ;
|
||||
|
|
|
|||
|
|
@ -58,8 +58,10 @@ GENERIC: next-method-quot* ( class generic combination -- quot )
|
|||
] bi next-method-quot*
|
||||
] cache ;
|
||||
|
||||
ERROR: no-next-method method ;
|
||||
|
||||
: (call-next-method) ( method -- )
|
||||
next-method-quot call ;
|
||||
dup next-method-quot [ call ] [ no-next-method ] ?if ;
|
||||
|
||||
TUPLE: check-method class generic ;
|
||||
|
||||
|
|
|
|||
|
|
@ -33,22 +33,6 @@ HELP: define-simple-generic
|
|||
|
||||
{ standard-combination hook-combination } related-words
|
||||
|
||||
HELP: no-next-method
|
||||
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the current method is already the least specific method." }
|
||||
{ $examples
|
||||
"The following code throws this error:"
|
||||
{ $code
|
||||
"GENERIC: error-test ( object -- )"
|
||||
""
|
||||
"M: number error-test 3 + call-next-method ;"
|
||||
""
|
||||
"M: integer error-test recip call-next-method ;"
|
||||
""
|
||||
"123 error-test"
|
||||
}
|
||||
"This results in the method on " { $link integer } " being called, which then calls the method on " { $link number } ". The latter then calls " { $link POSTPONE: call-next-method } ", however there is no method less specific than the method on " { $link number } " and so an error is thrown."
|
||||
} ;
|
||||
|
||||
HELP: inconsistent-next-method
|
||||
{ $error-description "Thrown by " { $link POSTPONE: call-next-method } " if the values on the stack are not compatible with the current method." }
|
||||
{ $examples
|
||||
|
|
|
|||
|
|
@ -200,7 +200,7 @@ M: ceo salary
|
|||
[ T{ inconsistent-next-method f ceo salary } = ] must-fail-with
|
||||
|
||||
[ intern boa salary ]
|
||||
[ T{ no-next-method f intern salary } = ] must-fail-with
|
||||
[ no-next-method? ] must-fail-with
|
||||
|
||||
! Weird shit
|
||||
TUPLE: a ;
|
||||
|
|
|
|||
|
|
@ -79,20 +79,15 @@ ERROR: no-method object generic ;
|
|||
|
||||
ERROR: inconsistent-next-method class generic ;
|
||||
|
||||
ERROR: no-next-method class generic ;
|
||||
|
||||
: single-next-method-quot ( class generic -- quot )
|
||||
[
|
||||
[ drop "predicate" word-prop % ]
|
||||
: single-next-method-quot ( class generic -- quot/f )
|
||||
2dup next-method dup [
|
||||
[
|
||||
2dup next-method
|
||||
[ 2nip 1quotation ]
|
||||
[ [ no-next-method ] 2curry [ ] like ] if* ,
|
||||
]
|
||||
[ [ inconsistent-next-method ] 2curry , ]
|
||||
2tri
|
||||
\ if ,
|
||||
] [ ] make ;
|
||||
pick "predicate" word-prop %
|
||||
1quotation ,
|
||||
[ inconsistent-next-method ] 2curry ,
|
||||
\ if ,
|
||||
] [ ] make
|
||||
] [ 3drop f ] if ;
|
||||
|
||||
: single-effective-method ( obj word -- method )
|
||||
[ [ order [ instance? ] with find-last nip ] keep method ]
|
||||
|
|
@ -130,7 +125,8 @@ M: standard-combination method-declaration
|
|||
|
||||
M: standard-combination next-method-quot*
|
||||
[
|
||||
single-next-method-quot picker prepend
|
||||
single-next-method-quot
|
||||
dup [ picker prepend ] when
|
||||
] with-standard ;
|
||||
|
||||
M: standard-generic effective-method
|
||||
|
|
@ -145,9 +141,12 @@ PREDICATE: hook-generic < generic
|
|||
|
||||
: with-hook ( combination quot -- quot' )
|
||||
0 (dispatch#) [
|
||||
dip var>> [ get ] curry prepend
|
||||
[ hook-combination ] dip with-variable
|
||||
] with-variable ; inline
|
||||
|
||||
: prepend-hook-var ( quot -- quot' )
|
||||
hook-combination get var>> [ get ] curry prepend ;
|
||||
|
||||
M: hook-combination dispatch# drop 0 ;
|
||||
|
||||
M: hook-combination method-declaration 2drop [ ] ;
|
||||
|
|
@ -159,13 +158,18 @@ M: hook-generic effective-method
|
|||
single-effective-method ;
|
||||
|
||||
M: hook-combination make-default-method
|
||||
[ error-method ] with-hook ;
|
||||
[ error-method prepend-hook-var ] with-hook ;
|
||||
|
||||
M: hook-combination perform-combination
|
||||
[ drop ] [ [ single-combination ] with-hook ] 2bi define ;
|
||||
[ drop ] [
|
||||
[ single-combination prepend-hook-var ] with-hook
|
||||
] 2bi define ;
|
||||
|
||||
M: hook-combination next-method-quot*
|
||||
[ single-next-method-quot ] with-hook ;
|
||||
[
|
||||
single-next-method-quot
|
||||
dup [ prepend-hook-var ] when
|
||||
] with-hook ;
|
||||
|
||||
M: simple-generic definer drop \ GENERIC: f ;
|
||||
|
||||
|
|
|
|||
|
|
@ -41,7 +41,6 @@ SYMBOL: visited
|
|||
] if ;
|
||||
|
||||
: draw-maze ( n -- )
|
||||
-0.5 0.5 0 glTranslated
|
||||
line-width 2 - glLineWidth
|
||||
line-width 2 - glPointSize
|
||||
1.0 1.0 1.0 1.0 glColor4d
|
||||
|
|
|
|||
339
misc/factor.el
339
misc/factor.el
|
|
@ -89,6 +89,11 @@ buffer."
|
|||
:type 'boolean
|
||||
:group 'factor)
|
||||
|
||||
(defcustom factor-help-use-minibuffer t
|
||||
"When enabled, use the minibuffer for short help messages."
|
||||
:type 'boolean
|
||||
:group 'factor)
|
||||
|
||||
(defcustom factor-display-compilation-output t
|
||||
"Display the REPL buffer before compiling files."
|
||||
:type 'boolean
|
||||
|
|
@ -195,11 +200,14 @@ buffer."
|
|||
(defconst factor--regex-symbol-definition
|
||||
(factor--regex-second-word '("SYMBOL:")))
|
||||
|
||||
(defconst factor--regex-stack-effect " ( .* )")
|
||||
|
||||
(defconst factor--regex-using-line "^USING: +\\([^;]*\\);")
|
||||
|
||||
(defconst factor--regex-use-line "^USE: +\\(.*\\)$")
|
||||
|
||||
(defconst factor--font-lock-keywords
|
||||
`(("( .* )" . 'factor-font-lock-stack-effect)
|
||||
`((,factor--regex-stack-effect . 'factor-font-lock-stack-effect)
|
||||
("\\(P\\|SBUF\\)\"" 1 'factor-font-lock-parsing-word)
|
||||
,@(mapcar #'(lambda (w) (cons (concat "\\(^\\| \\)\\(" w "\\)\\($\\| \\)")
|
||||
'(2 'factor-font-lock-parsing-word)))
|
||||
|
|
@ -218,16 +226,19 @@ buffer."
|
|||
|
||||
;;; Factor mode syntax:
|
||||
|
||||
(defconst factor--regexp-word-starters
|
||||
(regexp-opt '("TUPLE" "MACRO" "MACRO:" "M" ":" "")))
|
||||
|
||||
(defconst factor--regexp-word-start
|
||||
(let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
|
||||
(format "^\\(%s\\)\\(:\\) " (regexp-opt sws))))
|
||||
(format "^\\(%s:\\) " factor--regexp-word-starters))
|
||||
|
||||
(defconst factor--font-lock-syntactic-keywords
|
||||
`(("^\\(:\\)\\(:\\)" (1 ".") (2 "(;"))
|
||||
(,factor--regexp-word-start (2 "(;"))
|
||||
`((,(format "^\\(%s\\)\\(:\\)" factor--regexp-word-starters)
|
||||
(1 "w") (2 "(;"))
|
||||
("\\(;\\)" (1 "):"))
|
||||
("\\(#!\\)" (1 "<"))
|
||||
("\\(!\\)" (1 "<"))
|
||||
(" \\(!\\)" (1 "<"))
|
||||
("^\\(!\\)" (1 "<"))
|
||||
("\\(!(\\) .* \\()\\)" (1 "<") (2 ">"))))
|
||||
|
||||
(defvar factor-mode-syntax-table nil
|
||||
|
|
@ -279,6 +290,25 @@ buffer."
|
|||
(modify-syntax-entry ?\" "\"" factor-mode-syntax-table)
|
||||
(modify-syntax-entry ?\\ "/" factor-mode-syntax-table)))
|
||||
|
||||
;;; symbol-at-point
|
||||
|
||||
(defun factor--beginning-of-symbol ()
|
||||
"Move point to the beginning of the current symbol."
|
||||
(while (eq (char-before) ?:) (backward-char))
|
||||
(skip-syntax-backward "w_"))
|
||||
|
||||
(defun factor--end-of-symbol ()
|
||||
"Move point to the end of the current symbol."
|
||||
(skip-syntax-forward "w_")
|
||||
(while (looking-at ":") (forward-char)))
|
||||
|
||||
(put 'factor-symbol 'end-op 'factor--end-of-symbol)
|
||||
(put 'factor-symbol 'beginning-op 'factor--beginning-of-symbol)
|
||||
|
||||
(defsubst factor--symbol-at-point ()
|
||||
(let ((s (substring-no-properties (thing-at-point 'factor-symbol))))
|
||||
(and (> (length s) 0) s)))
|
||||
|
||||
|
||||
;;; Factor mode indentation:
|
||||
|
||||
|
|
@ -414,7 +444,83 @@ buffer."
|
|||
(goto-char (- (point-max) pos))))))
|
||||
|
||||
|
||||
;;; Factor mode commands:
|
||||
;; Factor mode:
|
||||
(defvar factor-mode-map (make-sparse-keymap)
|
||||
"Key map used by Factor mode.")
|
||||
|
||||
;;;###autoload
|
||||
(defun factor-mode ()
|
||||
"A mode for editing programs written in the Factor programming language.
|
||||
\\{factor-mode-map}"
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(use-local-map factor-mode-map)
|
||||
(setq major-mode 'factor-mode)
|
||||
(setq mode-name "Factor")
|
||||
;; Font locking
|
||||
(set (make-local-variable 'comment-start) "! ")
|
||||
(set (make-local-variable 'parse-sexp-lookup-properties) t)
|
||||
(set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
|
||||
(set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
|
||||
(set (make-local-variable 'font-lock-defaults)
|
||||
`(factor--font-lock-keywords
|
||||
nil nil nil nil
|
||||
(font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords)))
|
||||
|
||||
(set-syntax-table factor-mode-syntax-table)
|
||||
;; Defun navigation
|
||||
(setq defun-prompt-regexp "[^ :]+")
|
||||
(set (make-local-variable 'open-paren-in-column-0-is-defun-start) t)
|
||||
;; Indentation
|
||||
(set (make-local-variable 'indent-line-function) 'factor--indent-line)
|
||||
(setq factor-indent-width (factor--guess-indent-width))
|
||||
(setq indent-tabs-mode nil)
|
||||
;; ElDoc
|
||||
(set (make-local-variable 'eldoc-documentation-function) 'factor--eldoc)
|
||||
|
||||
(run-hooks 'factor-mode-hook))
|
||||
|
||||
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
|
||||
|
||||
|
||||
;;; Factor listener mode:
|
||||
|
||||
;;;###autoload
|
||||
(define-derived-mode factor-listener-mode comint-mode "Factor Listener"
|
||||
"Major mode for interacting with an inferior Factor listener process.
|
||||
\\{factor-listener-mode-map}"
|
||||
(set (make-local-variable 'comint-prompt-regexp) "^( [^)]+ ) "))
|
||||
|
||||
(defvar factor--listener-buffer nil
|
||||
"The buffer in which the Factor listener is running.")
|
||||
|
||||
(defun factor--listener-start-process ()
|
||||
"Start an inferior Factor listener process, using
|
||||
`factor-binary' and `factor-image'."
|
||||
(setq factor--listener-buffer
|
||||
(apply 'make-comint "factor" (expand-file-name factor-binary) nil
|
||||
`("-run=listener" ,(format "-i=%s" (expand-file-name factor-image)))))
|
||||
(with-current-buffer factor--listener-buffer
|
||||
(factor-listener-mode)))
|
||||
|
||||
(defun factor--listener-process (&optional start)
|
||||
(or (and (buffer-live-p factor--listener-buffer)
|
||||
(get-buffer-process factor--listener-buffer))
|
||||
(when start
|
||||
(factor--listener-start-process)
|
||||
(factor--listener-process t))))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'switch-to-factor 'run-factor)
|
||||
;;;###autoload
|
||||
(defun run-factor (&optional arg)
|
||||
"Show the factor-listener buffer, starting the process if needed."
|
||||
(interactive)
|
||||
(let ((buf (process-buffer (factor--listener-process t)))
|
||||
(pop-up-windows factor-listener-window-allow-split))
|
||||
(if factor-listener-use-other-window
|
||||
(pop-to-buffer buf)
|
||||
(switch-to-buffer buf))))
|
||||
|
||||
(defun factor-telnet-to-port (port)
|
||||
(interactive "nPort: ")
|
||||
|
|
@ -429,21 +535,125 @@ buffer."
|
|||
(interactive)
|
||||
(factor-telnet-to-port 9010))
|
||||
|
||||
|
||||
;;; Factor listener interaction:
|
||||
|
||||
(defun factor--listener-send-cmd (cmd)
|
||||
(let ((proc (factor--listener-process)))
|
||||
(when proc
|
||||
(let* ((out (get-buffer-create "*factor messages*"))
|
||||
(beg (with-current-buffer out (goto-char (point-max)))))
|
||||
(comint-redirect-send-command-to-process cmd out proc nil t)
|
||||
(with-current-buffer factor--listener-buffer
|
||||
(while (not comint-redirect-completed) (sleep-for 0 1)))
|
||||
(with-current-buffer out
|
||||
(split-string (buffer-substring-no-properties beg (point-max))
|
||||
"[\"\f\n\r\v]+" t))))))
|
||||
|
||||
;;;;; Current vocabulary:
|
||||
(make-variable-buffer-local
|
||||
(defvar factor--current-vocab nil
|
||||
"Current vocabulary."))
|
||||
|
||||
(defconst factor--regexp-current-vocab "^IN: +\\([^ \r\n\f]+\\)")
|
||||
|
||||
(defun factor--current-buffer-vocab ()
|
||||
(save-excursion
|
||||
(when (or (re-search-backward factor--regexp-current-vocab nil t)
|
||||
(re-search-forward factor--regexp-current-vocab nil t))
|
||||
(setq factor--current-vocab (match-string-no-properties 1)))))
|
||||
|
||||
(defun factor--current-listener-vocab ()
|
||||
(car (factor--listener-send-cmd "USING: parser ; in get .")))
|
||||
|
||||
|
||||
(defun factor--set-current-listener-vocab (&optional vocab)
|
||||
(factor--listener-send-cmd
|
||||
(format "IN: %s" (or vocab (factor--current-buffer-vocab))))
|
||||
t)
|
||||
|
||||
(defmacro factor--with-vocab (vocab &rest body)
|
||||
(let ((current (make-symbol "current")))
|
||||
`(let ((,current (factor--current-listener-vocab)))
|
||||
(factor--set-current-listener-vocab ,vocab)
|
||||
(prog1 (condition-case nil (progn . ,body) (error nil))
|
||||
(factor--set-current-listener-vocab ,current)))))
|
||||
|
||||
(put 'factor--with-vocab 'lisp-indent-function 1)
|
||||
|
||||
;;;;; Synchronous interaction:
|
||||
|
||||
(defsubst factor--listener-vocab-cmds (cmds &optional vocab)
|
||||
(factor--with-vocab vocab
|
||||
(mapcar #'factor--listener-send-cmd cmds)))
|
||||
|
||||
(defsubst factor--listener-vocab-cmd (cmd &optional vocab)
|
||||
(factor--with-vocab vocab
|
||||
(factor--listener-send-cmd cmd)))
|
||||
|
||||
;;;;; Interface: see
|
||||
|
||||
(defconst factor--regex-error-marker "^Type :help for debugging")
|
||||
(defconst factor--regex-data-stack "^--- Data stack:")
|
||||
|
||||
(defun factor--prune-ans-strings (ans)
|
||||
(nreverse
|
||||
(catch 'done
|
||||
(let ((res))
|
||||
(dolist (a ans res)
|
||||
(cond ((string-match factor--regex-stack-effect a)
|
||||
(throw 'done (cons a res)))
|
||||
((string-match factor--regex-data-stack a)
|
||||
(throw 'done res))
|
||||
((string-match factor--regex-error-marker a)
|
||||
(throw 'done nil))
|
||||
(t (push a res))))))))
|
||||
|
||||
(defun factor--see-ans-to-string (ans)
|
||||
(let ((s (mapconcat #'identity (factor--prune-ans-strings ans) " "))
|
||||
(font-lock-verbose nil))
|
||||
(and (> (length s) 0)
|
||||
(with-temp-buffer
|
||||
(insert s)
|
||||
(factor-mode)
|
||||
(font-lock-fontify-buffer)
|
||||
(buffer-string)))))
|
||||
|
||||
(defun factor--see-current-word (&optional word)
|
||||
(let ((word (or word (factor--symbol-at-point))))
|
||||
(when word
|
||||
(let ((answer (factor--listener-send-cmd (format "\\ %s see" word))))
|
||||
(and answer (factor--see-ans-to-string answer))))))
|
||||
|
||||
(defalias 'factor--eldoc 'factor--see-current-word)
|
||||
|
||||
(defun factor-see-current-word (&optional word)
|
||||
"Echo in the minibuffer information about word at point."
|
||||
(interactive)
|
||||
(unless (factor--listener-process)
|
||||
(error "No factor listener running. Try M-x run-factor"))
|
||||
(let ((word (or word (factor--symbol-at-point)))
|
||||
(msg (factor--see-current-word word)))
|
||||
(if msg (message "%s" msg)
|
||||
(if word (message "No help found for '%s'" word)
|
||||
(message "No word at point")))))
|
||||
|
||||
;;; to fix:
|
||||
(defun factor-run-file ()
|
||||
(interactive)
|
||||
(when (and (buffer-modified-p)
|
||||
(y-or-n-p (format "Save file %s? " (buffer-file-name))))
|
||||
(save-buffer))
|
||||
(y-or-n-p (format "Save file %s? " (buffer-file-name))))
|
||||
(save-buffer))
|
||||
(when factor-display-compilation-output
|
||||
(factor-display-output-buffer))
|
||||
(factor-display-output-buffer))
|
||||
(comint-send-string "*factor*" (format "\"%s\"" (buffer-file-name)))
|
||||
(comint-send-string "*factor*" " run-file\n"))
|
||||
|
||||
(defun factor-display-output-buffer ()
|
||||
(with-current-buffer "*factor*"
|
||||
(goto-char (point-max))
|
||||
(unless (get-buffer-window (current-buffer) t)
|
||||
(display-buffer (current-buffer) t))))
|
||||
(goto-char (point-max))
|
||||
(unless (get-buffer-window (current-buffer) t)
|
||||
(display-buffer (current-buffer) t))))
|
||||
|
||||
(defun factor-send-string (str)
|
||||
(let ((n (length (split-string str "\n"))))
|
||||
|
|
@ -485,83 +695,6 @@ buffer."
|
|||
(beginning-of-line)
|
||||
(insert "! "))
|
||||
|
||||
(defvar factor-mode-map (make-sparse-keymap)
|
||||
"Key map used by Factor mode.")
|
||||
|
||||
|
||||
;; Factor mode:
|
||||
|
||||
;;;###autoload
|
||||
(defun factor-mode ()
|
||||
"A mode for editing programs written in the Factor programming language.
|
||||
\\{factor-mode-map}"
|
||||
(interactive)
|
||||
(kill-all-local-variables)
|
||||
(use-local-map factor-mode-map)
|
||||
(setq major-mode 'factor-mode)
|
||||
(setq mode-name "Factor")
|
||||
;; Font locking
|
||||
(set (make-local-variable 'comment-start) "! ")
|
||||
(set (make-local-variable 'parse-sexp-lookup-properties) t)
|
||||
(set (make-local-variable 'font-lock-comment-face) 'factor-font-lock-comment)
|
||||
(set (make-local-variable 'font-lock-string-face) 'factor-font-lock-string)
|
||||
(set (make-local-variable 'font-lock-defaults)
|
||||
`(factor--font-lock-keywords
|
||||
nil nil nil nil
|
||||
(font-lock-syntactic-keywords . ,factor--font-lock-syntactic-keywords)))
|
||||
|
||||
(set-syntax-table factor-mode-syntax-table)
|
||||
;; Defun navigation
|
||||
(setq defun-prompt-regexp "[^ :]+")
|
||||
(set (make-local-variable 'open-paren-in-column-0-is-defun-start) t)
|
||||
;; Indentation
|
||||
(set (make-local-variable 'indent-line-function) 'factor--indent-line)
|
||||
(setq factor-indent-width (factor--guess-indent-width))
|
||||
(setq indent-tabs-mode nil)
|
||||
|
||||
(run-hooks 'factor-mode-hook))
|
||||
|
||||
(add-to-list 'auto-mode-alist '("\\.factor\\'" . factor-mode))
|
||||
|
||||
|
||||
;;; Factor listener mode:
|
||||
|
||||
;;;###autoload
|
||||
(define-derived-mode factor-listener-mode comint-mode "Factor Listener"
|
||||
"Major mode for interacting with an inferior Factor listener process.
|
||||
\\{factor-listener-mode-map}"
|
||||
(set (make-local-variable 'comint-prompt-regexp) "^( [^)]+ ) "))
|
||||
|
||||
(defvar factor--listener-buffer nil
|
||||
"The buffer in which the Factor listener is running.")
|
||||
|
||||
(defun factor--listener-start-process ()
|
||||
"Start an inferior Factor listener process, using
|
||||
`factor-binary' and `factor-image'."
|
||||
(setq factor--listener-buffer
|
||||
(apply 'make-comint "factor" (expand-file-name factor-binary) nil
|
||||
`("-run=listener" ,(format "-i=%s" (expand-file-name factor-image)))))
|
||||
(with-current-buffer factor--listener-buffer
|
||||
(factor-listener-mode)))
|
||||
|
||||
(defun factor--listener-process ()
|
||||
(or (and (buffer-live-p factor--listener-buffer)
|
||||
(get-buffer-process factor--listener-buffer))
|
||||
(progn (factor--listener-start-process)
|
||||
(factor--listener-process))))
|
||||
|
||||
;;;###autoload
|
||||
(defalias 'switch-to-factor 'run-factor)
|
||||
;;;###autoload
|
||||
(defun run-factor (&optional arg)
|
||||
"Show the factor-listener buffer, starting the process if needed."
|
||||
(interactive)
|
||||
(let ((buf (process-buffer (factor--listener-process)))
|
||||
(pop-up-windows factor-listener-window-allow-split))
|
||||
(if factor-listener-use-other-window
|
||||
(pop-to-buffer buf)
|
||||
(switch-to-buffer buf))))
|
||||
|
||||
|
||||
;;;; Factor help mode:
|
||||
|
||||
|
|
@ -611,16 +744,18 @@ buffer."
|
|||
|
||||
(defun factor--listener-help-buffer ()
|
||||
(with-current-buffer (get-buffer-create "*factor-help*")
|
||||
(let ((inhibit-read-only t))
|
||||
(delete-region (point-min) (point-max)))
|
||||
(let ((inhibit-read-only t)) (erase-buffer))
|
||||
(factor-help-mode)
|
||||
(current-buffer)))
|
||||
|
||||
(defvar factor--help-history nil)
|
||||
|
||||
(defun factor--listener-show-help (&optional see)
|
||||
(let* ((def (thing-at-point 'sexp))
|
||||
(prompt (format "%s (%s): " (if see "See" "Help") def))
|
||||
(unless (factor--listener-process)
|
||||
(error "No running factor listener. Try M-x run-factor"))
|
||||
(let* ((def (factor--symbol-at-point))
|
||||
(prompt (format "See%s help on%s: " (if see " short" "")
|
||||
(if def (format " (%s)" def) "")))
|
||||
(ask (or (not (eq major-mode 'factor-mode))
|
||||
(not def)
|
||||
factor-help-always-ask))
|
||||
|
|
@ -633,11 +768,21 @@ buffer."
|
|||
(pop-to-buffer hb)
|
||||
(beginning-of-buffer hb)))
|
||||
|
||||
(defun factor-see ()
|
||||
(interactive)
|
||||
(factor--listener-show-help t))
|
||||
;;;; Interface: see/help commands
|
||||
|
||||
(defun factor-see (&optional arg)
|
||||
"See a help summary of symbol at point.
|
||||
By default, the information is shown in the minibuffer. When
|
||||
called with a prefix argument, the information is displayed in a
|
||||
separate help buffer."
|
||||
(interactive "P")
|
||||
(if (if factor-help-use-minibuffer (not arg) arg)
|
||||
(factor-see-current-word)
|
||||
(factor--listener-show-help t)))
|
||||
|
||||
(defun factor-help ()
|
||||
"Show extended help about the symbol at point, using a help
|
||||
buffer."
|
||||
(interactive)
|
||||
(factor--listener-show-help))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
include vm/Config.macosx
|
||||
include vm/Config.x86.64
|
||||
CFLAGS += -arch x86_64
|
||||
CFLAGS += -m64
|
||||
|
|
|
|||
|
|
@ -985,6 +985,7 @@ void primitive_become(void)
|
|||
}
|
||||
|
||||
gc();
|
||||
iterate_code_heap(relocate_code_block);
|
||||
}
|
||||
|
||||
CELL find_all_words(void)
|
||||
|
|
|
|||
|
|
@ -129,7 +129,7 @@ void print_nested_obj(CELL obj, F_FIXNUM nesting)
|
|||
print_string(" ]");
|
||||
break;
|
||||
default:
|
||||
print_string("#<type "); print_cell(type_of(obj)); print_string(" @ "); print_cell_hex(obj);
|
||||
print_string("#<type "); print_cell(type_of(obj)); print_string(" @ "); print_cell_hex(obj); print_string(">");
|
||||
break;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -141,4 +141,5 @@ void *primitives[] = {
|
|||
primitive_unimplemented,
|
||||
primitive_gc_reset,
|
||||
primitive_jit_compile,
|
||||
primitive_load_locals,
|
||||
};
|
||||
|
|
|
|||
8
vm/run.c
8
vm/run.c
|
|
@ -190,3 +190,11 @@ void primitive_set_slot(void)
|
|||
CELL value = dpop();
|
||||
set_slot(obj,slot,value);
|
||||
}
|
||||
|
||||
void primitive_load_locals(void)
|
||||
{
|
||||
F_FIXNUM count = untag_fixnum_fast(dpop());
|
||||
memcpy((CELL *)(rs + CELLS),(CELL *)(ds - CELLS * (count - 1)),CELLS * count);
|
||||
ds -= CELLS * count;
|
||||
rs += CELLS * count;
|
||||
}
|
||||
|
|
|
|||
1
vm/run.h
1
vm/run.h
|
|
@ -247,5 +247,6 @@ void primitive_set_os_envs(void);
|
|||
void primitive_micros(void);
|
||||
void primitive_sleep(void);
|
||||
void primitive_set_slot(void);
|
||||
void primitive_load_locals(void);
|
||||
|
||||
bool stage2;
|
||||
|
|
|
|||
22
vm/types.c
22
vm/types.c
|
|
@ -139,18 +139,6 @@ CELL allot_array_1(CELL obj)
|
|||
return tag_object(a);
|
||||
}
|
||||
|
||||
CELL allot_array_2(CELL v1, CELL v2)
|
||||
{
|
||||
REGISTER_ROOT(v1);
|
||||
REGISTER_ROOT(v2);
|
||||
F_ARRAY *a = allot_array_internal(ARRAY_TYPE,2);
|
||||
UNREGISTER_ROOT(v2);
|
||||
UNREGISTER_ROOT(v1);
|
||||
set_array_nth(a,0,v1);
|
||||
set_array_nth(a,1,v2);
|
||||
return tag_object(a);
|
||||
}
|
||||
|
||||
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4)
|
||||
{
|
||||
REGISTER_ROOT(v1);
|
||||
|
|
@ -331,15 +319,9 @@ void primitive_tuple_boa(void)
|
|||
{
|
||||
F_TUPLE_LAYOUT *layout = untag_object(dpop());
|
||||
F_FIXNUM size = untag_fixnum_fast(layout->size);
|
||||
|
||||
REGISTER_UNTAGGED(layout);
|
||||
F_TUPLE *tuple = allot_tuple(layout);
|
||||
UNREGISTER_UNTAGGED(layout);
|
||||
|
||||
F_FIXNUM i;
|
||||
for(i = size - 1; i >= 0; i--)
|
||||
put(AREF(tuple,i),dpop());
|
||||
|
||||
memcpy(tuple + 1,(CELL *)(ds - CELLS * (size - 1)),CELLS * size);
|
||||
ds -= CELLS * size;
|
||||
dpush(tag_tuple(tuple));
|
||||
}
|
||||
|
||||
|
|
|
|||
|
|
@ -109,7 +109,6 @@ F_ARRAY *allot_array(CELL type, CELL capacity, CELL fill);
|
|||
F_BYTE_ARRAY *allot_byte_array(CELL size);
|
||||
|
||||
CELL allot_array_1(CELL obj);
|
||||
CELL allot_array_2(CELL v1, CELL v2);
|
||||
CELL allot_array_4(CELL v1, CELL v2, CELL v3, CELL v4);
|
||||
|
||||
void primitive_array(void);
|
||||
|
|
|
|||
Loading…
Reference in New Issue