more cleanups; split up huge gadgets vocabulary
parent
d5f52bbe7d
commit
42ac874cbd
|
@ -65,6 +65,7 @@ make-sbuf ==> SBUF" " make
|
||||||
<li>New <code>sleep ( ms -- )</code> word pauses current thread for a number of milliseconds.</li>
|
<li>New <code>sleep ( ms -- )</code> word pauses current thread for a number of milliseconds.</li>
|
||||||
<li>New <code>with-datastack ( stack word -- stack )</code> combinator.</li>
|
<li>New <code>with-datastack ( stack word -- stack )</code> combinator.</li>
|
||||||
<li>New <code>cond ( conditions -- )</code> combinator. It behaves like a set of nested <code>ifte</code>s, and compiles if each branch has the same stack effect. See its documentation comment for details.</li>
|
<li>New <code>cond ( conditions -- )</code> combinator. It behaves like a set of nested <code>ifte</code>s, and compiles if each branch has the same stack effect. See its documentation comment for details.</li>
|
||||||
|
<li>Formally documented method combination (<code>G:</code> syntax) in handbook.
|
||||||
<li>Erlang/Termite-style concurrency library in <code>contrib/concurrency</code> (Chris Double).</li>
|
<li>Erlang/Termite-style concurrency library in <code>contrib/concurrency</code> (Chris Double).</li>
|
||||||
<li>Completely redid infix algebra in <code>conrib/algebra/</code>. Now, vector operations are possible
|
<li>Completely redid infix algebra in <code>conrib/algebra/</code>. Now, vector operations are possible
|
||||||
and the syntax doesn't use so many spaces. New way to write the quadratic formula:
|
and the syntax doesn't use so many spaces. New way to write the quadratic formula:
|
||||||
|
|
|
@ -2,13 +2,14 @@
|
||||||
- out of memory error when printing global namespace
|
- out of memory error when printing global namespace
|
||||||
- removing unneeded #label
|
- removing unneeded #label
|
||||||
- pprint trailing space regression
|
- pprint trailing space regression
|
||||||
|
- finish scrollbars
|
||||||
|
- fix up the min thumb size hack
|
||||||
|
|
||||||
+ ui:
|
+ ui:
|
||||||
|
|
||||||
- fix up the min thumb size hack
|
- long lines of text fail in draw-surface
|
||||||
- only redraw dirty gadgets
|
- only redraw dirty gadgets
|
||||||
- faster mouse tracking
|
- faster mouse tracking
|
||||||
|
|
||||||
- off-by-one error in pick-up?
|
- off-by-one error in pick-up?
|
||||||
- closing ui does not stop timers
|
- closing ui does not stop timers
|
||||||
- adding/removing timers automatically for animated gadgets
|
- adding/removing timers automatically for animated gadgets
|
||||||
|
@ -66,8 +67,8 @@
|
||||||
- the invalid recursion form case needs to be fixed, for inlines too
|
- the invalid recursion form case needs to be fixed, for inlines too
|
||||||
- #jump-f #jump-f-label
|
- #jump-f #jump-f-label
|
||||||
- re-introduce #target-label => #target optimization
|
- re-introduce #target-label => #target optimization
|
||||||
- recursion is iffy; no base case needs to throw an error, and if the
|
- recursion is iffy; if the stack at the recursive call doesn't match
|
||||||
stack at the recursive call doesn't match up, throw an error
|
up, throw an error
|
||||||
|
|
||||||
+ kernel:
|
+ kernel:
|
||||||
|
|
||||||
|
|
|
@ -2543,21 +2543,6 @@ Outputs a new sequence with the reverse element order.
|
||||||
}
|
}
|
||||||
Tests if \texttt{s1} starts or ends with \texttt{s1}. If \texttt{s1} is longer than \texttt{s2}, outputs \texttt{f}.
|
Tests if \texttt{s1} starts or ends with \texttt{s1}. If \texttt{s1} is longer than \texttt{s2}, outputs \texttt{f}.
|
||||||
|
|
||||||
\wordtable{
|
|
||||||
\vocabulary{sequences}
|
|
||||||
\ordinaryword{cut}{cut ( seq n -- s1 s2 )}
|
|
||||||
}
|
|
||||||
Outputs a pair of sequences that equal the original sequence when appended. The first sequence has length $n$, the second has length $l-n$ where $l$ is the length of the input.
|
|
||||||
\begin{alltt}
|
|
||||||
"Hello world" 5 cut .s
|
|
||||||
\textbf{" world"
|
|
||||||
"Hello"}
|
|
||||||
\end{alltt}
|
|
||||||
This word has a simple definition:
|
|
||||||
\begin{verbatim}
|
|
||||||
: cut ( n seq -- seq seq )
|
|
||||||
[ head ] 2keep tail ;
|
|
||||||
\end{verbatim}
|
|
||||||
\wordtable{
|
\wordtable{
|
||||||
\vocabulary{sequences}
|
\vocabulary{sequences}
|
||||||
\ordinaryword{?head}{?head~( s1 s2 -- seq ?~)}
|
\ordinaryword{?head}{?head~( s1 s2 -- seq ?~)}
|
||||||
|
|
|
@ -167,5 +167,5 @@ M: compound (uncrossref)
|
||||||
drop
|
drop
|
||||||
] [
|
] [
|
||||||
dup { "infer-effect" "base-case" "no-effect" }
|
dup { "infer-effect" "base-case" "no-effect" }
|
||||||
reset-props decompile
|
reset-props update-xt
|
||||||
] ifte ;
|
] ifte ;
|
||||||
|
|
|
@ -54,6 +54,7 @@ sequences io vectors words ;
|
||||||
"/library/collections/queues.factor"
|
"/library/collections/queues.factor"
|
||||||
|
|
||||||
"/library/math/matrices.factor"
|
"/library/math/matrices.factor"
|
||||||
|
"/library/math/parse-numbers.factor"
|
||||||
|
|
||||||
"/library/words.factor"
|
"/library/words.factor"
|
||||||
"/library/vocabularies.factor"
|
"/library/vocabularies.factor"
|
||||||
|
@ -71,7 +72,6 @@ sequences io vectors words ;
|
||||||
"/library/io/directories.factor"
|
"/library/io/directories.factor"
|
||||||
"/library/io/binary.factor"
|
"/library/io/binary.factor"
|
||||||
|
|
||||||
"/library/syntax/parse-numbers.factor"
|
|
||||||
"/library/syntax/parse-words.factor"
|
"/library/syntax/parse-words.factor"
|
||||||
"/library/syntax/parse-errors.factor"
|
"/library/syntax/parse-errors.factor"
|
||||||
"/library/syntax/parser.factor"
|
"/library/syntax/parser.factor"
|
||||||
|
@ -95,20 +95,17 @@ sequences io vectors words ;
|
||||||
|
|
||||||
"/library/io/logging.factor"
|
"/library/io/logging.factor"
|
||||||
|
|
||||||
"/library/tools/gensym.factor"
|
|
||||||
"/library/tools/interpreter.factor"
|
"/library/tools/interpreter.factor"
|
||||||
"/library/tools/debugger.factor"
|
"/library/tools/debugger.factor"
|
||||||
"/library/tools/memory.factor"
|
"/library/tools/memory.factor"
|
||||||
"/library/tools/listener.factor"
|
"/library/tools/listener.factor"
|
||||||
"/library/tools/word-tools.factor"
|
|
||||||
"/library/tools/walker.factor"
|
"/library/tools/walker.factor"
|
||||||
"/library/tools/jedit.factor"
|
"/library/tools/jedit.factor"
|
||||||
|
|
||||||
"/library/test/test.factor"
|
|
||||||
|
|
||||||
"/library/tools/annotations.factor"
|
"/library/tools/annotations.factor"
|
||||||
"/library/tools/inspector.factor"
|
"/library/tools/inspector.factor"
|
||||||
|
|
||||||
|
"/library/test/test.factor"
|
||||||
|
|
||||||
"/library/syntax/see.factor"
|
"/library/syntax/see.factor"
|
||||||
|
|
||||||
"/library/threads.factor"
|
"/library/threads.factor"
|
||||||
|
|
|
@ -38,8 +38,8 @@ vocabularies get [ "syntax" set [ reveal ] each ] bind
|
||||||
{ ">bignum" "math" }
|
{ ">bignum" "math" }
|
||||||
{ ">float" "math" }
|
{ ">float" "math" }
|
||||||
{ "(fraction>)" "math-internals" }
|
{ "(fraction>)" "math-internals" }
|
||||||
{ "str>float" "parser" }
|
{ "string>float" "math-internals" }
|
||||||
{ "(unparse-float)" "parser" }
|
{ "float>string" "math-internals" }
|
||||||
{ "float>bits" "math" }
|
{ "float>bits" "math" }
|
||||||
{ "double>bits" "math" }
|
{ "double>bits" "math" }
|
||||||
{ "bits>float" "math" }
|
{ "bits>float" "math" }
|
||||||
|
|
|
@ -106,6 +106,10 @@ SYMBOL: building
|
||||||
#! Append to the sequence being built with make-seq.
|
#! Append to the sequence being built with make-seq.
|
||||||
building get swap nappend ;
|
building get swap nappend ;
|
||||||
|
|
||||||
|
: # ( n -- )
|
||||||
|
#! Only useful with "" make.
|
||||||
|
number>string % ;
|
||||||
|
|
||||||
! Building hashtables, and computing a transitive closure.
|
! Building hashtables, and computing a transitive closure.
|
||||||
SYMBOL: hash-buffer
|
SYMBOL: hash-buffer
|
||||||
|
|
||||||
|
|
|
@ -48,15 +48,8 @@ M: compound (compile) ( word -- )
|
||||||
|
|
||||||
: compile-all ( -- ) [ try-compile ] each-word ;
|
: compile-all ( -- ) [ try-compile ] each-word ;
|
||||||
|
|
||||||
: decompile ( word -- )
|
|
||||||
dup compiled? [
|
|
||||||
"Decompiling " write dup . update-xt
|
|
||||||
] [
|
|
||||||
drop
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
: recompile ( word -- )
|
: recompile ( word -- )
|
||||||
dup decompile compile ;
|
dup update-xt compile ;
|
||||||
|
|
||||||
: compile-1 ( quot -- word )
|
: compile-1 ( quot -- word )
|
||||||
#! Compute a quotation into an uninterned word, for testing
|
#! Compute a quotation into an uninterned word, for testing
|
||||||
|
|
|
@ -140,3 +140,12 @@ M: generic definer drop \ G: ;
|
||||||
: define-class ( class metaclass -- )
|
: define-class ( class metaclass -- )
|
||||||
dupd "metaclass" set-word-prop
|
dupd "metaclass" set-word-prop
|
||||||
dup types number-sort typemap get set-hash ;
|
dup types number-sort typemap get set-hash ;
|
||||||
|
|
||||||
|
: implementors ( class -- list )
|
||||||
|
#! Find a list of generics that implement a method
|
||||||
|
#! specializing on this class.
|
||||||
|
[ "methods" word-prop ?hash ] word-subset-with ;
|
||||||
|
|
||||||
|
: classes ( -- list )
|
||||||
|
#! Output a list of all defined classes.
|
||||||
|
[ metaclass ] word-subset ;
|
||||||
|
|
|
@ -30,7 +30,7 @@ M: general-list tutorial-line
|
||||||
|
|
||||||
: <page> ( list -- gadget )
|
: <page> ( list -- gadget )
|
||||||
[ tutorial-line ] map
|
[ tutorial-line ] map
|
||||||
1 <pile> [ add-gadgets ] keep
|
<pile> dup 1 over set-pack-fill [ add-gadgets ] keep
|
||||||
empty-border ;
|
empty-border ;
|
||||||
|
|
||||||
: tutorial-pages
|
: tutorial-pages
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2004,2005 Slava Pestov.
|
! Copyright (C) 2004,2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: file-responder
|
IN: file-responder
|
||||||
USING: html httpd kernel lists namespaces parser sequences
|
USING: html httpd kernel lists math namespaces parser sequences
|
||||||
io strings ;
|
io strings ;
|
||||||
|
|
||||||
: serving-path ( filename -- filename )
|
: serving-path ( filename -- filename )
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: html
|
IN: html
|
||||||
USING: generic http io kernel lists namespaces parser
|
USING: generic http io kernel lists math namespaces parser
|
||||||
presentation sequences strings styles words ;
|
presentation sequences strings styles words ;
|
||||||
|
|
||||||
: html-entities ( -- alist )
|
: html-entities ( -- alist )
|
||||||
|
@ -35,7 +35,7 @@ presentation sequences strings styles words ;
|
||||||
[ "text-decoration: underline; " % ] when ;
|
[ "text-decoration: underline; " % ] when ;
|
||||||
|
|
||||||
: size-css, ( size -- )
|
: size-css, ( size -- )
|
||||||
"font-size: " % number>string % "; " % ;
|
"font-size: " % # "; " % ;
|
||||||
|
|
||||||
: font-css, ( font -- )
|
: font-css, ( font -- )
|
||||||
"font-family: " % % "; " % ;
|
"font-family: " % % "; " % ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: http-client
|
IN: http-client
|
||||||
USING: errors http kernel lists namespaces parser sequences
|
USING: errors http kernel lists math namespaces parser sequences
|
||||||
io strings ;
|
io strings ;
|
||||||
|
|
||||||
: parse-host ( url -- host port )
|
: parse-host ( url -- host port )
|
||||||
|
|
|
@ -38,7 +38,7 @@ sequences ;
|
||||||
[ (handle-request) serve-responder ] with-scope ;
|
[ (handle-request) serve-responder ] with-scope ;
|
||||||
|
|
||||||
: parse-request ( request -- )
|
: parse-request ( request -- )
|
||||||
dup log
|
dup log-message
|
||||||
" " split1 dup [
|
" " split1 dup [
|
||||||
" HTTP" split1 drop url>path secure-path dup [
|
" HTTP" split1 drop url>path secure-path dup [
|
||||||
swap handle-request
|
swap handle-request
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: httpd
|
IN: httpd
|
||||||
USING: hashtables http kernel lists namespaces parser sequences
|
USING: hashtables http kernel lists math namespaces parser
|
||||||
io strings ;
|
sequences io strings ;
|
||||||
|
|
||||||
! Variables
|
! Variables
|
||||||
SYMBOL: vhosts
|
SYMBOL: vhosts
|
||||||
|
@ -66,7 +66,7 @@ SYMBOL: responders
|
||||||
|
|
||||||
: log-user-agent ( alist -- )
|
: log-user-agent ( alist -- )
|
||||||
"User-Agent" swap assoc* [
|
"User-Agent" swap assoc* [
|
||||||
unswons [ % ": " % % ] "" make log
|
unswons [ % ": " % % ] "" make log-message
|
||||||
] when* ;
|
] when* ;
|
||||||
|
|
||||||
: prepare-url ( url -- url )
|
: prepare-url ( url -- url )
|
||||||
|
@ -138,7 +138,7 @@ SYMBOL: responders
|
||||||
"default" responder call-responder ;
|
"default" responder call-responder ;
|
||||||
|
|
||||||
: log-responder ( path -- )
|
: log-responder ( path -- )
|
||||||
"Calling responder " swap append log ;
|
"Calling responder " swap append log-message ;
|
||||||
|
|
||||||
: trim-/ ( url -- url )
|
: trim-/ ( url -- url )
|
||||||
#! Trim a leading /, if there is one.
|
#! Trim a leading /, if there is one.
|
||||||
|
|
|
@ -113,13 +113,13 @@ memory parser sequences strings vectors words prettyprint ;
|
||||||
\ (fraction>) t "flushable" set-word-prop
|
\ (fraction>) t "flushable" set-word-prop
|
||||||
\ (fraction>) t "foldable" set-word-prop
|
\ (fraction>) t "foldable" set-word-prop
|
||||||
|
|
||||||
\ str>float [ [ string ] [ float ] ] "infer-effect" set-word-prop
|
\ string>float [ [ string ] [ float ] ] "infer-effect" set-word-prop
|
||||||
\ str>float t "flushable" set-word-prop
|
\ string>float t "flushable" set-word-prop
|
||||||
\ str>float t "foldable" set-word-prop
|
\ string>float t "foldable" set-word-prop
|
||||||
|
|
||||||
\ (unparse-float) [ [ float ] [ string ] ] "infer-effect" set-word-prop
|
\ float>string [ [ float ] [ string ] ] "infer-effect" set-word-prop
|
||||||
\ (unparse-float) t "flushable" set-word-prop
|
\ float>string t "flushable" set-word-prop
|
||||||
\ (unparse-float) t "foldable" set-word-prop
|
\ float>string t "foldable" set-word-prop
|
||||||
|
|
||||||
\ float>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
|
\ float>bits [ [ real ] [ integer ] ] "infer-effect" set-word-prop
|
||||||
\ float>bits t "flushable" set-word-prop
|
\ float>bits t "flushable" set-word-prop
|
||||||
|
|
|
@ -1,28 +1,25 @@
|
||||||
! Copyright (C) 2003, 2005 Slava Pestov.
|
! Copyright (C) 2003, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: io
|
IN: io
|
||||||
USING: io kernel namespaces parser sequences strings ;
|
USING: io kernel math namespaces parser sequences strings ;
|
||||||
|
|
||||||
! A simple logging framework.
|
! A simple logging framework.
|
||||||
SYMBOL: log-stream
|
SYMBOL: log-stream
|
||||||
|
|
||||||
: log ( msg -- )
|
: log-message ( msg -- )
|
||||||
#! Log a message to the log stream, either stdio or a file.
|
#! Log a message to the log stream, either stdio or a file.
|
||||||
log-stream get [
|
log-stream get [ stdio get ] unless*
|
||||||
[ stream-print ] keep stream-flush
|
[ stream-print ] keep stream-flush ;
|
||||||
] [
|
|
||||||
print flush
|
|
||||||
] ifte* ;
|
|
||||||
|
|
||||||
: log-error ( error -- ) "Error: " swap append log ;
|
: log-error ( error -- ) "Error: " swap append log-message ;
|
||||||
|
|
||||||
: log-client ( client-stream -- )
|
: log-client ( client-stream -- )
|
||||||
[
|
[
|
||||||
"Accepted connection from " %
|
"Accepted connection from " %
|
||||||
dup client-stream-host %
|
dup client-stream-host %
|
||||||
CHAR: : ,
|
CHAR: : ,
|
||||||
client-stream-port number>string %
|
client-stream-port #
|
||||||
] "" make log ;
|
] "" make log-message ;
|
||||||
|
|
||||||
: with-log-file ( file quot -- )
|
: with-log-file ( file quot -- )
|
||||||
#! Calls to log inside quot will output to a file.
|
#! Calls to log inside quot will output to a file.
|
||||||
|
|
|
@ -86,3 +86,6 @@ GENERIC: abs ( z -- |z| )
|
||||||
] [
|
] [
|
||||||
dup 1 = [ drop 0 ] [ 2 /i log2 1 + ] ifte
|
dup 1 = [ drop 0 ] [ 2 /i log2 1 + ] ifte
|
||||||
] ifte ; foldable
|
] ifte ; foldable
|
||||||
|
|
||||||
|
GENERIC: string>number ( str -- num ) foldable
|
||||||
|
GENERIC: number>string ( str -- num ) foldable
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: parser
|
IN: math
|
||||||
USING: errors generic kernel math namespaces sequences strings ;
|
USING: errors generic kernel math-internals namespaces sequences
|
||||||
|
strings ;
|
||||||
|
|
||||||
! Number parsing
|
! Number parsing
|
||||||
|
|
||||||
|
@ -26,9 +27,7 @@ M: object digit> not-a-number ;
|
||||||
: base> ( str base -- num )
|
: base> ( str base -- num )
|
||||||
#! Convert a string to an integer. Throw an error if
|
#! Convert a string to an integer. Throw an error if
|
||||||
#! conversion fails.
|
#! conversion fails.
|
||||||
swap "-" ?head [ (base>) neg ] [ (base>) ] ifte ;
|
swap "-" ?head >r (base>) r> [ neg ] when ;
|
||||||
|
|
||||||
GENERIC: string>number ( str -- num )
|
|
||||||
|
|
||||||
M: string string>number 10 base> ;
|
M: string string>number 10 base> ;
|
||||||
|
|
||||||
|
@ -37,24 +36,18 @@ M: potential-ratio string>number ( str -- num )
|
||||||
"/" split1 >r 10 base> r> 10 base> / ;
|
"/" split1 >r 10 base> r> 10 base> / ;
|
||||||
|
|
||||||
PREDICATE: string potential-float CHAR: . swap member? ;
|
PREDICATE: string potential-float CHAR: . swap member? ;
|
||||||
M: potential-float string>number ( str -- num )
|
M: potential-float string>number ( str -- num ) string>float ;
|
||||||
str>float ;
|
|
||||||
|
|
||||||
: bin> 2 base> ;
|
: bin> 2 base> ;
|
||||||
: oct> 8 base> ;
|
: oct> 8 base> ;
|
||||||
: hex> 16 base> ;
|
: hex> 16 base> ;
|
||||||
|
|
||||||
GENERIC: number>string ( str -- num )
|
|
||||||
|
|
||||||
: >digit ( n -- ch )
|
: >digit ( n -- ch )
|
||||||
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
|
dup 10 < [ CHAR: 0 + ] [ 10 - CHAR: a + ] ifte ;
|
||||||
|
|
||||||
: integer, ( num radix -- )
|
: integer, ( num radix -- )
|
||||||
dup >r /mod >digit , dup 0 > [
|
dup >r /mod >digit , dup 0 >
|
||||||
r> integer,
|
[ r> integer, ] [ r> 2drop ] ifte ;
|
||||||
] [
|
|
||||||
r> 2drop
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
: >base ( num radix -- string )
|
: >base ( num radix -- string )
|
||||||
#! Convert a number to a string in a certain base.
|
#! Convert a number to a string in a certain base.
|
||||||
|
@ -73,17 +66,9 @@ GENERIC: number>string ( str -- num )
|
||||||
M: integer number>string ( obj -- str ) 10 >base ;
|
M: integer number>string ( obj -- str ) 10 >base ;
|
||||||
|
|
||||||
M: ratio number>string ( num -- str )
|
M: ratio number>string ( num -- str )
|
||||||
[
|
[ dup numerator # CHAR: / , denominator # ] "" make ;
|
||||||
dup
|
|
||||||
numerator number>string %
|
|
||||||
CHAR: / ,
|
|
||||||
denominator number>string %
|
|
||||||
] "" make ;
|
|
||||||
|
|
||||||
: fix-float ( str -- str )
|
|
||||||
#! This is terrible. Will go away when we do our own float
|
|
||||||
#! output.
|
|
||||||
CHAR: . over member? [ ".0" append ] unless ;
|
|
||||||
|
|
||||||
M: float number>string ( float -- str )
|
M: float number>string ( float -- str )
|
||||||
(unparse-float) fix-float ;
|
#! This is terrible. Will go away when we do our own float
|
||||||
|
#! output.
|
||||||
|
float>string CHAR: . over member? [ ".0" append ] unless ;
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: parser
|
IN: parser
|
||||||
USING: kernel lists namespaces sequences io ;
|
USING: kernel lists namespaces sequences io words ;
|
||||||
|
|
||||||
: file-vocabs ( -- )
|
: file-vocabs ( -- )
|
||||||
"scratchpad" "in" set
|
"scratchpad" "in" set
|
||||||
|
@ -38,3 +38,12 @@ USING: kernel lists namespaces sequences io ;
|
||||||
|
|
||||||
: run-resource ( file -- )
|
: run-resource ( file -- )
|
||||||
parse-resource call ;
|
parse-resource call ;
|
||||||
|
|
||||||
|
: word-file ( word -- file )
|
||||||
|
"file" word-prop dup [
|
||||||
|
"resource:/" ?head [ resource-path swap path+ ] when
|
||||||
|
] when ;
|
||||||
|
|
||||||
|
: reload ( word -- )
|
||||||
|
#! Reload the source file the word originated from.
|
||||||
|
word-file run-file ;
|
||||||
|
|
|
@ -11,7 +11,6 @@ SYMBOL: last-newline
|
||||||
SYMBOL: recursion-check
|
SYMBOL: recursion-check
|
||||||
SYMBOL: line-count
|
SYMBOL: line-count
|
||||||
SYMBOL: end-printing
|
SYMBOL: end-printing
|
||||||
SYMBOL: newline-ok?
|
|
||||||
|
|
||||||
! Configuration
|
! Configuration
|
||||||
SYMBOL: tab-size
|
SYMBOL: tab-size
|
||||||
|
@ -30,7 +29,6 @@ global [
|
||||||
0 last-newline set
|
0 last-newline set
|
||||||
0 line-count set
|
0 line-count set
|
||||||
string-limit off
|
string-limit off
|
||||||
newline-ok? off
|
|
||||||
] bind
|
] bind
|
||||||
|
|
||||||
TUPLE: pprinter stack ;
|
TUPLE: pprinter stack ;
|
||||||
|
@ -48,9 +46,6 @@ C: section ( length -- section )
|
||||||
: section-fits? ( section -- ? )
|
: section-fits? ( section -- ? )
|
||||||
section-end last-newline get - indent get + margin get <= ;
|
section-end last-newline get - indent get + margin get <= ;
|
||||||
|
|
||||||
: insert-newline? ( section -- ? )
|
|
||||||
section-fits? not newline-ok? and ;
|
|
||||||
|
|
||||||
: line-limit? ( -- ? )
|
: line-limit? ( -- ? )
|
||||||
line-limit get dup [ line-count get <= ] when ;
|
line-limit get dup [ line-count get <= ] when ;
|
||||||
|
|
||||||
|
@ -58,10 +53,14 @@ C: section ( length -- section )
|
||||||
|
|
||||||
: fresh-line ( n -- )
|
: fresh-line ( n -- )
|
||||||
#! n is current column position.
|
#! n is current column position.
|
||||||
|
dup last-newline get = [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
last-newline set
|
last-newline set
|
||||||
line-count inc
|
line-count inc
|
||||||
line-limit? [ "..." write end-printing get call ] when
|
line-limit? [ "..." write end-printing get call ] when
|
||||||
"\n" write do-indent ;
|
"\n" write do-indent
|
||||||
|
] ifte ;
|
||||||
|
|
||||||
TUPLE: text string style ;
|
TUPLE: text string style ;
|
||||||
|
|
||||||
|
@ -107,8 +106,8 @@ C: block ( -- block )
|
||||||
[ section-end fresh-line ] [ drop ] ifte ;
|
[ section-end fresh-line ] [ drop ] ifte ;
|
||||||
|
|
||||||
: pprint-section ( section -- )
|
: pprint-section ( section -- )
|
||||||
dup insert-newline? newline-ok? on
|
dup section-fits?
|
||||||
[ inset-section ] [ pprint-section* ] ifte ;
|
[ pprint-section* ] [ inset-section ] ifte ;
|
||||||
|
|
||||||
TUPLE: newline ;
|
TUPLE: newline ;
|
||||||
|
|
||||||
|
@ -116,7 +115,7 @@ C: newline ( -- section )
|
||||||
0 <section> over set-delegate ;
|
0 <section> over set-delegate ;
|
||||||
|
|
||||||
M: newline pprint-section* ( newline -- )
|
M: newline pprint-section* ( newline -- )
|
||||||
section-start fresh-line newline-ok? off ;
|
section-start fresh-line ;
|
||||||
|
|
||||||
M: block pprint-section* ( block -- )
|
M: block pprint-section* ( block -- )
|
||||||
block-sections [ pprint-section ] each ;
|
block-sections [ pprint-section ] each ;
|
||||||
|
|
|
@ -118,3 +118,14 @@ M: word class. drop ;
|
||||||
|
|
||||||
: see ( word -- )
|
: see ( word -- )
|
||||||
[ dup in. dup (see) dup class. methods. ] with-pprint ;
|
[ dup in. dup (see) dup class. methods. ] with-pprint ;
|
||||||
|
|
||||||
|
: (apropos) ( substring -- seq )
|
||||||
|
vocabs [
|
||||||
|
words [ word-name subseq? ] subset-with
|
||||||
|
] map-with concat ;
|
||||||
|
|
||||||
|
: apropos ( substring -- )
|
||||||
|
#! List all words that contain a string.
|
||||||
|
(apropos) [
|
||||||
|
"IN: " write dup word-vocabulary write " " write .
|
||||||
|
] each ;
|
||||||
|
|
|
@ -21,10 +21,7 @@ M: assert error.
|
||||||
#! Evaluates the given code and prints the time taken to
|
#! Evaluates the given code and prints the time taken to
|
||||||
#! execute it.
|
#! execute it.
|
||||||
millis >r gc-time >r call gc-time r> - millis r> -
|
millis >r gc-time >r call gc-time r> - millis r> -
|
||||||
[
|
[ # " ms run / " % # " ms GC time" % ] "" make print ;
|
||||||
number>string % " ms run / " %
|
|
||||||
number>string % " ms GC time" %
|
|
||||||
] "" make print ;
|
|
||||||
|
|
||||||
: unit-test ( output input -- )
|
: unit-test ( output input -- )
|
||||||
[
|
[
|
||||||
|
|
|
@ -1,14 +0,0 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
|
||||||
IN: words
|
|
||||||
USING: hashtables kernel math namespaces parser sequences
|
|
||||||
strings ;
|
|
||||||
|
|
||||||
: gensym ( -- word )
|
|
||||||
#! Return a word that is distinct from every other word, and
|
|
||||||
#! is not contained in any vocabulary.
|
|
||||||
"G:"
|
|
||||||
global [ \ gensym dup inc get ] bind
|
|
||||||
number>string append f <word> ;
|
|
||||||
|
|
||||||
0 \ gensym global set-hash
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2004, 2005 Slava Pestov.
|
! Copyright (C) 2004, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: jedit
|
IN: jedit
|
||||||
USING: errors io kernel lists namespaces parser prettyprint
|
USING: errors io kernel lists math namespaces parser prettyprint
|
||||||
sequences strings unparser vectors words ;
|
sequences strings unparser vectors words ;
|
||||||
|
|
||||||
! Some words to send requests to a running jEdit instance to
|
! Some words to send requests to a running jEdit instance to
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2003, 2005 Slava Pestov.
|
! Copyright (C) 2003, 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: telnetd
|
IN: telnetd
|
||||||
USING: errors listener kernel namespaces io threads parser ;
|
USING: errors listener kernel math namespaces io threads parser ;
|
||||||
|
|
||||||
: telnet-client ( socket -- )
|
: telnet-client ( socket -- )
|
||||||
dup [ log-client print-banner listener ] with-stream ;
|
dup [ log-client print-banner listener ] with-stream ;
|
||||||
|
|
|
@ -1,43 +0,0 @@
|
||||||
! Copyright (C) 2003, 2005 Slava Pestov.
|
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
|
||||||
IN: words
|
|
||||||
USING: generic inspector lists kernel namespaces
|
|
||||||
prettyprint io strings sequences math hashtables parser ;
|
|
||||||
|
|
||||||
: vocab-apropos ( substring vocab -- list )
|
|
||||||
#! Push a list of all words in a vocabulary whose names
|
|
||||||
#! contain a string.
|
|
||||||
words [ word-name subseq? ] subset-with ;
|
|
||||||
|
|
||||||
: vocab-apropos. ( substring vocab -- )
|
|
||||||
#! List all words in a vocabulary that contain a string.
|
|
||||||
tuck vocab-apropos dup [
|
|
||||||
"IN: " write swap print sequence.
|
|
||||||
] [
|
|
||||||
2drop
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
: apropos. ( substring -- )
|
|
||||||
#! List all words that contain a string.
|
|
||||||
vocabs [ vocab-apropos. ] each-with ;
|
|
||||||
|
|
||||||
: word-file ( word -- file )
|
|
||||||
"file" word-prop dup [
|
|
||||||
"resource:/" ?head [
|
|
||||||
resource-path swap path+
|
|
||||||
] when
|
|
||||||
] when ;
|
|
||||||
|
|
||||||
: reload ( word -- )
|
|
||||||
#! Reload the source file the word originated from.
|
|
||||||
word-file run-file ;
|
|
||||||
|
|
||||||
: implementors ( class -- list )
|
|
||||||
#! Find a list of generics that implement a method
|
|
||||||
#! specializing on this class.
|
|
||||||
[
|
|
||||||
"methods" word-prop [ dupd hash ] [ f ] ifte*
|
|
||||||
] word-subset nip ;
|
|
||||||
|
|
||||||
: classes ( -- list )
|
|
||||||
[ metaclass ] word-subset ;
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-books
|
||||||
USING: generic kernel lists math matrices sequences ;
|
USING: gadgets gadgets-buttons gadgets-labels gadgets-layouts
|
||||||
|
generic kernel lists math matrices sequences ;
|
||||||
|
|
||||||
TUPLE: book page ;
|
TUPLE: book page ;
|
||||||
|
|
||||||
|
@ -46,7 +47,7 @@ TUPLE: book-browser book ;
|
||||||
{ ">" [ find-book next-page ] }
|
{ ">" [ find-book next-page ] }
|
||||||
{ ">|" [ find-book last-page ] }
|
{ ">|" [ find-book last-page ] }
|
||||||
] [ 2unseq >r <label> r> <button> ] map
|
] [ 2unseq >r <label> r> <button> ] map
|
||||||
0 <shelf> [ add-gadgets ] keep ;
|
<shelf> [ add-gadgets ] keep ;
|
||||||
|
|
||||||
C: book-browser ( book -- gadget )
|
C: book-browser ( book -- gadget )
|
||||||
<frame> over set-delegate
|
<frame> over set-delegate
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-borders
|
||||||
USING: errors generic hashtables kernel lists math matrices
|
USING: errors gadgets generic hashtables kernel lists math
|
||||||
namespaces sdl vectors ;
|
namespaces sdl vectors ;
|
||||||
|
|
||||||
TUPLE: border size ;
|
TUPLE: border size ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-buttons
|
||||||
USING: generic io kernel lists math namespaces prettyprint sdl
|
USING: gadgets gadgets-borders generic io kernel lists math
|
||||||
sequences sequences styles threads ;
|
namespaces sdl sequences sequences styles threads ;
|
||||||
|
|
||||||
: button-down? ( n -- ? ) hand hand-buttons member? ;
|
: button-down? ( n -- ? ) hand hand-buttons member? ;
|
||||||
|
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-editors
|
||||||
USING: generic kernel math matrices namespaces sdl sequences
|
USING: gadgets gadgets-labels gadgets-scrolling generic kernel
|
||||||
strings styles threads vectors ;
|
math namespaces sdl sequences strings styles threads vectors ;
|
||||||
|
|
||||||
! A blinking caret
|
! A blinking caret
|
||||||
TUPLE: caret ;
|
TUPLE: caret ;
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-layouts
|
||||||
USING: generic kernel lists math namespaces sequences vectors ;
|
USING: gadgets generic kernel lists math namespaces sequences
|
||||||
|
vectors ;
|
||||||
|
|
||||||
! A frame arranges gadgets in a 3x3 grid, where the center
|
! A frame arranges gadgets in a 3x3 grid, where the center
|
||||||
! gadgets gets left-over space.
|
! gadgets gets left-over space.
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-layouts
|
||||||
USING: generic kernel math ;
|
USING: gadgets generic kernel math ;
|
||||||
|
|
||||||
! Incremental layout allows adding lines to panes to be O(1).
|
! Incremental layout allows adding lines to panes to be O(1).
|
||||||
! Note that incremental packs are distinct from ordinary packs
|
! Note that incremental packs are distinct from ordinary packs
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-labels
|
||||||
USING: generic hashtables io kernel lists math namespaces sdl
|
USING: gadgets generic hashtables io kernel lists math
|
||||||
sequences styles vectors ;
|
namespaces sdl sequences styles vectors ;
|
||||||
|
|
||||||
! A label gadget draws a string.
|
! A label gadget draws a string.
|
||||||
TUPLE: label text ;
|
TUPLE: label text ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-layouts
|
||||||
USING: errors generic hashtables kernel lists math matrices
|
USING: errors gadgets generic hashtables kernel lists math
|
||||||
namespaces sdl sequences ;
|
matrices namespaces sdl sequences ;
|
||||||
|
|
||||||
: layout ( gadget -- )
|
: layout ( gadget -- )
|
||||||
#! Set the gadget's width and height to its preferred width
|
#! Set the gadget's width and height to its preferred width
|
||||||
|
@ -26,36 +26,24 @@ TUPLE: pack align fill vector ;
|
||||||
>r >r pack-vector r> r> [ pick set-axis ] 2map nip ;
|
>r >r pack-vector r> r> [ pick set-axis ] 2map nip ;
|
||||||
|
|
||||||
: packed-dim-2 ( gadget sizes -- list )
|
: packed-dim-2 ( gadget sizes -- list )
|
||||||
[
|
[ over rect-dim over v- rot pack-fill v*n v+ ] map-with ;
|
||||||
over rect-dim { 1 1 1 } vmax over v-
|
|
||||||
rot pack-fill v*n v+
|
|
||||||
] map-with ;
|
|
||||||
|
|
||||||
: (packed-dims) ( gadget sizes -- seq )
|
|
||||||
2dup packed-dim-2 swap orient ;
|
|
||||||
|
|
||||||
: packed-dims ( gadget sizes -- seq )
|
: packed-dims ( gadget sizes -- seq )
|
||||||
over gadget-children >r (packed-dims) r>
|
2dup packed-dim-2 swap orient ;
|
||||||
[ set-gadget-dim ] 2each ;
|
|
||||||
|
|
||||||
: packed-loc-1 ( sizes -- seq )
|
: packed-loc-1 ( sizes -- seq )
|
||||||
{ 0 0 0 } [ v+ ] accumulate ;
|
{ 0 0 0 } [ v+ ] accumulate ;
|
||||||
|
|
||||||
: packed-loc-2 ( gadget sizes -- seq )
|
: packed-loc-2 ( gadget sizes -- seq )
|
||||||
>r dup rect-dim { 1 1 1 } vmax over r>
|
[ >r dup pack-align swap rect-dim r> v- n*v ] map-with ;
|
||||||
packed-dim-2 [ v- ] map-with
|
|
||||||
>r dup pack-align swap rect-dim { 1 1 1 } vmax r>
|
|
||||||
[ >r 2dup r> v- n*v ] map 2nip ;
|
|
||||||
|
|
||||||
: (packed-locs) ( gadget sizes -- seq )
|
: packed-locs ( gadget sizes -- seq )
|
||||||
dup packed-loc-1 >r dupd packed-loc-2 r> orient ;
|
dup packed-loc-1 >r dupd packed-loc-2 r> orient ;
|
||||||
|
|
||||||
: packed-locs ( gadget sizes -- )
|
|
||||||
over gadget-children >r (packed-locs) r>
|
|
||||||
[ set-rect-loc ] 2each ;
|
|
||||||
|
|
||||||
: packed-layout ( gadget sizes -- )
|
: packed-layout ( gadget sizes -- )
|
||||||
2dup packed-locs packed-dims ;
|
over gadget-children
|
||||||
|
>r dupd packed-dims r> 2dup [ set-gadget-dim ] 2each
|
||||||
|
>r packed-locs r> [ set-rect-loc ] 2each ;
|
||||||
|
|
||||||
C: pack ( fill vector -- pack )
|
C: pack ( fill vector -- pack )
|
||||||
#! gap: between each child.
|
#! gap: between each child.
|
||||||
|
@ -65,9 +53,9 @@ C: pack ( fill vector -- pack )
|
||||||
[ set-pack-fill ] keep
|
[ set-pack-fill ] keep
|
||||||
0 over set-pack-align ;
|
0 over set-pack-align ;
|
||||||
|
|
||||||
: <pile> ( fill -- pack ) { 0 1 0 } <pack> ;
|
: <pile> ( -- pack ) { 0 1 0 } <pack> ;
|
||||||
|
|
||||||
: <shelf> ( fill -- pack ) { 1 0 0 } <pack> ;
|
: <shelf> ( -- pack ) { 1 0 0 } <pack> ;
|
||||||
|
|
||||||
M: pack pref-dim ( pack -- dim )
|
M: pack pref-dim ( pack -- dim )
|
||||||
[
|
[
|
||||||
|
@ -94,7 +82,8 @@ TUPLE: stack ;
|
||||||
|
|
||||||
C: stack ( -- gadget )
|
C: stack ( -- gadget )
|
||||||
#! A stack lays out all its children on top of each other.
|
#! A stack lays out all its children on top of each other.
|
||||||
1 { 0 0 1 } <pack> over set-delegate ;
|
{ 0 0 1 } <pack> over set-delegate
|
||||||
|
1 over set-pack-fill ;
|
||||||
|
|
||||||
M: stack children-on ( point stack -- gadget )
|
M: stack children-on ( point stack -- gadget )
|
||||||
nip gadget-children ;
|
nip gadget-children ;
|
||||||
|
|
|
@ -3,8 +3,10 @@
|
||||||
IN: help
|
IN: help
|
||||||
DEFER: <tutorial-button>
|
DEFER: <tutorial-button>
|
||||||
|
|
||||||
IN: gadgets
|
IN: gadgets-listener
|
||||||
USING: generic help io kernel listener lists math namespaces
|
USING: gadgets gadgets-labels gadgets-layouts gadgets-panes
|
||||||
|
gadgets-presentations gadgets-scrolling gadgets-splitters
|
||||||
|
generic help io kernel listener lists math namespaces
|
||||||
prettyprint sdl sequences shells styles threads words ;
|
prettyprint sdl sequences shells styles threads words ;
|
||||||
|
|
||||||
SYMBOL: datastack-display
|
SYMBOL: datastack-display
|
||||||
|
@ -25,14 +27,11 @@ TUPLE: display title pane ;
|
||||||
C: display ( -- display )
|
C: display ( -- display )
|
||||||
<frame> over set-delegate
|
<frame> over set-delegate
|
||||||
"" <display-title> over add-display-title
|
"" <display-title> over add-display-title
|
||||||
0 <pile> 2dup swap set-display-pane
|
<pile> 2dup swap set-display-pane
|
||||||
<scroller> over add-center ;
|
<scroller> over add-center ;
|
||||||
|
|
||||||
: make-presentations ( seq -- seq )
|
: make-presentations ( seq -- seq )
|
||||||
[
|
[ <object-presentation> ] map ;
|
||||||
dup presented swons unit swap unparse-short
|
|
||||||
<presentation>
|
|
||||||
] map ;
|
|
||||||
|
|
||||||
: present-stack ( seq title display -- )
|
: present-stack ( seq title display -- )
|
||||||
[ display-title set-label-text ] keep
|
[ display-title set-label-text ] keep
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-menus
|
||||||
USING: generic kernel lists math namespaces sequences ;
|
USING: gadgets gadgets-borders gadgets-buttons gadgets-layouts
|
||||||
|
gadgets-labels generic kernel lists math namespaces sequences ;
|
||||||
|
|
||||||
: menu-actions ( glass -- )
|
: menu-actions ( glass -- )
|
||||||
[ drop hide-glass ] [ button-down 1 ] set-action ;
|
[ drop hide-glass ] [ button-down 1 ] set-action ;
|
||||||
|
@ -22,7 +23,7 @@ USING: generic kernel lists math namespaces sequences ;
|
||||||
#! Given an association list mapping labels to quotations.
|
#! Given an association list mapping labels to quotations.
|
||||||
#! Prepend a call to hide-menu to each quotation.
|
#! Prepend a call to hide-menu to each quotation.
|
||||||
[ uncons \ hide-glass swons >r <label> r> <roll-button> ] map
|
[ uncons \ hide-glass swons >r <label> r> <roll-button> ] map
|
||||||
1 <pile> [ add-gadgets ] keep ;
|
<pile> 1 over set-pack-fill [ add-gadgets ] keep ;
|
||||||
|
|
||||||
: menu-theme ( menu -- )
|
: menu-theme ( menu -- )
|
||||||
<< solid f >> interior set-paint-prop ;
|
<< solid f >> interior set-paint-prop ;
|
||||||
|
|
|
@ -1,7 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-panes
|
||||||
USING: generic hashtables io kernel line-editor listener lists
|
USING: gadgets gadgets-editors gadgets-labels gadgets-layouts
|
||||||
|
gadgets-scrolling generic hashtables io kernel line-editor lists
|
||||||
math namespaces prettyprint sequences strings styles threads
|
math namespaces prettyprint sequences strings styles threads
|
||||||
vectors ;
|
vectors ;
|
||||||
|
|
||||||
|
@ -19,7 +20,7 @@ TUPLE: pane output active current input continuation ;
|
||||||
: add-input 2dup set-pane-input add-gadget ;
|
: add-input 2dup set-pane-input add-gadget ;
|
||||||
|
|
||||||
: <active-line> ( input current -- line )
|
: <active-line> ( input current -- line )
|
||||||
2vector 0 <shelf> [ add-gadgets ] keep ;
|
2vector <shelf> [ add-gadgets ] keep ;
|
||||||
|
|
||||||
: init-active-line ( pane -- )
|
: init-active-line ( pane -- )
|
||||||
dup pane-active unparent
|
dup pane-active unparent
|
||||||
|
@ -54,18 +55,22 @@ SYMBOL: structured-input
|
||||||
[ pane-input editor-commit ] keep
|
[ pane-input editor-commit ] keep
|
||||||
2dup stream-print pane-eval ;
|
2dup stream-print pane-eval ;
|
||||||
|
|
||||||
|
: pane-clear ( pane -- )
|
||||||
|
dup pane-output clear-incremental pane-current clear-gadget ;
|
||||||
|
|
||||||
: pane-actions ( line -- )
|
: pane-actions ( line -- )
|
||||||
[
|
[
|
||||||
[[ [ button-down 1 ] [ pane-input click-editor ] ]]
|
[[ [ button-down 1 ] [ pane-input click-editor ] ]]
|
||||||
[[ [ "RETURN" ] [ pane-return ] ]]
|
[[ [ "RETURN" ] [ pane-return ] ]]
|
||||||
[[ [ "UP" ] [ pane-input [ history-prev ] with-editor ] ]]
|
[[ [ "UP" ] [ pane-input [ history-prev ] with-editor ] ]]
|
||||||
[[ [ "DOWN" ] [ pane-input [ history-next ] with-editor ] ]]
|
[[ [ "DOWN" ] [ pane-input [ history-next ] with-editor ] ]]
|
||||||
|
[[ [ "CTRL" "l" ] [ pane get pane-clear ] ]]
|
||||||
] swap add-actions ;
|
] swap add-actions ;
|
||||||
|
|
||||||
C: pane ( -- pane )
|
C: pane ( -- pane )
|
||||||
0 <pile> over set-delegate
|
<pile> over set-delegate
|
||||||
0 <pile> <incremental> over add-output
|
<pile> <incremental> over add-output
|
||||||
0 <shelf> over set-pane-current
|
<shelf> over set-pane-current
|
||||||
"" <editor> over set-pane-input
|
"" <editor> over set-pane-input
|
||||||
dup init-active-line
|
dup init-active-line
|
||||||
dup pane-actions ;
|
dup pane-actions ;
|
||||||
|
@ -73,9 +78,6 @@ C: pane ( -- pane )
|
||||||
M: pane focusable-child* ( pane -- editor )
|
M: pane focusable-child* ( pane -- editor )
|
||||||
pane-input ;
|
pane-input ;
|
||||||
|
|
||||||
: pane-clear ( pane -- )
|
|
||||||
dup pane-output clear-incremental pane-current clear-gadget ;
|
|
||||||
|
|
||||||
: pane-write-1 ( style text pane -- )
|
: pane-write-1 ( style text pane -- )
|
||||||
pick not pick empty? and [
|
pick not pick empty? and [
|
||||||
3drop
|
3drop
|
||||||
|
@ -96,7 +98,7 @@ M: pane focusable-child* ( pane -- editor )
|
||||||
|
|
||||||
: pane-terpri ( pane -- )
|
: pane-terpri ( pane -- )
|
||||||
dup pane-current over pane-print-1
|
dup pane-current over pane-print-1
|
||||||
0 <shelf> over set-pane-current init-active-line ;
|
<shelf> over set-pane-current init-active-line ;
|
||||||
|
|
||||||
: pane-write ( style pane list -- )
|
: pane-write ( style pane list -- )
|
||||||
3dup car swap pane-write-1 cdr dup
|
3dup car swap pane-write-1 cdr dup
|
||||||
|
|
|
@ -1,9 +1,10 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-presentations
|
||||||
USING: compiler generic hashtables inference inspector io jedit
|
USING: compiler gadgets gadgets-buttons gadgets-labels
|
||||||
kernel lists memory namespaces parser prettyprint sequences
|
gadgets-menus gadgets-panes generic hashtables inference
|
||||||
styles vectors words ;
|
inspector io jedit kernel lists memory namespaces parser
|
||||||
|
prettyprint sequences styles vectors words ;
|
||||||
|
|
||||||
SYMBOL: commands
|
SYMBOL: commands
|
||||||
|
|
||||||
|
@ -43,6 +44,9 @@ SYMBOL: commands
|
||||||
gadget pick assoc dup
|
gadget pick assoc dup
|
||||||
[ 2nip ] [ drop <styled-label> init-commands ] ifte ;
|
[ 2nip ] [ drop <styled-label> init-commands ] ifte ;
|
||||||
|
|
||||||
|
: <object-presentation> ( object -- gadget )
|
||||||
|
dup presented swons unit swap unparse-short <presentation> ;
|
||||||
|
|
||||||
: gadget. ( gadget -- )
|
: gadget. ( gadget -- )
|
||||||
gadget swons unit
|
gadget swons unit
|
||||||
"This stream does not support live gadgets"
|
"This stream does not support live gadgets"
|
||||||
|
@ -62,7 +66,6 @@ SYMBOL: commands
|
||||||
[ compound? ] "Annotate with breakpoint" [ break ] define-command
|
[ compound? ] "Annotate with breakpoint" [ break ] define-command
|
||||||
[ compound? ] "Annotate with profiling" [ profile ] define-command
|
[ compound? ] "Annotate with profiling" [ profile ] define-command
|
||||||
[ word? ] "Compile" [ recompile ] define-command
|
[ word? ] "Compile" [ recompile ] define-command
|
||||||
[ word? ] "Decompile" [ decompile ] define-command
|
|
||||||
[ word? ] "Show stack effect" [ unit infer . ] define-command
|
[ word? ] "Show stack effect" [ unit infer . ] define-command
|
||||||
[ word? ] "Show dataflow IR" [ word-def t dataflow. ] define-command
|
[ word? ] "Show dataflow IR" [ word-def t dataflow. ] define-command
|
||||||
[ word? ] "Show linear IR" [ precompile ] define-command
|
[ word? ] "Show linear IR" [ precompile ] define-command
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-scrolling
|
||||||
USING: generic kernel lists math matrices namespaces sequences
|
USING: gadgets gadgets-layouts generic kernel lists math
|
||||||
threads vectors styles ;
|
namespaces sequences threads vectors styles ;
|
||||||
|
|
||||||
! A viewport can be scrolled.
|
! A viewport can be scrolled.
|
||||||
TUPLE: viewport ;
|
TUPLE: viewport ;
|
||||||
|
@ -83,5 +83,6 @@ M: scroller focusable-child* ( scroller -- viewport )
|
||||||
M: scroller layout* ( scroller -- )
|
M: scroller layout* ( scroller -- )
|
||||||
dup scroller-bottom? [
|
dup scroller-bottom? [
|
||||||
f over set-scroller-bottom?
|
f over set-scroller-bottom?
|
||||||
dup dup scroller-viewport viewport-dim scroll
|
dup dup scroller-viewport viewport-dim
|
||||||
|
{ 0 1 0 } v* scroll
|
||||||
] when delegate layout* ;
|
] when delegate layout* ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-scrolling
|
||||||
USING: generic kernel lists math matrices namespaces sequences
|
USING: gadgets gadgets-buttons gadgets-layouts generic kernel
|
||||||
threads vectors styles ;
|
lists math namespaces sequences threads vectors styles ;
|
||||||
|
|
||||||
! An elevator has a thumb that may be moved up and down.
|
! An elevator has a thumb that may be moved up and down.
|
||||||
TUPLE: elevator ;
|
TUPLE: elevator ;
|
||||||
|
|
|
@ -1,8 +1,8 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets-splitters
|
||||||
USING: generic kernel lists math matrices namespaces sequences
|
USING: gadgets gadgets-layouts generic kernel lists math
|
||||||
styles vectors ;
|
namespaces sequences styles vectors ;
|
||||||
|
|
||||||
TUPLE: divider splitter ;
|
TUPLE: divider splitter ;
|
||||||
|
|
||||||
|
@ -31,9 +31,10 @@ C: divider ( -- divider )
|
||||||
dup divider-actions ;
|
dup divider-actions ;
|
||||||
|
|
||||||
C: splitter ( first second split vector -- splitter )
|
C: splitter ( first second split vector -- splitter )
|
||||||
[ >r 1 swap <pack> r> set-delegate ] keep
|
[ >r <pack> r> set-delegate ] keep
|
||||||
[ set-splitter-split ] keep
|
[ set-splitter-split ] keep
|
||||||
[ >r >r <divider> r> 3vector r> add-gadgets ] keep ;
|
[ >r >r <divider> r> 3vector r> add-gadgets ] keep
|
||||||
|
1 over set-pack-fill ;
|
||||||
|
|
||||||
: <x-splitter> ( first second split -- splitter )
|
: <x-splitter> ( first second split -- splitter )
|
||||||
{ 0 1 0 } <splitter> ;
|
{ 0 1 0 } <splitter> ;
|
||||||
|
|
|
@ -6,12 +6,10 @@ sequences strings styles ;
|
||||||
|
|
||||||
: draw-surface ( x y surface -- )
|
: draw-surface ( x y surface -- )
|
||||||
surface get SDL_UnlockSurface
|
surface get SDL_UnlockSurface
|
||||||
[
|
[ [ surface-rect ] keep swap surface get 0 0 ] keep
|
||||||
[ surface-rect ] keep swap surface get 0 0
|
surface-rect swap rot SDL_UpperBlit drop
|
||||||
] keep surface-rect swap rot SDL_UpperBlit drop
|
surface get dup must-lock-surface?
|
||||||
surface get dup must-lock-surface? [
|
[ SDL_LockSurface ] when drop ;
|
||||||
SDL_LockSurface
|
|
||||||
] when drop ;
|
|
||||||
|
|
||||||
: filter-nulls ( str -- str )
|
: filter-nulls ( str -- str )
|
||||||
[ dup 0 = [ drop CHAR: \s ] when ] map ;
|
[ dup 0 = [ drop CHAR: \s ] when ] map ;
|
||||||
|
|
|
@ -1,8 +1,9 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets
|
||||||
USING: generic help io kernel listener lists math namespaces
|
USING: gadgets-listener generic help io kernel listener lists
|
||||||
prettyprint sdl sequences shells styles threads words ;
|
math namespaces prettyprint sdl sequences shells styles threads
|
||||||
|
words ;
|
||||||
|
|
||||||
: init-world
|
: init-world
|
||||||
global [
|
global [
|
||||||
|
|
|
@ -1,9 +1,9 @@
|
||||||
! Copyright (C) 2005 Slava Pestov.
|
! Copyright (C) 2005 Slava Pestov.
|
||||||
! See http://factor.sf.net/license.txt for BSD license.
|
! See http://factor.sf.net/license.txt for BSD license.
|
||||||
IN: gadgets
|
IN: gadgets
|
||||||
USING: alien errors generic io kernel lists math memory
|
USING: alien errors gadgets-layouts generic io kernel lists math
|
||||||
namespaces prettyprint sdl sequences sequences strings threads
|
memory namespaces prettyprint sdl sequences sequences strings
|
||||||
vectors ;
|
threads vectors ;
|
||||||
|
|
||||||
! The world gadget is the top level gadget that all (visible)
|
! The world gadget is the top level gadget that all (visible)
|
||||||
! gadgets are contained in. The current world is stored in the
|
! gadgets are contained in. The current world is stored in the
|
||||||
|
|
|
@ -77,11 +77,8 @@ M: port set-timeout ( timeout port -- )
|
||||||
dup port-error f rot set-port-error throw ;
|
dup port-error f rot set-port-error throw ;
|
||||||
|
|
||||||
: report-error ( error port -- )
|
: report-error ( error port -- )
|
||||||
[
|
[ "Error on fd " % dup port-handle # ": " % swap % ] "" make
|
||||||
"Error on fd " %
|
swap set-port-error ;
|
||||||
dup port-handle number>string %
|
|
||||||
": " % swap %
|
|
||||||
] "" make swap set-port-error ;
|
|
||||||
|
|
||||||
: defer-error ( port -- ? )
|
: defer-error ( port -- ? )
|
||||||
#! Return t if it is an unrecoverable error.
|
#! Return t if it is an unrecoverable error.
|
||||||
|
|
|
@ -81,10 +81,10 @@ C: accept-task ( port -- task )
|
||||||
|
|
||||||
: inet-ntoa ( n -- str )
|
: inet-ntoa ( n -- str )
|
||||||
ntohl [
|
ntohl [
|
||||||
dup -24 shift HEX: ff bitand number>string % CHAR: . ,
|
dup -24 shift HEX: ff bitand # CHAR: . ,
|
||||||
dup -16 shift HEX: ff bitand number>string % CHAR: . ,
|
dup -16 shift HEX: ff bitand # CHAR: . ,
|
||||||
dup -8 shift HEX: ff bitand number>string % CHAR: . ,
|
dup -8 shift HEX: ff bitand # CHAR: . ,
|
||||||
HEX: ff bitand number>string %
|
HEX: ff bitand #
|
||||||
] "" make ;
|
] "" make ;
|
||||||
|
|
||||||
: do-accept ( port sockaddr fd -- )
|
: do-accept ( port sockaddr fd -- )
|
||||||
|
|
|
@ -20,38 +20,36 @@ M: word set-word-xt ( xt w -- ) 7 set-integer-slot ;
|
||||||
#! Sort a list of words by name.
|
#! Sort a list of words by name.
|
||||||
[ swap word-name swap word-name lexi ] sort ;
|
[ swap word-name swap word-name lexi ] sort ;
|
||||||
|
|
||||||
|
: uses ( word -- uses )
|
||||||
|
#! Outputs a list of words that this word directly calls.
|
||||||
|
[
|
||||||
|
dup word-def [
|
||||||
|
dup word? [ 2dup eq? [ dup , ] unless ] when 2drop
|
||||||
|
] tree-each-with
|
||||||
|
] { } make prune ;
|
||||||
|
|
||||||
! The cross-referencer keeps track of word dependencies, so that
|
! The cross-referencer keeps track of word dependencies, so that
|
||||||
! words can be recompiled when redefined.
|
! words can be recompiled when redefined.
|
||||||
SYMBOL: crossref
|
SYMBOL: crossref
|
||||||
|
|
||||||
: (add-crossref)
|
: (add-crossref) crossref get [ dupd nest set-hash ] bind ;
|
||||||
dup word? [
|
|
||||||
crossref get [ dupd nest set-hash ] bind
|
|
||||||
] [
|
|
||||||
2drop
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
: add-crossref ( word -- )
|
: add-crossref ( word -- )
|
||||||
#! Marks each word in the quotation as being a dependency
|
#! Marks each word in the quotation as being a dependency
|
||||||
#! of the word.
|
#! of the word.
|
||||||
crossref get [
|
crossref get [
|
||||||
dup word-def [ (add-crossref) ] tree-each-with
|
dup uses [ (add-crossref) ] each-with
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] ifte ;
|
] ifte ;
|
||||||
|
|
||||||
: (remove-crossref)
|
: (remove-crossref) crossref get [ nest remove-hash ] bind ;
|
||||||
dup word? [
|
|
||||||
crossref get [ nest remove-hash ] bind
|
|
||||||
] [
|
|
||||||
2drop
|
|
||||||
] ifte ;
|
|
||||||
|
|
||||||
: remove-crossref ( word -- )
|
: remove-crossref ( word -- )
|
||||||
#! Marks each word in the quotation as not being a
|
#! Marks each word in the quotation as not being a
|
||||||
#! dependency of the word.
|
#! dependency of the word.
|
||||||
crossref get [
|
crossref get [
|
||||||
dup word-def [ (remove-crossref) ] tree-each-with
|
dup uses [ (remove-crossref) ] each-with
|
||||||
] [
|
] [
|
||||||
drop
|
drop
|
||||||
] ifte ;
|
] ifte ;
|
||||||
|
@ -126,3 +124,12 @@ M: object literalize ;
|
||||||
M: word literalize <wrapper> ;
|
M: word literalize <wrapper> ;
|
||||||
|
|
||||||
M: wrapper literalize <wrapper> ;
|
M: wrapper literalize <wrapper> ;
|
||||||
|
|
||||||
|
: gensym ( -- word )
|
||||||
|
#! Return a word that is distinct from every other word, and
|
||||||
|
#! is not contained in any vocabulary.
|
||||||
|
"G:"
|
||||||
|
global [ \ gensym dup inc get ] bind
|
||||||
|
number>string append f <word> ;
|
||||||
|
|
||||||
|
0 \ gensym global set-hash
|
||||||
|
|
Loading…
Reference in New Issue