</li>
-<li>Sequences:
+<li>Collections:
<ul>
<li><code>2each ( seq seq quot -- quot: elt -- elt )</code> combinator</li>
<li>Integers now support the sequence protocol. An integer is an increasing sequence of its predecessors. This means the <code>count ( n -- [ 0 ... n-1 ] )</code> word is gone; just use <code>>vector</code> instead. Also, <code>project</code> has been made redundant by <code>map</code>.</li>
<li>The <code>seq-transpose ( seq -- seq )</code> word is now named <code>flip</code>.
</li>
+<li>The matrices library has been greatly simplified. Matrices are now represented as vectors of vectors, and matrix words have been moved to the <code>math</code> vocabulary.</li>
+<li>More descriptive "out of bounds" errors.</li>
+<li>New <code>make-hash ( quot -- namespace )</code> combinator executes quotation in a new namespace, which is then pushed on the stack.</li>
+<li>The <code><namespace></code> word is gone. It would create a hashtable with a default capacity. Now, just write <code>{{ }} clone</code>.
</ul>
</li>
-<li>Prettyprinter:
+<li>Development tools:
<ul>
+<li>In the UI, object slots are now clickable in the inspector.</li>
+<li>Inspector now supports a history and an interactive loop; it prints a brief help message when it starts describing usage.</li>
<li>The prettyprinter has been merged with the unparser. The <code>unparse ( object -- string )</code> word has been moved to the <code>prettyprint</code> vocabulary, and can now produce a parsable string for any class supported by the prettyprinter.</li>
<li>New <code>unparse-short ( object -- string )</code> returns a string no longer than a single line.</li>
<li>The prettyprinter now supports many more configuration variables. See the handbook for details.</li>
+<li>New <code>profile ( word -- )</code> word. Causes the word's accumulative runtime to be stored in a global variable named by the word. This is done with the annotation facility, the word's definition is modified; use <code>reload ( word -- )</code> to get the old definition back from the source file.</li>
</ul>
</li>
+
<li>Everything else:
<ul>
<li>New <code>sleep ( ms -- )</code> word pauses current thread for a number of milliseconds.</li>
-<li>New <code>make-hash ( quot -- namespace )</code> combinator executes quotation in a new namespace, which is then pushed on the stack.</li>
-<li>Erlang/Termite-style concurrency library in <code>contrib/concurrency</code> (Chris Double).</li>
-<li>Object slots are now clickable in the inspector</li>
-<li>The matrices library has been greatly simplified. Matrices are now represented as vectors of vectors, and matrix words have been moved to the <code>math</code> vocabulary.</li>
-<li>More descriptive "out of bounds" errors.</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; see its documentation comment for details. Note that it does not compile.</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
and the syntax doesn't use so many spaces. New way to write the quadratic formula:
<pre>MATH: quadratic[a;b;c] =
- reader syntax for arrays, byte arrays, displaced aliens\r
- fix infer hang\r
- out of memory error when printing global namespace\r
-- HTML formatting\r
+- HTML prettyprinting\r
\r
+ ui:\r
\r
-- off-by-one error in pickup?\r
+- off-by-one error in pick-up?\r
- closing ui does not stop timers\r
- adding/removing timers automatically for animated gadgets\r
- fix listener prompt display after presentation commands invoked\r
\r
+ kernel:\r
\r
+- first time hash/vector is grown, set size to something big\r
- merge timers with sleeping tasks\r
- what about tasks and timers between image restarts\r
- split: return vectors\r
#! backslash quote.
[
[ dup [ [[ CHAR: ' "\\'" ]] [[ CHAR: " "\\\"" ]] ] assoc [ % ] [ % ] ?ifte ] each
- ] make-string ;
+ ] "" make ;
: make-eval-javascript ( string -- string )
#! Give a string return some javascript that when
: live-search-apropos-word ( string -- )
#! Given a string that is a factor word, show the
#! aporpos of that word.
- <namespace> [
+ [
"browser" "responder" set
<pre>
stdio get <html-stream> [
apropos.
] with-stream
</pre>
- ] bind ;
+ ] with-scope ;
: live-updater-responder ( -- )
[
: get-live-updater-js ( filename -- string )
#! Return the liveUpdater javascript code as a string.
- <file-reader> [ get-live-updater-js* ] make-string ;
+ <file-reader> [ get-live-updater-js* ] "" make ;
: live-updater-url ( -- url )
#! Generate an URL to the liveUpdater.js code.
: todo-stylesheet ( -- string )
#! Return the stylesheet for the todo list
- [
- "table.list {" %
- " text-align:center;" %
- " font-family: Verdana;" %
- " font-weight: normal;" %
- " font-size: 11px;" %
- " color: #404040;" %
- " background-color: #fafafa;" %
- " border: 1px #6699cc solid;" %
- " border-collapse: collapse;" %
- " boder-spacing: 0px;" %
- "}" %
- "tr.heading {" %
- " border-bottom: 2px solid #6699cc;" %
- " border-left: 1px solix #6699cc;" %
- " background-color: #BEC8D1;" %
- " text-align: left;" %
- " text-indent: 0px;" %
- " font-family: verdana;" %
- " font-weight: bold;" %
- " color: #404040;" %
- "}" %
- "tr.item {" %
- " border-bottom: 1px solid #9cf;" %
- " border-top: 0px;" %
- " border-left: 1px solid #9cf;" %
- " border-right: 0px;" %
- " text-align: left;" %
- " text-indent: 2px;" %
- " font-family: verdana, sans-serif, arial;" %
- " font-weight: normal;" %
- " color: #404040;" %
- " background-color: #fafafa;" %
- "}" %
- "tr.complete {" %
- " border-bottom: 1px solid #9cf;" %
- " border-top: 0px;" %
- " border-left: 1px solid #9cf;" %
- " border-right: 0px;" %
- " text-align: left;" %
- " text-indent: 2px;" %
- " font-family: verdana, sans-serif, arial;" %
- " font-weight: normal;" %
- " color: #404040;" %
- " background-color: #ccc;" %
- "}" %
- "td.lbl {" %
- " font-weight: bold; text-align: right;" %
- "}" %
- "tr.required {" %
- " background: #FCC;" %
- "}" %
- "input:focus {" %
- " background: yellow;" %
- "}" %
- "textarea:focus {" %
- " background: yellow;" %
- "}" %
- ] make-string ;
+ {
+ "table.list {"
+ " text-align:center;"
+ " font-family: Verdana;"
+ " font-weight: normal;"
+ " font-size: 11px;"
+ " color: #404040;"
+ " background-color: #fafafa;"
+ " border: 1px #6699cc solid;"
+ " border-collapse: collapse;"
+ " boder-spacing: 0px;"
+ "}"
+ "tr.heading {"
+ " border-bottom: 2px solid #6699cc;"
+ " border-left: 1px solix #6699cc;"
+ " background-color: #BEC8D1;"
+ " text-align: left;"
+ " text-indent: 0px;"
+ " font-family: verdana;"
+ " font-weight: bold;"
+ " color: #404040;"
+ "}"
+ "tr.item {"
+ " border-bottom: 1px solid #9cf;"
+ " border-top: 0px;"
+ " border-left: 1px solid #9cf;"
+ " border-right: 0px;"
+ " text-align: left;"
+ " text-indent: 2px;"
+ " font-family: verdana, sans-serif, arial;"
+ " font-weight: normal;"
+ " color: #404040;"
+ " background-color: #fafafa;"
+ "}"
+ "tr.complete {"
+ " border-bottom: 1px solid #9cf;"
+ " border-top: 0px;"
+ " border-left: 1px solid #9cf;"
+ " border-right: 0px;"
+ " text-align: left;"
+ " text-indent: 2px;"
+ " font-family: verdana, sans-serif, arial;"
+ " font-weight: normal;"
+ " color: #404040;"
+ " background-color: #ccc;"
+ "}"
+ "td.lbl {"
+ " font-weight: bold; text-align: right;"
+ "}"
+ "tr.required {"
+ " background: #FCC;"
+ "}"
+ "input:focus {"
+ " background: yellow;"
+ "}"
+ "textarea:focus {"
+ " background: yellow;"
+ "}"
+ } concat ;
: todo-stylesheet-url ( -- url )
#! Generate an URL for the stylesheet.
: get-todo-filename ( database-path <todo> -- filename )
#! Get the filename containing the todo list details.
- [ swap % todo-username % ".todo" % ] make-string ;
+ [ swap % todo-username % ".todo" % ] "" make ;
: add-default-todo-item ( <todo> -- )
#! Add a default todo item. This is a workaround for the
: show-todo-list ( -- )
#! Show the current todo list.
[
- [ "todo" get todo-username % "'s To Do list" % ] make-string
+ [ "todo" get todo-username % "'s To Do list" % ] "" make
[ include-todo-stylesheet ]
[
"todo" get write-item-table
#! each successive value being the result of applying quot to
#! n.
swap dup unit delay -rot
- [ , dup , \ call , , \ lfrom-by , ] make-list delay lcons ;
+ [ , dup , \ call , , \ lfrom-by , ] [ ] make delay lcons ;
: lnaturals 0 lfrom ;
: lpositves 1 lfrom ;
: lcons ( lcar lcdr -- promise )
#! Given a car and cdr, both lazy values, return a lazy cons.
- swap [ , , \ <lcons> , ] make-list delay ;
+ swap [ , , \ <lcons> , ] [ ] make delay ;
: lunit ( lvalue -- llist )
#! Given a lazy value (a quotation that when called produces
drop
] [
swap 2dup
- [ , \ lcdr , , \ lmap , ] make-list delay >r
- [ , \ lcar , , \ call , ] make-list delay r>
+ [ , \ lcdr , , \ lmap , ] [ ] make delay >r
+ [ , \ lcar , , \ call , ] [ ] make delay r>
lcons
] ifte ;
nip
] [
swap dupd ( llist llist n -- )
- [ [ 1 - ] cons , \ call , , \ lcdr , \ ltake , ] make-list delay >r
- [ , \ lcar , ] make-list delay r>
+ [ [ 1 - ] cons , \ call , , \ lcdr , \ ltake , ] [ ] make delay >r
+ [ , \ lcar , ] [ ] make delay r>
lcons
] ifte
] ifte ;
] bind ;
: library-abi ( library -- abi )
- library [ [ "abi" get ] bind ] [ "cdecl" ] ifte* ;
+ library "abi" swap ?hash [ "cdecl" ] unless* ;
: DLL" skip-blank parse-string dlopen swons ; parsing
[
"width" get , \ <c-object> , \ tuck , 0 ,
"setter" get %
- ] make-list
+ ] [ ] make
] bind define-compound ;
: init-c-type ( name vocab -- )
: parse-arglist ( lst -- types stack effect )
unpair [
" " % [ "," ?tail drop % " " % ] each "-- " %
- ] make-string ;
+ ] "" make ;
: (define-c-word) ( type lib func types stack-effect -- )
>r over create-in >r
] "infer" set-word-prop
global [
- "libraries" get [ <namespace> "libraries" set ] unless
+ "libraries" get [ {{ }} clone "libraries" set ] unless
] bind
M: compound (uncrossref)
"/library/bootstrap/primitives.factor" run-resource
-! The make-list form creates a boot quotation
+! The [ ] make form creates a boot quotation
[
[
[ hashtable? ] instances
} [ dup print parse-resource % ] each
[ "/library/bootstrap/boot-stage2.factor" run-resource ] %
-] make-list
+] [ ] make
vocabularies get [
"!syntax" get "syntax" set
] when\r
] unless\r
\r
-: compile? "compile" get supported-cpu? and ;\r
-\r
-compile? [\r
- "Compiling base..." print\r
-\r
- \ car compile\r
- \ * compile\r
- \ = compile\r
- \ string>number compile\r
- \ number>string compile\r
- \ scan compile\r
- \ (generate) compile\r
-] when\r
-\r
"Loading more library code..." print\r
\r
t [\r
"/library/help/tutorial.factor"\r
] pull-in\r
\r
+: compile? "compile" get supported-cpu? and ;\r
+\r
+compile? [\r
+ "Compiling base..." print\r
+\r
+ \ car compile\r
+ \ * compile\r
+ \ = compile\r
+ \ string>number compile\r
+ \ number>string compile\r
+ \ scan compile\r
+ \ (generate) compile\r
+] when\r
+\r
compile? [\r
unix? [\r
"/library/unix/types.factor"\r
r> emit ;
: word-error ( word msg -- )
- [ % dup word-vocabulary % " " % word-name % ] make-string
+ [ % dup word-vocabulary % " " % word-name % ] "" make
throw ;
: transfer-word ( word -- word )
! Bring up a bare cross-compiling vocabulary.
"syntax" vocab
-<namespace> vocabularies set
+{{ }} clone vocabularies set
f crossref set
vocabularies get [ "syntax" set [ reveal ] each ] bind
! Okay, now we have primitives fleshed out. Bring up the generic
! word system.
: builtin-predicate ( class predicate -- )
- [ \ type , over types first , \ eq? , ] make-list
+ [ \ type , over types first , \ eq? , ] [ ] make
define-predicate ;
: register-builtin ( class -- )
define-slots
register-builtin ;
-<namespace> typemap set
+{{ }} clone typemap set
num-types empty-vector builtins set
! Catch-all metaclass for providing a default method.
: global ( -- g ) 4 getenv ;
-: <namespace> ( -- n )
- #! Create a new namespace.
- 23 <hashtable> ; flushable
-
: (get) ( var ns -- value )
#! Internal word for searching the namestack.
dup [
: nest ( variable -- hash )
#! If the variable is set in the current namespace, return
#! its value, otherwise set its value to a new namespace.
- dup namespace hash [ ] [ >r <namespace> dup r> set ] ?ifte ;
+ dup namespace hash [ ] [ >r {{ }} clone dup r> set ] ?ifte ;
: change ( var quot -- )
#! Execute the quotation with the variable value on the
#! Execute a quotation with a namespace on the namestack.
swap >n call n> drop ; inline
-: make-hash ( quot -- hash ) <namespace> >n call n> ; inline
+: make-hash ( quot -- hash ) {{ }} clone >n call n> ; inline
: with-scope ( quot -- ) make-hash drop ; inline
! Building sequences
SYMBOL: building
-: make-seq ( quot sequence -- sequence )
- #! Call , and % from the quotation to append to a sequence.
- [ building set call building get ] with-scope ; inline
+: make ( quot proto -- )
+ #! Call , and % from "quot" to append to a sequence
+ #! that has the same type as "proto".
+ [
+ dup thaw building set >r call building get r> like
+ ] with-scope ; inline
: , ( obj -- )
#! Add to the sequence being built with make-seq.
building get push ;
-: unique, ( obj -- )
- #! Add the object to the sequence being built with make-seq
- #! unless an equal object has already been added.
- building get 2dup member? [ 2drop ] [ push ] ifte ;
-
: % ( seq -- )
#! Append to the sequence being built with make-seq.
building get swap nappend ;
-: make-vector ( quot -- vector )
- 100 <vector> make-seq ; inline
-
-: make-list ( quot -- list )
- make-vector >list ; inline
-
-: make-sbuf ( quot -- sbuf )
- 100 <sbuf> make-seq ; inline
-
-: make-string ( quot -- string )
- make-sbuf >string ; inline
-
-: make-rstring ( quot -- string )
- make-sbuf <reversed> >string ; inline
-
! Building hashtables, and computing a transitive closure.
SYMBOL: hash-buffer
: closure ( key hash -- list )
[
- <namespace> hash-buffer set
+ {{ }} clone hash-buffer set
(closure)
hash-buffer get hash-keys
] with-scope ;
: length= ( seq seq -- ? ) length swap length number= ;
-: (sequence=) ( seq seq i -- ? )
- over length over number= [
- 3drop t
- ] [
- 3dup 2nth = [ 1 + (sequence=) ] [ 3drop f ] ifte
- ] ifte ;
-
: sequence= ( seq seq -- ? )
#! Check if two sequences have the same length and elements,
#! but not necessarily the same class.
- over general-list? over general-list? or [
- swap >list swap >list =
+ 2dup length= [
+ dup length [ >r 2dup r> 2nth = ] all? 2nip
] [
- 2dup length= [ 0 (sequence=) ] [ 2drop f ] ifte
+ 2drop f
] ifte ; flushable
M: sequence = ( obj seq -- ? )
[ 2swap [ slip push ] 2keep ] 2each nip
] keep like ; inline
-: find* ( i seq quot -- i elt )
+: find* ( i seq quot -- i elt )
pick pick length >= [
3drop -1 f
] [
: member? ( obj seq -- ? ) [ = ] contains-with? ; flushable
: memq? ( obj seq -- ? ) [ eq? ] contains-with? ; flushable
: remove ( obj list -- list ) [ = not ] subset-with ; flushable
-: remq ( obj list -- list ) [ eq? not ] subset-with ; flushable
: copy-into ( start to from -- )
dup length [ >r pick r> + pick set-nth ] 2each 2drop ;
USING: generic kernel kernel-internals lists math namespaces
strings vectors ;
-: head-slice ( n seq -- slice )
- #! n is an index from the start of the sequence.
- 0 -rot <slice> ; flushable
+: head-slice ( n seq -- slice ) 0 -rot <slice> ; flushable
-: head-slice* ( n seq -- slice )
- #! n is an index from the end of the sequence.
- [ length swap - ] keep head-slice ; flushable
+: tail-slice ( n seq -- slice ) [ length ] keep <slice> ; flushable
-: tail-slice ( n seq -- slice )
- #! n is an index from the start of the sequence.
- [ length ] keep <slice> ; flushable
+: (slice*) [ length swap - ] keep ;
-: tail-slice* ( n seq -- slice )
- #! n is an index from the end of the sequence.
- [ length swap - ] keep tail-slice ; flushable
+: head-slice* ( n seq -- slice ) (slice*) head-slice ; flushable
-: subseq ( from to seq -- seq )
- #! Makes a new sequence with the same contents and type as
- #! the slice of another sequence.
- [ <slice> ] keep like ; flushable
+: tail-slice* ( n seq -- slice ) (slice*) tail-slice ; flushable
-M: object head ( index seq -- seq )
- [ head-slice ] keep like ;
+: subseq ( from to seq -- seq ) [ <slice> ] keep like ; flushable
-: head* ( n seq -- seq )
- [ head-slice* ] keep like ; flushable
+M: object head ( index seq -- seq ) [ head-slice ] keep like ;
-M: object tail ( index seq -- seq )
- [ tail-slice ] keep like ;
+: head* ( n seq -- seq ) [ head-slice* ] keep like ; flushable
-: tail* ( n seq -- seq )
- [ tail-slice* ] keep like ; flushable
+M: object tail ( index seq -- seq ) [ tail-slice ] keep like ;
-: length< ( seq seq -- ? )
- swap length swap length < ; flushable
+: tail* ( n seq -- seq ) [ tail-slice* ] keep like ; flushable
+
+: length< ( seq seq -- ? ) swap length swap length < ; flushable
: head? ( seq begin -- ? )
2dup length< [
: ?tail ( seq end -- seq ? )
2dup tail? [ length swap head* t ] [ drop f ] ifte ; flushable
-: cut ( index seq -- seq seq )
- #! Returns 2 sequences, that when concatenated yield the
- #! original sequence.
- [ head ] 2keep tail ; flushable
-
: group-advance subseq , >r tuck + swap r> ;
: group-finish nip dup length swap subseq , ;
: group ( n seq -- list )
#! Split a sequence into element chunks.
- [ 0 -rot (group) ] make-vector ; flushable
+ [ 0 -rot (group) ] { } make ; flushable
: start-step ( subseq seq n -- subseq slice )
pick length dupd + rot <slice> ;
: split ( seq subseq -- list )
#! Split the sequence at each occurrence of subseq, and push
#! a list of the pieces.
- [ 0 -rot (split) ] make-list ; flushable
+ [ 0 -rot (split) ] [ ] make ; flushable
compiled-offset 0 compile-cell ;
: init-assembler ( -- )
- global [ <namespace> interned-literals set ] bind ;
+ {{ }} clone interned-literals global set-hash ;
: w>h/h dup -16 shift HEX: ffff bitand >r HEX: ffff bitand r> ;
#! purposes.
gensym [ swap define-compound ] keep dup compile execute ;
+\ dataflow profile
\ optimize profile
\ linearize profile
\ simplify profile
+\ generate profile
+\ kill-node profile
+\ partial-eval profile
+\ inline-method profile
+\ apply-identities profile
+\ subst-values profile
+\ split-branch profile
[[ fixnum> %fixnum> ]]
[[ eq? %eq? ]]
] [
- uncons [ literalize , \ binary-op , ] make-list
+ uncons [ literalize , \ binary-op , ] [ ] make
"intrinsic" set-word-prop
] each
#! Transform dataflow IR into linear IR. This strips out
#! stack flow information, and flattens conditionals into
#! jumps and labels.
- [ %prologue , linearize-node ] make-list ;
+ [ %prologue , linearize-node ] [ ] make ;
M: #label linearize-node* ( node -- )
<label> dup %return-to , >r
DEFER: callcc1
IN: errors
-TUPLE: no-method object generic ;
+! This is a very lightweight exception handling system.
-: no-method ( object generic -- )
- #! We 2dup here to leave both values on the stack, for
- #! post-mortem inspection.
- <no-method> throw ;
+TUPLE: no-method object generic ;
-! This is a very lightweight exception handling system.
+: no-method ( object generic -- ) <no-method> throw ;
: catchstack ( -- cs ) 6 getenv ;
: set-catchstack ( cs -- ) 6 setenv ;
: init-methods ( word -- )
dup "methods" word-prop
- [ drop ] [ <namespace> "methods" set-word-prop ] ifte ;
+ [ drop ] [ {{ }} clone "methods" set-word-prop ] ifte ;
! Defining generic words
: math-vtable ( picker quot -- )
[
swap , \ tag ,
- [ num-tags swap map % ] make-vector ,
+ [ num-tags swap map % ] { } make ,
\ dispatch ,
- ] make-list ; inline
+ ] [ ] make ; inline
: math-class? ( object -- ? )
dup word? [ "math-priority" word-prop ] [ drop f ] ifte ;
3dup nip "definition" set-word-prop
pick predicate "metaclass" set-word-prop
pick "superclass" word-prop "predicate" word-prop
- [ \ dup , % , [ drop f ] , \ ifte , ] make-list
+ [ \ dup , % , [ drop f ] , \ ifte , ] [ ] make
define-predicate ;
PREDICATE: word predicate metaclass predicate = ;
>r word-name "-" r> append3 "in" get 2vector ;
: writer-word ( class name -- word )
- [ swap "set-" % word-name % "-" % % ] make-string
+ [ swap "set-" % word-name % "-" % % ] "" make
"in" get 2vector ;
: simple-slot ( class name -- reader writer )
namespaces sequences vectors words ;
: error-method ( picker word -- method )
- [ swap % literalize , \ no-method , ] make-list ;
+ [ swap % literalize , \ no-method , ] [ ] make ;
: empty-method ( picker word -- method )
over [ dup ] = [
[
[ dup delegate ] % dup unit , error-method , \ ?ifte ,
- ] make-list
+ ] [ ] make
] [
error-method
] ifte ;
[ uncons >r "predicate" word-prop append r> cons ] map-with ;
: alist>quot ( default alist -- quot )
- [ unswons [ % , , \ ifte , ] make-list ] each ;
+ [ unswons [ % , , \ ifte , ] [ ] make ] each ;
: sort-methods ( assoc -- vtable )
#! Input is a predicate -> method association.
2dup methods class-predicates >r empty-method r> alist>quot ;
: big-generic ( picker word -- def )
- [ over % \ type , <vtable> , \ dispatch , ] make-list ;
+ [ over % \ type , <vtable> , \ dispatch , ] [ ] make ;
: small-generic? ( word -- ? )
"methods" word-prop hash-size 3 <= ;
#! Make a foo? word for testing the tuple class at the top
#! of the stack.
dup predicate-word
- [ \ class-tuple , over literalize , \ eq? , ] make-list
+ [ \ class-tuple , over literalize , \ eq? , ] [ ] make
define-predicate ;
: forget-tuple ( class -- )
: define-constructor ( word class def -- )
>r [
dup literalize , "tuple-size" word-prop , \ make-tuple ,
- ] make-list r> append define-compound ;
+ ] [ ] make r> append define-compound ;
: default-constructor ( tuple -- )
[ tuple-constructor ] keep dup [
"slots" word-prop 1 swap tail-slice reverse-slice
[ peek unit , \ keep , ] each
- ] make-list define-constructor ;
+ ] [ ] make define-constructor ;
: define-tuple ( tuple slots -- )
2dup check-shape
: get-random-id ( -- id )
#! Generate a random id to use for continuation URL's
- [ 32 [ 0 9 random-int CHAR: 0 + , ] times ] make-string
+ [ 32 [ 0 9 random-int CHAR: 0 + , ] times ] "" make
string>number 36 >base ;
#! Name of variable holding the table of continuations.
: reset-continuation-table ( -- )
#! Create the initial global table
- <namespace> table set ;
+ {{ }} clone table set ;
#! Tuple for holding data related to a continuation.
TUPLE: item expire? quot id time-added ;
[
"HTTP/1.1 302 Document Moved\nLocation: " % %
"\nContent-Length: 0\nContent-Type: text/plain\n\n" %
- ] make-string call-exit-continuation ;
+ ] "" make call-exit-continuation ;
: redirect-to-here ( -- )
#! Force a redirect to the client browser so that the browser
#! Convert the given quotation so it works as a callback
#! by returning a quotation that will pass the original
#! quotation to the callback continuation.
- [ , callback-cc get , \ call , ] make-list ;
+ [ , callback-cc get , \ call , ] [ ] make ;
: quot-href ( text quot -- )
#! Write to standard output an HTML HREF where the href,
#!
#! Convert the quotation so it is run within a session namespace
#! and that namespace is initialized first.
- \ init-session-namespace swons [ , \ with-scope , ] make-list
+ \ init-session-namespace swons [ , \ with-scope , ] [ ] make
[
[ cont-get/post-responder ] "get" set
[ cont-get/post-responder ] "post" set
#! Remove all existing responders, and create a blank
#! responder table.
global [
- <namespace> responders set
+ {{ }} clone responders set
! Runs all unit tests and dumps result to the client. This uses
! a lot of server resources, so disable it on a busy server.
! The root directory is served by...
"file" set-default-responder
- vhosts nest [ <namespace> "default" set ] bind
+ vhosts nest [ {{ }} clone "default" set ] bind
] bind
[
number>string "Content-Length" swons ,
"Content-Type" swons ,
- ] make-list "200 OK" response terpri ;
+ ] [ ] make "200 OK" response terpri ;
: serve-static ( filename mime-type -- )
over file-length file-response "method" get "head" = [
! <a href= "http://" swap append a> "click" write </a>
!
! (url -- )
-! <a href= [ "http://" % % ] make-string a> "click" write </a>
+! <a href= [ "http://" % % ] "" make a> "click" write </a>
!
! Tags that have no 'closing' equivalent have a trailing tag/> form:
!
#! suitable for embedding in an html tag.
reverse [
[ dup car % "='" % cdr % "'" % ] each
- ] make-string ;
+ ] "" make ;
: write-attributes ( n: namespace -- )
#! With the attribute namespace on the stack, get the attributes
! : <p ( -- n: <namespace> )
! #! Used for setting inline attributes. Prints out
! #! an unclosed opening tag.
-! "<p" write <namespace> >n ;
+! "<p" write {{ }} clone >n ;
!
! : p> ( n: <namespace> -- )
! #! Used to close off inline attribute version of word.
!
! : <input ( -- n: <namespace> )
! #! Used for setting inline attributes.
-! "<input" write <namespace> >n ;
+! "<input" write {{ }} clone >n ;
!
! : input/> ( n: <namespace> -- )
! #! Used to close off inline attribute version of word
: def-for-html-word-<foo ( name -- name quot )
#! Return the name and code for the <foo patterned
#! word.
- "<" swap append dup [ write <namespace> >n ] cons ;
+ "<" swap append dup [ write {{ }} clone >n ] cons ;
: def-for-html-word-foo> ( name -- name quot )
#! Return the name and code for the foo> patterned
: def-for-html-word-</foo> ( name -- name quot )
#! Return the name and code for the </foo> patterned
#! word.
- [ "</" % % ">" % ] make-string dup [ write ] cons ;
+ [ "</" % % ">" % ] "" make dup [ write ] cons ;
: def-for-html-word-<foo/> ( name -- name quot )
#! Return the name and code for the <foo/> patterned
#! word.
- [ "<" % dup % "/>" % ] make-string swap
- [ "<" % % ">" % ] make-string
+ [ "<" % dup % "/>" % ] "" make swap
+ [ "<" % % ">" % ] "" make
[ write ] cons ;
: def-for-html-word-foo/> ( name -- name quot )
#! Convert <, >, &, ' and " to HTML entities.
[
[ dup html-entities assoc [ % ] [ , ] ?ifte ] each
- ] make-string ;
+ ] "" make ;
: hex-color, ( triplet -- )
[ >hex 2 CHAR: 0 pad-left % ] each ;
[ font-size size-css, ]
[ underline underline-css, ]
] assoc-apply
- ] make-string ;
+ ] "" make ;
: span-tag ( style quot -- )
over css-style dup "" = [
] when* "/" ?tail drop ;
: file-link-href ( path -- href )
- [ "/" % resolve-file-link url-encode % ] make-string ;
+ [ "/" % resolve-file-link url-encode % ] "" make ;
: file-link-tag ( style quot -- )
over file swap assoc [
url-encode %
"&word=" %
url-encode %
- ] make-string ;
+ ] "" make ;
: browser-link-tag ( style quot -- style )
over presented swap assoc dup word? [
CHAR: % , >hex 2 CHAR: 0 pad-left %
] ifte
] each
- ] make-string ;
+ ] "" make ;
: catch-hex> ( str -- n )
#! Push f if string is not a valid hex literal.
] ifte ;
: url-decode ( str -- str )
- [ 0 swap url-decode-iter ] make-string ;
+ [ 0 swap url-decode-iter ] "" make ;
[
"request" get % CHAR: / ,
"raw-query" get [ CHAR: ? , % ] when*
- ] make-string redirect ;
+ ] "" make redirect ;
: query>alist ( query -- alist )
dup [
: log-user-agent ( alist -- )
"User-Agent" swap assoc* [
- unswons [ % ": " % % ] make-string log
+ unswons [ % ": " % % ] "" make log
] when* ;
: prepare-url ( url -- url )
: infer-classes ( node -- )
[
- <namespace> value-classes set
- <namespace> value-literals set
- <namespace> ties set
+ {{ }} clone value-classes set
+ {{ }} clone value-literals set
+ {{ }} clone ties set
(infer-classes)
] with-scope ;
: make-node ( param in-d out-d in-r out-r node -- node )
[
- >r {{ }} {{ }} 10 <vector> f f <node> r> set-delegate
+ >r {{ }} clone {{ }} clone { } clone f f <node> r>
+ set-delegate
] keep ;
: param-node ( label) { } { } { } { } ;
[
dup node-in-d % dup node-out-d %
dup node-in-r % node-out-r %
- ] make-vector ;
+ ] { } make ;
: uses-value? ( value node -- ? )
node-values [ value-refers? ] contains-with? ;
: subst-values ( new old node -- )
#! Mutates the node.
[
- 10 <vector> substituted set [
+ { } clone substituted set [
3dup node-in-d (subst-values)
3dup node-in-r (subst-values)
3dup node-out-d (subst-values)
: init-inference ( recursive-state -- )
init-interpreter
- 0 <vector> d-in set
+ { } clone d-in set
recursive-state set
dataflow-graph off
current-node off ;
GENERIC: literals* ( node -- )
: literals ( node -- seq )
- [ [ literals* ] each-node ] make-vector ;
+ [ [ literals* ] each-node ] { } make ;
GENERIC: can-kill* ( literal node -- ? )
2dup node-in-d value-str %
"--" %
node-out-d value-str %
- ] make-string ;
+ ] "" make ;
M: #push node>quot ( ? node -- )
node-out-d [ literal-value literalize ] map % drop ;
] ifte ;
: dataflow>quot ( node ? -- quot )
- [ swap (dataflow>quot) ] make-list ;
+ [ swap (dataflow>quot) ] [ ] make ;
: dataflow. ( quot ? -- )
#! Print dataflow IR for a quotation. Flag indicates if
: collect-recursion ( label node -- seq )
#! Collect the input stacks of all #call-label nodes that
#! call given label.
- [ [ collect-recursion* ] each-node-with ] make-vector ;
+ [ [ collect-recursion* ] each-node-with ] { } make ;
GENERIC: solve-recursion*
] ifte ;
M: line-reader stream-readln ( line -- string )
- [ f swap (readln) ] make-string
+ [ f swap (readln) ] "" make
dup empty? [ f ? ] [ nip ] ifte ;
M: line-reader stream-read ( count line -- string )
: lines ( stream -- seq )
#! Read all lines from the stream into a sequence.
- [ 100 <vector> (lines) ] with-stream ;
+ [ { } clone (lines) ] with-stream ;
dup client-stream-host %
CHAR: : ,
client-stream-port number>string %
- ] make-string log ;
+ ] "" make log ;
: with-log-file ( file quot -- )
#! Calls to log inside quot will output to a file.
: modifiers, ( mod -- )
modifiers get [
- uncons pick bitand 0 = [ drop ] [ unique, ] ifte
+ uncons pick bitand 0 = [ drop ] [ , ] ifte
] each
drop ;
[
dup keyboard-event-mod modifiers,
keyboard-event-sym keysym,
- ] make-list ;
+ ] [ ] make prune ;
] [
integer,
] ifte
- ] make-rstring ;
+ ] "" make reverse ;
: >bin ( num -- string ) 2 >base ;
: >oct ( num -- string ) 8 >base ;
numerator number>string %
CHAR: / ,
denominator number>string %
- ] make-string ;
+ ] "" make ;
: fix-float ( str -- str )
#! This is terrible. Will go away when we do our own float
#! Read a string from the input stream, until it is
#! terminated by a ".
"col" [
- [ "line" get (parse-string) ] make-string swap
+ [ "line" get (parse-string) ] "" make swap
] change ;
] when ;
: pprint-string ( string prefix -- )
- [ % [ unparse-ch ] each CHAR: " , ] make-string
+ [ % [ unparse-ch ] each CHAR: " , ] "" make
do-string-limit f text ;
M: string pprint* ( str -- str ) "\"" pprint-string ;
dup first stack-picture%
"-- " %
second stack-picture%
- ] make-string ;
+ ] "" make ;
: stack-effect ( word -- string )
dup "stack-effect" word-prop [ ] [
: string-step ( n str -- )
2dup length > [
- dup [ "123" % % "456" % % "789" % ] make-string
+ dup [ "123" % % "456" % % "789" % ] "" make
dup dup length 2 /i 0 swap rot subseq
swap dup length 2 /i 1 + 1 swap rot subseq append
string-step
--- /dev/null
+IN: temporary
+USING: gadgets kernel namespaces test ;
+
+[ "Hello world" ]
+[
+ <frame> "frame" set
+ "Hello world" <label> 1 2 "frame" get set-frame-child
+ 1 2 "frame" get frame-child label-text
+] unit-test
+
+[ { { 2 2 2 } { 3 3 3 } { 4 4 4 } } ] [
+ {
+ { { 0 0 0 } { 1 1 1 } { 2 2 2 } }
+ { { 0 0 0 } { 3 3 3 } { 0 0 0 } }
+ { { 0 0 0 } { 0 0 0 } { 4 4 4 } }
+ } reduce-grid
+] unit-test
+
+[ { 9 9 9 } ] [
+ {
+ { { 0 0 0 } { 1 1 1 } { 2 2 2 } }
+ { { 0 0 0 } { 3 3 3 } { 0 0 0 } }
+ { { 0 0 0 } { 0 0 0 } { 4 4 4 } }
+ } frame-pref-dim
+] unit-test
+
+[
+ {
+ { { 1 2 0 } { 2 2 0 } { 3 2 0 } }
+ { { 1 4 0 } { 2 4 0 } { 3 4 0 } }
+ }
+] [
+ { 1 2 3 } { 2 4 } frame-layout
+] unit-test
+
+: sized-gadget ( dim -- gadget )
+ <gadget> [ set-rect-dim ] keep ;
+
+[ { 90 120 0 } ]
+[
+ <frame> "frame" set
+ { 10 20 0 } sized-gadget 1 2 "frame" get set-frame-child
+ { 30 40 0 } sized-gadget 2 0 "frame" get set-frame-child
+ { 50 60 0 } sized-gadget 0 1 "frame" get set-frame-child
+ "frame" get pref-dim
+] unit-test
+
+[ { 140 250 0 } ]
+[
+ <frame> "frame" set
+ { 10 20 0 } sized-gadget 1 2 "frame" get set-frame-child
+ { 30 40 0 } sized-gadget 2 0 "frame" get set-frame-child
+ { 50 60 0 } sized-gadget 0 1 "frame" get set-frame-child
+ { 100 150 0 } sized-gadget 1 1 "frame" get set-frame-child
+ "frame" get pref-dim
+] unit-test
! Testing the hash element counting
-<namespace> "counting" set
+{{ }} clone "counting" set
"value" "key" "counting" get set-hash
[ 1 ] [ "counting" get hash-size ] unit-test
"value" "key" "counting" get set-hash
] hash-each
] unit-test
-<namespace> "cache-test" set
+{{ }} clone "cache-test" set
[ 4 ] [ 1 "cache-test" get [ 3 + ] cache ] unit-test
[ 5 ] [ 2 "cache-test" get [ 3 + ] cache ] unit-test
[ "xyz" , "xyz" unique,
#{ 3 2 }# , #{ 3 2 }# unique,
1/5 , 1/5 unique,
- [ { } unique, ] make-list , ] make-list
+ [ { } unique, ] [ ] make , ] [ ] make
] unit-test
[ ] [ -1 [ ] times ] unit-test
[ ] [ 5 [ ] repeat ] unit-test
-[ [ 0 1 2 3 4 ] ] [ [ 5 [ dup , ] repeat ] make-list ] unit-test
-[ [ ] ] [ [ -1 [ dup , ] repeat ] make-list ] unit-test
+[ [ 0 1 2 3 4 ] ] [ [ 5 [ dup , ] repeat ] [ ] make ] unit-test
+[ [ ] ] [ [ -1 [ dup , ] repeat ] [ ] make ] unit-test
USE: test
USE: words
-<namespace> "test-namespace" set
+{{ }} clone "test-namespace" set
: test-namespace ( -- )
- <namespace> dup [ namespace = ] bind ;
+ {{ }} clone dup [ namespace = ] bind ;
[ t ] [ test-namespace ] unit-test
10 "some-global" set
[ f ]
-[ <namespace> [ f "some-global" set "some-global" get ] bind ]
+[ {{ }} clone [ f "some-global" set "some-global" get ] bind ]
unit-test
[ 2 ] [ 1 3 { 1 2 3 4 } <slice> length ] unit-test
[ { 2 3 } ] [ 1 3 { 1 2 3 4 } <slice> >vector ] unit-test
[ { 4 5 } ] [ 2 { 1 2 3 4 5 } tail-slice* >vector ] unit-test
-[ { 1 2 } { 3 4 } ] [ 2 { 1 2 3 4 } cut ] unit-test
[ { 3 4 } ] [ 2 4 1 10 <range> subseq >vector ] unit-test
[ { 3 4 } ] [ 0 2 2 4 1 10 <range> <slice> subseq >vector ] unit-test
[ "cba" ] [ 3 "abcdef" head-slice reverse ] unit-test
[ ] [ 10 [ [ -1000000 <sbuf> ] [ drop ] catch ] times ] unit-test
-[ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] make-string ] unit-test
+[ "abc" ] [ [ "a" "b" "c" ] [ [ % ] each ] "" make ] unit-test
[ "abc" ] [ "ab" "c" append ] unit-test
[ "abc" ] [ "a" "b" "c" append3 ] unit-test
[ "end" ] [ 14 "Beginning and end" tail ] unit-test
-[ "" 10 cut ] unit-test-fails
-
-[ "Beginning" " and end" ] [ 9 "Beginning and end" cut ] unit-test
-
[ "hello" "world" ] [ "hello world" " " split1 ] unit-test
[ "goodbye" f ] [ "goodbye" " " split1 ] unit-test
[ "" "" ] [ "great" "great" split1 ] unit-test
[
number>string % " ms run / " %
number>string % " ms GC time" %
- ] make-string print ;
+ ] "" make print ;
: unit-test ( output input -- )
[
"httpd/http-client" "sbuf" "threads" "parsing-word"
"inference" "interpreter" "alien"
"gadgets/line-editor" "gadgets/rectangles"
- "gadgets/gradients" "memory"
+ "gadgets/gradients" "gadgets/frames" "memory"
"redefine" "annotate" "sequences" "binary" "inspector"
"kernel"
} run-tests ;
: init-threads ( -- )
global [
<queue> \ run-queue set
- 10 <vector> \ sleep-queue set
- <namespace> \ timers set
+ { } clone \ sleep-queue set
+ {{ }} clone \ timers set
] bind ;
%
"===> Leaving: " swap word-name append ,
[ print .s ] %
- ] make-list ;
+ ] [ ] make ;
: watch ( word -- )
#! Cause a message to be printed out when the word is
inline
: (profile) ( word def -- def )
- [ , literalize , \ with-profile , ] make-list ;
+ [ , literalize , \ with-profile , ] [ ] make ;
: profile ( word -- )
#! When the word is called, time it, and add the time to
inspector-help
terpri
"inspector " listener-prompt set
- 10 <vector> inspector-stack set
+ { } clone inspector-stack set
(inspect)
listener
] with-scope ;
SYMBOL: meta-executing
: init-interpreter ( -- )
- 10 <vector> meta-r set
- 10 <vector> meta-d set
+ { } clone meta-r set
+ { } clone meta-d set
namestack meta-n set
catchstack meta-c set
f meta-cf set
[
[ swap call ] 2keep rot [ , ] [ drop ] ifte
] each-object drop
- ] make-list ;
+ ] [ ] make ;
G: each-slot ( obj quot -- )
[ over ] standard-combination ; inline
}} hash ;
: ttf-path ( name -- string )
- [ resource-path % "/fonts/" % % ".ttf" % ] make-string ;
+ [ resource-path % "/fonts/" % % ".ttf" % ] "" make ;
: open-font ( [ font style ptsize ] -- alien )
3unseq >r ttf-name ttf-path r> TTF_OpenFont ;
! Copyright (C) 2005 Slava Pestov.
! See http://factor.sf.net/license.txt for BSD license.
IN: gadgets
-USING: gadgets generic kernel lists math namespaces sdl
-sequences vectors words ;
+USING: generic kernel lists math namespaces sequences vectors ;
-SYMBOL: x
-SYMBOL: y
+! A frame arranges gadgets in a 3x3 grid, where the center
+! gadgets gets left-over space.
+TUPLE: frame grid ;
-! A frame arranges left/right/top/bottom gadgets around a
-! center gadget, which gets any leftover space.
-TUPLE: frame left right top bottom center ;
-
-: add-center ( gadget frame -- )
- dup frame-center unparent 2dup set-frame-center add-gadget ;
-: add-left ( gadget frame -- )
- dup frame-left unparent 2dup set-frame-left add-gadget ;
-: add-right ( gadget frame -- )
- dup frame-right unparent 2dup set-frame-right add-gadget ;
-: add-top ( gadget frame -- )
- dup frame-top unparent 2dup set-frame-top add-gadget ;
-: add-bottom ( gadget frame -- )
- dup frame-bottom unparent 2dup set-frame-bottom add-gadget ;
+: <frame-grid> { { f f f } { f f f } { f f f } } [ clone ] map ;
C: frame ( -- frame )
- [ <gadget> swap set-delegate ] keep
- [ <gadget> swap set-frame-center ] keep
- [ <gadget> swap set-frame-left ] keep
- [ <gadget> swap set-frame-right ] keep
- [ <gadget> swap set-frame-top ] keep
- [ <gadget> swap set-frame-bottom ] keep ;
-
-: frame-major ( frame -- list )
- [
- dup frame-top , dup frame-center , frame-bottom ,
- ] make-list ;
-
-: frame-minor ( frame -- list )
- [
- dup frame-left , dup frame-center , frame-right ,
- ] make-list ;
-
-: pref-size pref-dim 3unseq drop ;
-
-: max-h pref-size nip height [ max ] change ;
-: max-w pref-size drop width [ max ] change ;
-
-: add-h pref-size nip height [ + ] change ;
-: add-w pref-size drop width [ + ] change ;
-
-: with-pref-size ( quot -- )
- [
- 0 width set 0 height set call width get height get
- ] with-scope ; inline
-
-M: frame pref-dim ( glue -- dim )
- [
- dup frame-major [ max-w ] each
- dup frame-minor [ max-h ] each
- dup frame-left add-w
- dup frame-right add-w
- dup frame-top add-h
- frame-bottom add-h
- ] with-pref-size 0 3vector ;
+ <gadget> over set-delegate <frame-grid> over set-frame-grid ;
-SYMBOL: frame-right-run
-SYMBOL: frame-bottom-run
+: frame-child ( frame i j -- gadget ) rot frame-grid nth nth ;
-: var-frame-x [ execute pref-size drop ] keep set ; inline
-: var-frame-y [ execute pref-size nip ] keep set ; inline
-: var-frame-left \ frame-left var-frame-x ;
-: var-frame-top \ frame-top var-frame-y ;
-: var-frame-right
- dup \ frame-right var-frame-x
- swap rect-dim first \ frame-right [ - ] change
- \ frame-right get \ frame-left get - frame-right-run set ;
-: var-frame-bottom
- dup \ frame-bottom var-frame-y
- swap rect-dim second \ frame-bottom [ - ] change
- \ frame-bottom get \ frame-top get - frame-bottom-run set ;
+: set-frame-child ( gadget frame i j -- )
+ 3dup frame-child unparent
+ >r >r 2dup add-gadget r> r>
+ rot frame-grid nth set-nth ;
-: setup-frame ( frame -- )
- dup var-frame-left
- dup var-frame-top
- dup var-frame-right
- var-frame-bottom ;
+: add-center ( gadget frame -- ) 1 1 set-frame-child ;
+: add-left ( gadget frame -- ) 0 1 set-frame-child ;
+: add-right ( gadget frame -- ) 2 1 set-frame-child ;
+: add-top ( gadget frame -- ) 1 0 set-frame-child ;
+: add-bottom ( gadget frame -- ) 1 2 set-frame-child ;
-: move-gadget ( x y gadget -- )
- >r 0 3vector r> set-rect-loc ;
+: reduce-grid ( grid -- seq )
+ [ { 0 0 0 } [ vmax ] reduce ] map ;
-: reshape-gadget ( x y w h gadget -- )
- [ >r 0 3vector r> set-gadget-dim ] keep move-gadget ;
+: frame-pref-dim ( grid -- dim )
+ reduce-grid { 0 0 0 } [ v+ ] reduce ;
-: pos-frame-center
- >r \ frame-left get \ frame-top get
- \ frame-right-run get \ frame-bottom-run get r>
- reshape-gadget ;
+: pref-dim-grid ( grid -- grid )
+ [ [ [ pref-dim ] [ { 0 0 0 } ] ifte* ] map ] map ;
-: pos-frame-left
- [
- >r 0 \ frame-top get r> pref-size drop \ frame-bottom-run get
- ] keep reshape-gadget ;
+M: frame pref-dim ( frame -- dim )
+ frame-grid pref-dim-grid
+ dup frame-pref-dim first
+ swap flip frame-pref-dim second
+ 0 3vector ;
-: pos-frame-right
- [
- >r \ frame-right get \ frame-top get r> pref-size drop
- \ frame-bottom-run get
- ] keep reshape-gadget ;
+: frame-layout ( horiz vert -- grid )
+ [ swap [ swap 0 3vector ] map-with ] map-with ;
-: pos-frame-top
- [
- >r \ frame-left get 0 \ frame-right get r> pref-size nip
- ] keep reshape-gadget ;
+: do-grid ( dim-grid gadget-grid quot -- )
+ -rot [ [ pick call ] 2each ] 2each drop ;
-: pos-frame-bottom
- [
- >r \ frame-left get \ frame-bottom get \ frame-right get
- r> pref-size nip
- ] keep reshape-gadget ;
+: position-grid ( gadgets horiz vert -- )
+ >r 0 [ + ] accumulate r> 0 [ + ] accumulate
+ frame-layout swap [ set-rect-loc ] do-grid ;
-: layout-frame ( frame -- )
- dup frame-center pos-frame-center
- dup frame-left pos-frame-left
- dup frame-right pos-frame-right
- dup frame-top pos-frame-top
- frame-bottom pos-frame-bottom ;
+: resize-grid ( gadgets horiz vert -- )
+ frame-layout swap [ set-gadget-dim ] do-grid ;
-M: frame layout* ( frame -- )
- [ 0 x set 0 y set dup setup-frame layout-frame ] with-scope ;
+M: frame layout* ( frame -- dim )
+ frame-grid dup pref-dim-grid
+ dup reduce-grid [ first ] map
+ swap flip reduce-grid [ second ] map
+ 3dup position-grid resize-grid ;
paint gestures visible? relayout? root?
parent children ;
+M: gadget = eq? ;
+
: gadget-child gadget-children first ;
C: gadget ( -- gadget )
sequences vectors ;
: remove-gadget ( gadget parent -- )
- [ 2dup gadget-children remq swap set-gadget-children ] keep
+ [ 2dup gadget-children remove swap set-gadget-children ] keep
relayout f swap set-gadget-parent ;
: unparent ( gadget -- )
: <line-editor> ( -- editor )
[
line-clear
- 100 <vector> history set
+ { } clone history set
0 history-index set
] make-hash ;
#! Call this in the line editor scope.
reset-history
2dup caret-insert
- line-text get cut
+ line-text get [ head ] 2keep tail
swapd append3 line-text set ;
: insert-char ( ch -- )
SYMBOL: commands
-global [ 100 <vector> commands set ] bind
+{ } clone commands global set-hash
: define-command ( class name quot -- )
3vector commands get push ;
commands get [ first call ] subset-with ;
: command-quot ( presented quot -- quot )
- [ swap literalize , % ] make-list
+ [ swap literalize , % ] [ ] make
[ pane get pane-call drop ] cons ;
: command-menu ( presented -- menu )
\ drop ,
literalize ,
[ command-menu show-menu ] %
- ] make-list
+ ] [ ] make
button-gestures
] [
2drop
dup splitter-part ,
divider-size ,
dup rect-dim divider-size v- swap splitter-part v- ,
- ] make-vector ;
+ ] { } make ;
M: splitter layout* ( splitter -- )
dup splitter-layout packed-layout ;
listener
] with-stream
] in-thread
+ ] bind
- pane get request-focus
- ] bind ;
+ pane get request-focus ;
SYMBOL: first-time
"Error on fd " %
dup port-handle number>string %
": " % swap %
- ] make-string swap set-port-error ;
+ ] "" make swap set-port-error ;
: defer-error ( port -- ? )
#! Return t if it is an unrecoverable error.
#! Should only be called on startup. Calling this at any
#! other time can have unintended consequences.
global [
- <namespace> read-tasks set
+ {{ }} clone read-tasks set
FD_SETSIZE <bit-array> read-fdset set
- <namespace> write-tasks set
+ {{ }} clone write-tasks set
FD_SETSIZE <bit-array> write-fdset set
0 1 t <fd-stream> stdio set
] bind ;
dup -16 shift HEX: ff bitand number>string % CHAR: . ,
dup -8 shift HEX: ff bitand number>string % CHAR: . ,
HEX: ff bitand number>string %
- ] make-string ;
+ ] "" make ;
: do-accept ( port sockaddr fd -- )
[
SYMBOL: vocabularies
-: word ( -- word ) "last-word" global hash ;
-: set-word ( word -- ) "last-word" global set-hash ;
+: word ( -- word ) \ word global hash ;
+: set-word ( word -- ) \ word global set-hash ;
: vocabs ( -- list )
#! Push a list of vocabularies.
: word-subset ( pred -- list | pred: word -- ? )
#! A list of words matching the predicate.
- all-words swap subset word-sort ; inline
+ all-words swap subset ; inline
: word-subset-with ( obj pred -- list | pred: obj word -- ? )
- all-words swap subset-with word-sort ; inline
+ all-words swap subset-with ; inline
: recrossref ( -- )
#! Update word cross referencing information.
- global [ <namespace> crossref set ] bind
+ {{ }} clone crossref global set-hash
[ add-crossref ] each-word ;
: lookup ( name vocab -- word ) vocab ?hash ;
: forget ( word -- )
#! Remove a word definition.
dup uncrossref
- dup word-vocabulary vocab [ word-name off ] bind ;
+ dup word-name swap word-vocabulary vocab remove-hash ;
: interned? ( word -- ? )
#! Test if the word is a member of its vocabulary.
- dup word-name over word-vocabulary vocab ?hash eq? ;
+ dup word-name over word-vocabulary lookup eq? ;
: init-search-path ( -- )
"scratchpad" "in" set
"overlapped-ext" c-size malloc <alien> ;
C: io-queue ( -- queue )
- 0 <vector> over set-io-queue-callbacks ;
+ { } clone over set-io-queue-callbacks ;
C: io-callback ( -- callback )
io-queue get io-queue-callbacks [ push ] 2keep
projects / factor.git / commitdiff