Merge branch 'master' of git://factorcode.org/git/factor
commit
b6f8fd587a
|
@ -144,6 +144,11 @@ PRIVATE>
|
||||||
: dlist-delete ( obj dlist -- obj/f )
|
: dlist-delete ( obj dlist -- obj/f )
|
||||||
>r [ eq? ] curry r> delete-node-if ;
|
>r [ eq? ] curry r> delete-node-if ;
|
||||||
|
|
||||||
|
: dlist-delete-all ( dlist -- )
|
||||||
|
f over set-dlist-front
|
||||||
|
f over set-dlist-back
|
||||||
|
0 swap set-dlist-length ;
|
||||||
|
|
||||||
: dlist-each ( dlist quot -- )
|
: dlist-each ( dlist quot -- )
|
||||||
[ dlist-node-obj ] swap compose dlist-each-node ; inline
|
[ dlist-node-obj ] swap compose dlist-each-node ; inline
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,8 @@ IN: temporary
|
||||||
USING: tools.test io.files io threads kernel continuations ;
|
USING: tools.test io.files io threads kernel continuations ;
|
||||||
|
|
||||||
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
|
[ "passwd" ] [ "/etc/passwd" file-name ] unit-test
|
||||||
[ "awk/" ] [ "/usr/libexec/awk/" file-name ] unit-test
|
[ "awk" ] [ "/usr/libexec/awk/" file-name ] unit-test
|
||||||
|
[ "awk" ] [ "/usr/libexec/awk///" file-name ] unit-test
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
"test-foo.txt" resource-path <file-writer> [
|
"test-foo.txt" resource-path <file-writer> [
|
||||||
|
|
|
@ -64,7 +64,7 @@ M: object root-directory? ( path -- ? ) path-separator? ;
|
||||||
normalize-directory dup (directory) fixup-directory ;
|
normalize-directory dup (directory) fixup-directory ;
|
||||||
|
|
||||||
: last-path-separator ( path -- n ? )
|
: last-path-separator ( path -- n ? )
|
||||||
[ length 2 [-] ] keep [ path-separator? ] find-last* ;
|
[ length 1- ] keep [ path-separator? ] find-last* ;
|
||||||
|
|
||||||
TUPLE: no-parent-directory path ;
|
TUPLE: no-parent-directory path ;
|
||||||
|
|
||||||
|
@ -83,7 +83,11 @@ TUPLE: no-parent-directory path ;
|
||||||
} cond ;
|
} cond ;
|
||||||
|
|
||||||
: file-name ( path -- string )
|
: file-name ( path -- string )
|
||||||
dup last-path-separator [ 1+ tail ] [ drop ] if ;
|
right-trim-separators {
|
||||||
|
{ [ dup empty? ] [ drop "/" ] }
|
||||||
|
{ [ dup last-path-separator ] [ 1+ tail ] }
|
||||||
|
{ [ t ] [ drop ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: resource-path ( path -- newpath )
|
: resource-path ( path -- newpath )
|
||||||
\ resource-path get [ image parent-directory ] unless*
|
\ resource-path get [ image parent-directory ] unless*
|
||||||
|
|
|
@ -349,6 +349,14 @@ IN: temporary
|
||||||
"IN: temporary : foo ; TUPLE: foo ;"
|
"IN: temporary : foo ; TUPLE: foo ;"
|
||||||
<string-reader> "redefining-a-class-4" parse-stream drop
|
<string-reader> "redefining-a-class-4" parse-stream drop
|
||||||
] [ [ redefine-error? ] is? ] must-fail-with
|
] [ [ redefine-error? ] is? ] must-fail-with
|
||||||
|
|
||||||
|
[ ] [
|
||||||
|
"IN: temporary : foo ( x y -- z ) 1 2 ; : bar ( a -- b ) ;" eval
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[
|
||||||
|
"IN: temporary : foo ( x y -- z) 1 2 ; : bar ( a -- b ) ;" eval
|
||||||
|
] must-fail
|
||||||
] with-file-vocabs
|
] with-file-vocabs
|
||||||
|
|
||||||
[
|
[
|
||||||
|
|
|
@ -307,10 +307,14 @@ SYMBOL: lexer-factory
|
||||||
|
|
||||||
! Parsing word utilities
|
! Parsing word utilities
|
||||||
: parse-effect ( -- effect )
|
: parse-effect ( -- effect )
|
||||||
")" parse-tokens { "--" } split1 dup [
|
")" parse-tokens "(" over member? [
|
||||||
<effect>
|
"Stack effect declaration must not contain (" throw
|
||||||
] [
|
] [
|
||||||
"Stack effect declaration must contain --" throw
|
{ "--" } split1 dup [
|
||||||
|
<effect>
|
||||||
|
] [
|
||||||
|
"Stack effect declaration must contain --" throw
|
||||||
|
] if
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
TUPLE: bad-number ;
|
TUPLE: bad-number ;
|
||||||
|
|
|
@ -149,12 +149,14 @@ SYMBOL: load-help?
|
||||||
dup modified-sources swap modified-docs ;
|
dup modified-sources swap modified-docs ;
|
||||||
|
|
||||||
: load-error. ( vocab error -- )
|
: load-error. ( vocab error -- )
|
||||||
"While loading " rot dup >vocab-link write-object ":" print
|
"==== " write >r
|
||||||
print-error ;
|
dup vocab-name swap f >vocab-link write-object ":" print nl
|
||||||
|
r> print-error ;
|
||||||
|
|
||||||
TUPLE: require-all-error vocabs ;
|
TUPLE: require-all-error vocabs ;
|
||||||
|
|
||||||
: require-all-error ( vocabs -- )
|
: require-all-error ( vocabs -- )
|
||||||
|
[ vocab-name ] map
|
||||||
\ require-all-error construct-boa throw ;
|
\ require-all-error construct-boa throw ;
|
||||||
|
|
||||||
M: require-all-error summary
|
M: require-all-error summary
|
||||||
|
@ -167,7 +169,6 @@ M: require-all-error summary
|
||||||
[ [ require ] [ 2array , ] recover ] each
|
[ [ require ] [ 2array , ] recover ] each
|
||||||
] { } make
|
] { } make
|
||||||
dup empty? [ drop ] [
|
dup empty? [ drop ] [
|
||||||
"==== LOAD ERRORS:" print
|
|
||||||
dup [ nl load-error. ] assoc-each
|
dup [ nl load-error. ] assoc-each
|
||||||
keys require-all-error
|
keys require-all-error
|
||||||
] if
|
] if
|
||||||
|
|
|
@ -5,11 +5,11 @@ USING: asn1 asn1.ldap io io.streams.string tools.test ;
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "testing" ] [
|
[ "testing" ] [
|
||||||
"\u0004\u0007testing" <string-reader> [ asn-syntax read-ber ] with-stream
|
"\u000004\u000007testing" <string-reader> [ asn-syntax read-ber ] with-stream
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [
|
[ { 1 { 3 "Administrator" "ad_is_bogus" } } ] [
|
||||||
"0$\u0002\u0001\u0001`\u001f\u0002\u0001\u0003\u0004\rAdministrator\u0080\u000bad_is_bogus"
|
"0$\u000002\u000001\u000001`\u00001f\u000002\u000001\u000003\u000004\rAdministrator\u000080\u00000bad_is_bogus"
|
||||||
<string-reader> [ asn-syntax read-ber ] with-stream
|
<string-reader> [ asn-syntax read-ber ] with-stream
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
|
|
@ -6,6 +6,8 @@ namespaces tools.test continuations dlists strings math words
|
||||||
match quotations concurrency.private ;
|
match quotations concurrency.private ;
|
||||||
IN: temporary
|
IN: temporary
|
||||||
|
|
||||||
|
[ ] [ self process-mailbox mailbox-data dlist-delete-all ] unit-test
|
||||||
|
|
||||||
[ V{ 1 2 3 } ] [
|
[ V{ 1 2 3 } ] [
|
||||||
0 <vector>
|
0 <vector>
|
||||||
make-mailbox
|
make-mailbox
|
||||||
|
|
|
@ -73,7 +73,7 @@ PRIVATE>
|
||||||
|
|
||||||
: mailbox-get?* ( pred mailbox timeout -- obj )
|
: mailbox-get?* ( pred mailbox timeout -- obj )
|
||||||
2over >r >r (mailbox-block-unless-pred) r> r>
|
2over >r >r (mailbox-block-unless-pred) r> r>
|
||||||
mailbox-data delete-node ; inline
|
mailbox-data delete-node-if ; inline
|
||||||
|
|
||||||
: mailbox-get? ( pred mailbox -- obj )
|
: mailbox-get? ( pred mailbox -- obj )
|
||||||
f mailbox-get?* ;
|
f mailbox-get?* ;
|
||||||
|
|
|
@ -10,25 +10,25 @@ T{ wince-os } os set-global
|
||||||
"MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
|
"MEMORYSTATUS" heap-size over set-MEMORYSTATUS-dwLength
|
||||||
[ GlobalMemoryStatus ] keep ;
|
[ GlobalMemoryStatus ] keep ;
|
||||||
|
|
||||||
M: wince cpus ( -- n ) 1 ;
|
M: wince-os cpus ( -- n ) 1 ;
|
||||||
|
|
||||||
M: wince memory-load ( -- n )
|
M: wince-os memory-load ( -- n )
|
||||||
memory-status MEMORYSTATUS-dwMemoryLoad ;
|
memory-status MEMORYSTATUS-dwMemoryLoad ;
|
||||||
|
|
||||||
M: wince physical-mem ( -- n )
|
M: wince-os physical-mem ( -- n )
|
||||||
memory-status MEMORYSTATUS-dwTotalPhys ;
|
memory-status MEMORYSTATUS-dwTotalPhys ;
|
||||||
|
|
||||||
M: wince available-mem ( -- n )
|
M: wince-os available-mem ( -- n )
|
||||||
memory-status MEMORYSTATUS-dwAvailPhys ;
|
memory-status MEMORYSTATUS-dwAvailPhys ;
|
||||||
|
|
||||||
M: wince total-page-file ( -- n )
|
M: wince-os total-page-file ( -- n )
|
||||||
memory-status MEMORYSTATUS-dwTotalPageFile ;
|
memory-status MEMORYSTATUS-dwTotalPageFile ;
|
||||||
|
|
||||||
M: wince available-page-file ( -- n )
|
M: wince-os available-page-file ( -- n )
|
||||||
memory-status MEMORYSTATUS-dwAvailPageFile ;
|
memory-status MEMORYSTATUS-dwAvailPageFile ;
|
||||||
|
|
||||||
M: wince total-virtual-mem ( -- n )
|
M: wince-os total-virtual-mem ( -- n )
|
||||||
memory-status MEMORYSTATUS-dwTotalVirtual ;
|
memory-status MEMORYSTATUS-dwTotalVirtual ;
|
||||||
|
|
||||||
M: wince available-virtual-mem ( -- n )
|
M: wince-os available-virtual-mem ( -- n )
|
||||||
memory-status MEMORYSTATUS-dwAvailVirtual ;
|
memory-status MEMORYSTATUS-dwAvailVirtual ;
|
||||||
|
|
|
@ -32,17 +32,18 @@ M: template-lexer skip-word
|
||||||
DEFER: <% delimiter
|
DEFER: <% delimiter
|
||||||
|
|
||||||
: check-<% ( lexer -- col )
|
: check-<% ( lexer -- col )
|
||||||
"<%" over line-text rot lexer-column start* ;
|
"<%" over lexer-line-text rot lexer-column start* ;
|
||||||
|
|
||||||
: found-<% ( accum lexer col -- accum )
|
: found-<% ( accum lexer col -- accum )
|
||||||
[
|
[
|
||||||
over line-text >r >r lexer-column r> r> subseq parsed
|
over lexer-line-text
|
||||||
|
>r >r lexer-column r> r> subseq parsed
|
||||||
\ write-html parsed
|
\ write-html parsed
|
||||||
] 2keep 2 + swap set-lexer-column ;
|
] 2keep 2 + swap set-lexer-column ;
|
||||||
|
|
||||||
: still-looking ( accum lexer -- accum )
|
: still-looking ( accum lexer -- accum )
|
||||||
[
|
[
|
||||||
dup line-text swap lexer-column tail
|
dup lexer-line-text swap lexer-column tail
|
||||||
parsed \ print-html parsed
|
parsed \ print-html parsed
|
||||||
] keep next-line ;
|
] keep next-line ;
|
||||||
|
|
||||||
|
|
|
@ -40,9 +40,9 @@ IN: ldap.libldap
|
||||||
: LDAP_RES_UNSOLICITED 0 ; inline
|
: LDAP_RES_UNSOLICITED 0 ; inline
|
||||||
|
|
||||||
! how many messages to retrieve results for
|
! how many messages to retrieve results for
|
||||||
: LDAP_MSG_ONE HEX: 00 ; inline
|
: LDAP_MSG_ONE HEX: 00 ; inline
|
||||||
: LDAP_MSG_ALL HEX: 01 ; inline
|
: LDAP_MSG_ALL HEX: 01 ; inline
|
||||||
: LDAP_MSG_RECEIVED HEX: 02 ; inline
|
: LDAP_MSG_RECEIVED HEX: 02 ; inline
|
||||||
|
|
||||||
! the possible result types returned
|
! the possible result types returned
|
||||||
: LDAP_RES_BIND HEX: 61 ; inline
|
: LDAP_RES_BIND HEX: 61 ; inline
|
||||||
|
@ -71,7 +71,7 @@ IN: ldap.libldap
|
||||||
{ HEX: 79 "LDAP_RES_EXTENDED_PARTIAL" }
|
{ HEX: 79 "LDAP_RES_EXTENDED_PARTIAL" }
|
||||||
} ;
|
} ;
|
||||||
|
|
||||||
: LDAP_OPT_PROTOCOL_VERSION HEX: 0011 ; inline
|
: LDAP_OPT_PROTOCOL_VERSION HEX: 0011 ; inline
|
||||||
|
|
||||||
C-STRUCT: ldap
|
C-STRUCT: ldap
|
||||||
{ "char" "ld_lberoptions" }
|
{ "char" "ld_lberoptions" }
|
||||||
|
|
|
@ -4,7 +4,7 @@ IN: math.constants
|
||||||
ARTICLE: "math-constants" "Constants"
|
ARTICLE: "math-constants" "Constants"
|
||||||
"Standard mathematical constants:"
|
"Standard mathematical constants:"
|
||||||
{ $subsection e }
|
{ $subsection e }
|
||||||
{ $subsection gamma }
|
{ $subsection euler }
|
||||||
{ $subsection phi }
|
{ $subsection phi }
|
||||||
{ $subsection pi }
|
{ $subsection pi }
|
||||||
"Various limits:"
|
"Various limits:"
|
||||||
|
@ -17,7 +17,7 @@ ABOUT: "math-constants"
|
||||||
HELP: e
|
HELP: e
|
||||||
{ $values { "e" "base of natural logarithm" } } ;
|
{ $values { "e" "base of natural logarithm" } } ;
|
||||||
|
|
||||||
HELP: gamma
|
HELP: euler
|
||||||
{ $values { "gamma" "Euler-Mascheroni constant" } }
|
{ $values { "gamma" "Euler-Mascheroni constant" } }
|
||||||
{ $description "The Euler-Mascheroni constant, also called \"Euler's constant\" or \"the Euler constant\"." } ;
|
{ $description "The Euler-Mascheroni constant, also called \"Euler's constant\" or \"the Euler constant\"." } ;
|
||||||
|
|
||||||
|
|
|
@ -3,7 +3,7 @@
|
||||||
IN: math.constants
|
IN: math.constants
|
||||||
|
|
||||||
: e ( -- e ) 2.7182818284590452354 ; inline
|
: e ( -- e ) 2.7182818284590452354 ; inline
|
||||||
: gamma ( -- gamma ) 0.57721566490153286060 ; inline
|
: euler ( -- gamma ) 0.57721566490153286060 ; inline
|
||||||
: phi ( -- phi ) 1.61803398874989484820 ; inline
|
: phi ( -- phi ) 1.61803398874989484820 ; inline
|
||||||
: pi ( -- pi ) 3.14159265358979323846 ; inline
|
: pi ( -- pi ) 3.14159265358979323846 ; inline
|
||||||
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
|
: epsilon ( -- epsilon ) 2.2204460492503131e-16 ; inline
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
! Copyright (C) 2006, 2007 Slava Pestov.
|
! Copyright (C) 2006, 2008 Slava Pestov.
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel math math.vectors math.matrices namespaces
|
USING: kernel math math.vectors math.matrices namespaces
|
||||||
sequences parser ;
|
sequences ;
|
||||||
IN: math.matrices.elimination
|
IN: math.matrices.elimination
|
||||||
|
|
||||||
SYMBOL: matrix
|
SYMBOL: matrix
|
||||||
|
@ -20,6 +20,9 @@ SYMBOL: matrix
|
||||||
|
|
||||||
: cols ( -- n ) 0 nth-row length ;
|
: cols ( -- n ) 0 nth-row length ;
|
||||||
|
|
||||||
|
: skip ( i seq quot -- n )
|
||||||
|
over >r find* drop r> length or ; inline
|
||||||
|
|
||||||
: first-col ( row# -- n )
|
: first-col ( row# -- n )
|
||||||
#! First non-zero column
|
#! First non-zero column
|
||||||
0 swap nth-row [ zero? not ] skip ;
|
0 swap nth-row [ zero? not ] skip ;
|
||||||
|
|
|
@ -108,10 +108,12 @@ M: nehe5-gadget draw-gadget* ( gadget -- )
|
||||||
|
|
||||||
: nehe5-update-thread ( gadget -- )
|
: nehe5-update-thread ( gadget -- )
|
||||||
dup nehe5-gadget-quit? [
|
dup nehe5-gadget-quit? [
|
||||||
|
drop
|
||||||
|
] [
|
||||||
redraw-interval sleep
|
redraw-interval sleep
|
||||||
dup relayout-1
|
dup relayout-1
|
||||||
nehe5-update-thread
|
nehe5-update-thread
|
||||||
] unless ;
|
] if ;
|
||||||
|
|
||||||
M: nehe5-gadget graft* ( gadget -- )
|
M: nehe5-gadget graft* ( gadget -- )
|
||||||
[ f swap set-nehe5-gadget-quit? ] keep
|
[ f swap set-nehe5-gadget-quit? ] keep
|
||||||
|
|
|
@ -49,7 +49,7 @@ C-STRUCT: bio
|
||||||
: BIO_CLOSE HEX: 01 ; inline
|
: BIO_CLOSE HEX: 01 ; inline
|
||||||
|
|
||||||
: RSA_3 HEX: 3 ; inline
|
: RSA_3 HEX: 3 ; inline
|
||||||
: RSA_F4 HEX: 10001 ; inline
|
: RSA_F4 HEX: 10001 ; inline
|
||||||
|
|
||||||
: BIO_C_SET_SSL 109 ; inline
|
: BIO_C_SET_SSL 109 ; inline
|
||||||
: BIO_C_GET_SSL 110 ; inline
|
: BIO_C_GET_SSL 110 ; inline
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
USING: alien alien.c-types assocs bit-arrays hashtables io io.files
|
USING: alien alien.c-types assocs bit-arrays hashtables io io.files
|
||||||
io.sockets kernel mirrors openssl.libcrypto openssl.libssl
|
io.sockets kernel mirrors openssl.libcrypto openssl.libssl
|
||||||
namespaces math math.parser openssl prettyprint sequences tools.test unix ;
|
namespaces math math.parser openssl prettyprint sequences tools.test ;
|
||||||
|
|
||||||
! =========================================================
|
! =========================================================
|
||||||
! Some crypto functions (still to be turned into words)
|
! Some crypto functions (still to be turned into words)
|
||||||
|
|
|
@ -4,7 +4,7 @@
|
||||||
! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
|
! Tested with OpenSSL 0.9.8a_0 on Mac OS X 10.4.9 PowerPC
|
||||||
|
|
||||||
USING: alien alien.c-types assocs kernel libc namespaces
|
USING: alien alien.c-types assocs kernel libc namespaces
|
||||||
openssl.libcrypto openssl.libssl sequences unix ;
|
openssl.libcrypto openssl.libssl sequences ;
|
||||||
|
|
||||||
IN: openssl
|
IN: openssl
|
||||||
|
|
||||||
|
|
|
@ -6,7 +6,7 @@ USING: kernel continuations arrays sequences quotations ;
|
||||||
: breset ( quot -- )
|
: breset ( quot -- )
|
||||||
[ 1array swap keep first continue-with ] callcc1 nip ;
|
[ 1array swap keep first continue-with ] callcc1 nip ;
|
||||||
|
|
||||||
: (bshift) ( v r k -- )
|
: (bshift) ( v r k -- obj )
|
||||||
>r dup first -rot r>
|
>r dup first -rot r>
|
||||||
[
|
[
|
||||||
rot set-first
|
rot set-first
|
||||||
|
@ -19,4 +19,4 @@ USING: kernel continuations arrays sequences quotations ;
|
||||||
over >r
|
over >r
|
||||||
[ (bshift) ] 2curry swap call
|
[ (bshift) ] 2curry swap call
|
||||||
r> first continue-with
|
r> first continue-with
|
||||||
] callcc1 2nip ;
|
] callcc1 2nip ; inline
|
||||||
|
|
|
@ -17,9 +17,9 @@ TUPLE: random-tester-error ;
|
||||||
: test-compiler ! ( data... quot -- ... )
|
: test-compiler ! ( data... quot -- ... )
|
||||||
errored off
|
errored off
|
||||||
dup quot set
|
dup quot set
|
||||||
datastack clone >vector dup pop* before set
|
datastack 1 head* before set
|
||||||
[ call ] catch drop
|
[ call ] [ drop ] recover
|
||||||
datastack clone after set
|
datastack after set
|
||||||
clear
|
clear
|
||||||
before get [ ] each
|
before get [ ] each
|
||||||
quot get [ compile-call ] [ errored on ] recover ;
|
quot get [ compile-call ] [ errored on ] recover ;
|
||||||
|
|
|
@ -77,7 +77,7 @@ PRIVATE>
|
||||||
|
|
||||||
: 'hex' ( -- parser )
|
: 'hex' ( -- parser )
|
||||||
"x" token 'hex-digit' 2 exactly-n &>
|
"x" token 'hex-digit' 2 exactly-n &>
|
||||||
"u" token 'hex-digit' 4 exactly-n &> <|>
|
"u" token 'hex-digit' 6 exactly-n &> <|>
|
||||||
[ hex> ] <@ ;
|
[ hex> ] <@ ;
|
||||||
|
|
||||||
: satisfy-tokens ( assoc -- parser )
|
: satisfy-tokens ( assoc -- parser )
|
||||||
|
|
|
@ -10,8 +10,6 @@ TUPLE: serialize-test a b ;
|
||||||
|
|
||||||
C: <serialize-test> serialize-test
|
C: <serialize-test> serialize-test
|
||||||
|
|
||||||
: CURRY< \ > parse-until first2 curry parsed ; parsing
|
|
||||||
|
|
||||||
: objects
|
: objects
|
||||||
{
|
{
|
||||||
f
|
f
|
||||||
|
@ -33,7 +31,7 @@ C: <serialize-test> serialize-test
|
||||||
B{ 50 13 55 64 1 }
|
B{ 50 13 55 64 1 }
|
||||||
?{ t f t f f t f }
|
?{ t f t f f t f }
|
||||||
F{ 1.0 3.0 4.0 1.0 2.35 0.33 }
|
F{ 1.0 3.0 4.0 1.0 2.35 0.33 }
|
||||||
CURRY< 1 [ 2 ] >
|
<< 1 [ 2 ] curry parsed >>
|
||||||
{ { "a" "bc" } { "de" "fg" } }
|
{ { "a" "bc" } { "de" "fg" } }
|
||||||
H{ { "a" "bc" } { "de" "fg" } }
|
H{ { "a" "bc" } { "de" "fg" } }
|
||||||
} ;
|
} ;
|
||||||
|
|
|
@ -1,4 +1,4 @@
|
||||||
USING: tools.test state-parser kernel io strings ;
|
USING: tools.test state-parser kernel io strings ascii ;
|
||||||
|
|
||||||
[ "hello" ] [ "hello" [ rest ] string-parse ] unit-test
|
[ "hello" ] [ "hello" [ rest ] string-parse ] unit-test
|
||||||
[ 2 4 ] [ "12\n123" [ rest drop get-line get-column ] string-parse ] unit-test
|
[ 2 4 ] [ "12\n123" [ rest drop get-line get-column ] string-parse ] unit-test
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
USING: tools.test tuple-syntax ;
|
USING: tools.test tuple-syntax ;
|
||||||
|
IN: temporary
|
||||||
|
|
||||||
TUPLE: foo bar baz ;
|
TUPLE: foo bar baz ;
|
||||||
|
|
||||||
|
|
|
@ -1,4 +1,5 @@
|
||||||
USING: kernel sequences slots parser words classes ;
|
USING: kernel sequences slots parser words classes
|
||||||
|
slots.private ;
|
||||||
IN: tuple-syntax
|
IN: tuple-syntax
|
||||||
|
|
||||||
! TUPLE: foo bar baz ;
|
! TUPLE: foo bar baz ;
|
||||||
|
@ -7,15 +8,15 @@ IN: tuple-syntax
|
||||||
: parse-object ( -- object )
|
: parse-object ( -- object )
|
||||||
scan-word dup parsing? [ V{ } clone swap execute first ] when ;
|
scan-word dup parsing? [ V{ } clone swap execute first ] when ;
|
||||||
|
|
||||||
: parse-slot-writer ( tuple -- slot-setter )
|
: parse-slot-writer ( tuple -- slot# )
|
||||||
scan dup "}" = [ 2drop f ] [
|
scan dup "}" = [ 2drop f ] [
|
||||||
1 head* swap class "slots" word-prop
|
1 head* swap class "slots" word-prop
|
||||||
[ slot-spec-name = ] with find nip slot-spec-writer
|
[ slot-spec-name = ] with find nip slot-spec-offset
|
||||||
] if ;
|
] if ;
|
||||||
|
|
||||||
: parse-slots ( accum tuple -- accum tuple )
|
: parse-slots ( accum tuple -- accum tuple )
|
||||||
dup parse-slot-writer
|
dup parse-slot-writer
|
||||||
[ parse-object pick rot execute parse-slots ] when* ;
|
[ parse-object pick rot set-slot parse-slots ] when* ;
|
||||||
|
|
||||||
: TUPLE{
|
: TUPLE{
|
||||||
scan-word construct-empty parse-slots parsed ; parsing
|
scan-word construct-empty parse-slots parsed ; parsing
|
||||||
|
|
|
@ -249,11 +249,11 @@ M: editor gadget-text* editor-string % ;
|
||||||
: extend-selection ( editor -- )
|
: extend-selection ( editor -- )
|
||||||
dup request-focus dup editor-caret click-loc ;
|
dup request-focus dup editor-caret click-loc ;
|
||||||
|
|
||||||
: mouse-elt ( -- elelement )
|
: mouse-elt ( -- element )
|
||||||
hand-click# get {
|
hand-click# get {
|
||||||
|
{ 1 T{ one-char-elt } }
|
||||||
{ 2 T{ one-word-elt } }
|
{ 2 T{ one-word-elt } }
|
||||||
{ 3 T{ one-line-elt } }
|
} at T{ one-line-elt } or ;
|
||||||
} at T{ one-char-elt } or ;
|
|
||||||
|
|
||||||
: drag-direction? ( loc editor -- ? )
|
: drag-direction? ( loc editor -- ? )
|
||||||
editor-mark* <=> 0 < ;
|
editor-mark* <=> 0 < ;
|
||||||
|
|
|
@ -1,6 +1,6 @@
|
||||||
IN: temporary
|
IN: temporary
|
||||||
USING: xmode.utilities tools.test xml xml.data
|
USING: xmode.utilities tools.test xml xml.data kernel strings
|
||||||
kernel strings vectors sequences io.files prettyprint assocs ;
|
vectors sequences io.files prettyprint assocs unicode.case ;
|
||||||
|
|
||||||
[ "hi" 3 ] [
|
[ "hi" 3 ] [
|
||||||
{ 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find
|
{ 1 2 3 4 5 6 7 8 } [ H{ { 3 "hi" } } at ] map-find
|
||||||
|
|
Loading…
Reference in New Issue