Merge branch 'master' of git://factorcode.org/git/factor

db4
Aaron Schaefer 2009-04-19 13:01:40 -04:00
commit 5006f11342
227 changed files with 2692 additions and 1078 deletions

2
.gitignore vendored
View File

@ -25,3 +25,5 @@ build-support/wordsize
.#*
*.swo
checksums.txt
*.so
a.out

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types arrays assocs effects grouping kernel
parser sequences splitting words fry locals ;
parser sequences splitting words fry locals lexer namespaces ;
IN: alien.parser
: parse-arglist ( parameters return -- types effect )
@ -12,8 +12,15 @@ IN: alien.parser
: function-quot ( return library function types -- quot )
'[ _ _ _ _ alien-invoke ] ;
:: define-function ( return library function parameters -- )
:: make-function ( return library function parameters -- word quot effect )
function create-in dup reset-generic
return library function
parameters return parse-arglist [ function-quot ] dip
define-declared ;
parameters return parse-arglist [ function-quot ] dip ;
: (FUNCTION:) ( -- word quot effect )
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter
make-function ;
: define-function ( return library function parameters -- )
make-function define-declared ;

View File

@ -16,9 +16,7 @@ SYNTAX: BAD-ALIEN <bad-alien> parsed ;
SYNTAX: LIBRARY: scan "c-library" set ;
SYNTAX: FUNCTION:
scan "c-library" get scan ";" parse-tokens
[ "()" subseq? not ] filter
define-function ;
(FUNCTION:) define-declared ;
SYNTAX: TYPEDEF:
scan scan typedef ;

View File

@ -8,7 +8,7 @@ namespaces eval kernel vocabs.loader io ;
(command-line) parse-command-line
load-vocab-roots
run-user-init
"e" get [ eval ] when*
"e" get [ eval( -- ) ] when*
ignore-cli-args? not script get and
[ run-script ] [ "run" get run ] if*
output-stream get [ stream-flush ] when*

View File

@ -2,33 +2,4 @@ IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io
quotations words.symbol ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"After loading a vocabulary, you might see messages like:"
{ $code
":errors - print 2 compiler errors"
":warnings - print 50 compiler warnings"
}
"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "."
$nl
"Words to view warnings and errors:"
{ $subsection :warnings }
{ $subsection :errors }
{ $subsection :linkage }
"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ;
HELP: compiler-error
{ $values { "error" "an error" } { "word" word } }
{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ;
HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
HELP: :warnings
{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
HELP: :linkage
{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
{ :errors :warnings } related-words
ABOUT: "compiler-errors"

View File

@ -1,7 +1,6 @@
! Copyright (C) 2007, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors source-files.errors kernel namespaces assocs
tools.errors ;
USING: accessors source-files.errors kernel namespaces assocs ;
IN: compiler.errors
TUPLE: compiler-error < source-file-error ;
@ -44,6 +43,7 @@ T{ error-type
{ icon "vocab:ui/tools/error-list/icons/linkage-error.tiff" }
{ quot [ +linkage-error+ errors-of-type values ] }
{ forget-quot [ compiler-errors get delete-at ] }
{ fatal? f }
} define-error-type
: <compiler-error> ( error word -- compiler-error )
@ -52,12 +52,3 @@ T{ error-type
: compiler-error ( error word -- )
compiler-errors get-global pick
[ [ [ <compiler-error> ] keep ] dip set-at ] [ delete-at drop ] if ;
: compiler-errors. ( type -- )
errors-of-type values errors. ;
: :errors ( -- ) +compiler-error+ compiler-errors. ;
: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
: :linkage ( -- ) +linkage-error+ compiler-errors. ;

View File

@ -12,7 +12,7 @@ IN: compiler.tests
IN: compiler.tests.folding
GENERIC: foldable-generic ( a -- b ) foldable
M: integer foldable-generic f <array> ;
"> (( -- )) eval
"> eval( -- )
] unit-test
[ ] [
@ -20,7 +20,7 @@ IN: compiler.tests
USING: math arrays ;
IN: compiler.tests.folding
: fold-test ( -- x ) 10 foldable-generic ;
"> (( -- )) eval
"> eval( -- )
] unit-test
[ t ] [

View File

@ -11,7 +11,7 @@ M: integer method-redefine-generic-1 3 + ;
[ 6 ] [ method-redefine-test-1 ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" (( -- )) eval ] unit-test
[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
@ -27,7 +27,7 @@ M: integer method-redefine-generic-2 3 + ;
[ 6 ] [ method-redefine-test-2 ] unit-test
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" (( -- )) eval ] unit-test
[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval( -- ) ] unit-test
[ 7 ] [ method-redefine-test-2 ] unit-test
@ -43,10 +43,10 @@ M: integer method-redefine-generic-2 3 + ;
[ t ] [ \ hey optimized>> ] unit-test
[ t ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" (( -- )) eval ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) 3 ;" eval( -- ) ] unit-test
[ f ] [ \ hey optimized>> ] unit-test
[ f ] [ \ there optimized>> ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" (( -- )) eval ] unit-test
[ ] [ "IN: compiler.tests : hey ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ there optimized>> ] unit-test
: good ( -- ) ;
@ -59,7 +59,7 @@ M: integer method-redefine-generic-2 3 + ;
[ f ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" (( -- )) eval ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) 3 ;" eval( -- ) ] unit-test
[ f ] [ \ good optimized>> ] unit-test
[ f ] [ \ bad optimized>> ] unit-test
@ -67,7 +67,7 @@ M: integer method-redefine-generic-2 3 + ;
[ t ] [ \ good compiled-usage assoc-empty? ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" (( -- )) eval ] unit-test
[ ] [ "IN: compiler.tests : good ( -- ) ;" eval( -- ) ] unit-test
[ t ] [ \ good optimized>> ] unit-test
[ t ] [ \ bad optimized>> ] unit-test

View File

@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin instance? [ 1 + ] when ;
"> (( -- )) eval
"> eval( -- )
] unit-test
[ ] [
@ -21,7 +21,7 @@ IN: compiler.tests
USE: math
IN: compiler.tests.redefine10
INSTANCE: float my-mixin
"> (( -- )) eval
"> eval( -- )
] unit-test
[ 2.0 ] [

View File

@ -17,7 +17,7 @@ IN: compiler.tests
M: my-mixin my-generic drop 0 ;
M: object my-generic drop 1 ;
: my-inline ( -- b ) { } my-generic ;
"> (( -- )) eval
"> eval( -- )
] unit-test
[ ] [

View File

@ -15,6 +15,6 @@ M: object g drop t ;
TUPLE: jeah ;
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" (( -- )) eval ] unit-test
[ ] [ "USE: kernel IN: compiler.tests.redefine12 M: jeah g drop f ;" eval( -- ) ] unit-test
[ f ] [ T{ jeah } h ] unit-test

View File

@ -5,7 +5,7 @@ arrays words assocs eval words.symbol ;
DEFER: redefine2-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" (( -- )) eval ] unit-test
[ ] [ "USE: sequences USE: kernel IN: compiler.tests TUPLE: redefine2-test ; M: redefine2-test nth 2drop 3 ; INSTANCE: redefine2-test sequence" eval( -- ) ] unit-test
[ t ] [ \ redefine2-test symbol? ] unit-test

View File

@ -18,7 +18,7 @@ M: empty-mixin sheeple drop "wake up" ;
[ t ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ f ] [ empty-mixin \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" (( -- )) eval ] unit-test
[ ] [ "IN: compiler.tests USE: arrays INSTANCE: array empty-mixin" eval( -- ) ] unit-test
[ "wake up" ] [ sheeple-test ] unit-test
[ f ] [ object \ sheeple method \ sheeple-test "compiled-uses" word-prop key? ] unit-test

View File

@ -7,6 +7,6 @@ USING: io.streams.string kernel tools.test eval ;
[ "" ] [ [ declaration-test ] with-string-writer ] unit-test
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" (( -- )) eval ] unit-test
[ ] [ "IN: compiler.tests USE: io : declaration-test-1 ( -- a ) \"X\" write f ;" eval( -- ) ] unit-test
[ "X" ] [ [ declaration-test ] with-string-writer ] unit-test

View File

@ -14,7 +14,7 @@ IN: compiler.tests
GENERIC: my-generic ( a -- b )
M: object my-generic [ <=> ] sort ;
: my-inline ( a -- b ) my-generic ;
"> (( -- )) eval
"> eval( -- )
] unit-test
[ ] [
@ -23,7 +23,7 @@ IN: compiler.tests
IN: compiler.tests.redefine5
TUPLE: my-tuple ;
M: my-tuple my-generic drop 0 ;
"> (( -- )) eval
"> eval( -- )
] unit-test
[ 0 ] [

View File

@ -14,7 +14,7 @@ IN: compiler.tests
MIXIN: my-mixin
M: my-mixin my-generic drop 0 ;
: my-inline ( a -- b ) { my-mixin } declare my-generic ;
"> (( -- )) eval
"> eval( -- )
] unit-test
[ ] [
@ -24,7 +24,7 @@ IN: compiler.tests
TUPLE: my-tuple ;
M: my-tuple my-generic drop 1 ;
INSTANCE: my-tuple my-mixin
"> (( -- )) eval
"> eval( -- )
] unit-test
[ 1 ] [

View File

@ -13,7 +13,7 @@ IN: compiler.tests
MIXIN: my-mixin
INSTANCE: fixnum my-mixin
: my-inline ( a -- b ) dup my-mixin? [ 1 + ] when ;
"> (( -- )) eval
"> eval( -- )
] unit-test
[ ] [
@ -21,7 +21,7 @@ IN: compiler.tests
USE: math
IN: compiler.tests.redefine7
INSTANCE: float my-mixin
"> (( -- )) eval
"> eval( -- )
] unit-test
[ 2.0 ] [

View File

@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> (( -- )) eval
"> eval( -- )
] unit-test
[ ] [
@ -24,7 +24,7 @@ IN: compiler.tests
USE: math
IN: compiler.tests.redefine8
INSTANCE: float my-mixin
"> (( -- )) eval
"> eval( -- )
] unit-test
[ 2.0 ] [

View File

@ -16,7 +16,7 @@ IN: compiler.tests
! We add the bogus quotation here to hinder inlining
! since otherwise we cannot trigger this bug.
M: my-mixin my-generic 1 + [ [ <=> ] sort ] drop ;
"> (( -- )) eval
"> eval( -- )
] unit-test
[ ] [
@ -25,7 +25,7 @@ IN: compiler.tests
IN: compiler.tests.redefine9
TUPLE: my-tuple ;
INSTANCE: my-tuple my-mixin
"> (( -- )) eval
"> eval( -- )
] unit-test
[

View File

@ -237,6 +237,6 @@ M: f single-combination-test-2 single-combination-test-4 ;
10 [
[ "compiler.tests.foo" forget-vocab ] with-compilation-unit
[ t ] [
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" (( -- obj )) eval
"USING: prettyprint words accessors ; IN: compiler.tests.foo : (recursive) ( -- ) (recursive) (recursive) ; inline recursive : recursive ( -- ) (recursive) ; \\ (recursive) optimized>>" eval( -- obj )
] unit-test
] times

View File

@ -302,7 +302,7 @@ cell-bits 32 = [
] unit-test
[ t ] [
[ 1000 [ 1+ ] map ] { 1+ fixnum+ } inlined?
[ 1000 iota [ 1+ ] map ] { 1+ fixnum+ } inlined?
] unit-test
: rec ( a -- b )

View File

@ -17,13 +17,13 @@ sequences accessors tools.test kernel math ;
[ 2 ] [ [ 3 [ drop ] [ 2drop 3 ] if ] build-tree count-introductions ] unit-test
: foo ( a b -- b a ) swap ; inline recursive
: foo ( quot: ( -- ) -- ) call ; inline recursive
: recursive-inputs ( nodes -- n )
[ #recursive? ] find nip child>> first in-d>> length ;
[ 0 2 ] [
[ foo ] build-tree
[ 1 3 ] [
[ [ swap ] foo ] build-tree
[ recursive-inputs ]
[ analyze-recursive normalize recursive-inputs ] bi
] unit-test

View File

@ -310,7 +310,7 @@ CONSTANT: rs-reg 30
4 ds-reg 0 LWZ
5 ds-reg -4 LWZU
5 0 4 CMP
2 swap execute ! magic number
2 swap execute( offset -- ) ! magic number
\ f tag-number 3 LI
3 ds-reg 0 STW ;
@ -341,7 +341,7 @@ CONSTANT: rs-reg 30
: jit-math ( insn -- )
3 ds-reg 0 LWZ
4 ds-reg -4 LWZU
[ 5 3 4 ] dip execute
[ 5 3 4 ] dip execute( dst src1 src2 -- )
5 ds-reg 0 STW ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive

View File

@ -334,7 +334,7 @@ big-endian off
! compare with second value
ds-reg [] temp0 CMP
! move t if true
[ temp1 temp3 ] dip execute
[ temp1 temp3 ] dip execute( dst src -- )
! store
ds-reg [] temp1 MOV ;
@ -355,7 +355,7 @@ big-endian off
! pop stack
ds-reg bootstrap-cell SUB
! compute result
[ ds-reg [] temp0 ] dip execute ;
[ ds-reg [] temp0 ] dip execute( dst src -- ) ;
[ \ ADD jit-math ] f f f \ fixnum+fast define-sub-primitive

View File

@ -35,7 +35,7 @@ M: hello bing hello-test ;
[ 3 ] [ 1 0 <hello> 2 whoa ] unit-test
[ 3 ] [ 1 0 <hello> f <goodbye> 2 whoa ] unit-test
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" (( -- )) eval ] times ] unit-test
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval( -- ) ] times ] unit-test
[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
@ -63,22 +63,22 @@ CONSULT: beta hey value>> 1- ;
[ 0 ] [ 1 <hey> three ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" (( -- )) eval ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: alpha one ;" eval( -- ) ] unit-test
[ f ] [ hey \ two method ] unit-test
[ f ] [ hey \ four method ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" (( -- )) eval ] unit-test
[ ] [ "USE: delegate IN: delegate.tests PROTOCOL: beta two three four ;" eval( -- ) ] unit-test
[ { hey } ] [ alpha protocol-users ] unit-test
[ { hey } ] [ beta protocol-users ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test
[ 0 ] [ 1 <hey> two ] unit-test
[ 0 ] [ 1 <hey> three ] unit-test
[ 0 ] [ 1 <hey> four ] unit-test
[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" (( -- )) eval ] unit-test
[ ] [ "USING: math accessors delegate ; IN: delegate.tests CONSULT: beta hey value>> 2 - ;" eval( -- ) ] unit-test
[ 2 ] [ 1 <hey> one ] unit-test
[ -1 ] [ 1 <hey> two ] unit-test
[ -1 ] [ 1 <hey> three ] unit-test
[ -1 ] [ 1 <hey> four ] unit-test
[ ] [ "IN: delegate.tests FORGET: alpha" (( -- )) eval ] unit-test
[ ] [ "IN: delegate.tests FORGET: alpha" eval( -- ) ] unit-test
[ f ] [ hey \ one method ] unit-test
TUPLE: slot-protocol-test-1 a b ;

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,17 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: editors io.launcher kernel make math.parser namespaces
sequences ;
IN: editors.gedit
: gedit-path ( -- path )
\ gedit-path get-global [
"gedit"
] unless* ;
: gedit ( file line -- )
[
gedit-path , number>string "+" prepend , ,
] { } make run-detached drop ;
[ gedit ] edit-hook set-global

View File

@ -0,0 +1 @@
gedit integration

View File

@ -1,4 +1,6 @@
IN: eval.tests
USING: eval tools.test ;
[ 4 ] [ "USE: math 2 2 +" eval( -- result ) ] unit-test
[ "USE: math 2 2 +" eval( -- ) ] must-fail
[ "4\n" ] [ "USING: math prettyprint ; 2 2 + ." eval>string ] unit-test

View File

@ -56,7 +56,7 @@ sequences eval accessors ;
3 '[ [ [ _ 1array ] call 1array ] call 1array ] call
] unit-test
[ "USING: fry locals.backend ; f '[ load-local _ ]" (( -- quot )) eval ]
[ "USING: fry locals.backend ; f '[ load-local _ ]" eval( -- quot ) ]
[ error>> >r/r>-in-fry-error? ] must-fail-with
[ { { "a" 1 } { "b" 2 } { "c" 3 } { "d" 4 } } ] [

View File

@ -272,8 +272,8 @@ HELP: nweave
HELP: n*quot
{ $values
{ "n" integer } { "seq" sequence }
{ "seq'" sequence }
{ "n" integer } { "quot" quotation }
{ "quot'" quotation }
}
{ $examples
{ $example "USING: generalizations prettyprint math ;"

View File

@ -7,7 +7,7 @@ IN: generalizations
<<
: n*quot ( n seq -- seq' ) <repetition> concat >quotation ;
: n*quot ( n quot -- quot' ) <repetition> concat >quotation ;
: repeat ( n obj quot -- ) swapd times ; inline
@ -94,4 +94,4 @@ MACRO: nweave ( n -- )
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline
: nappend ( n -- seq ) narray concat ; inline
: nappend ( n -- seq ) narray concat ; inline

View File

@ -6,9 +6,9 @@ IN: hash2.tests
: sample-hash ( -- hash )
5 <hash2>
dup 2 3 "foo" roll set-hash2
dup 4 2 "bar" roll set-hash2
dup 4 7 "other" roll set-hash2 ;
[ [ 2 3 "foo" ] dip set-hash2 ] keep
[ [ 4 2 "bar" ] dip set-hash2 ] keep
[ [ 4 7 "other" ] dip set-hash2 ] keep ;
[ "foo" ] [ 2 3 sample-hash hash2 ] unit-test
[ "bar" ] [ 4 2 sample-hash hash2 ] unit-test

View File

@ -1,4 +1,6 @@
USING: kernel sequences arrays math vectors ;
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences arrays math vectors locals ;
IN: hash2
! Little ad-hoc datastructure used to map two numbers
@ -22,8 +24,8 @@ IN: hash2
: assoc2 ( a b alist -- value )
(assoc2) dup [ third ] when ; inline
: set-assoc2 ( value a b alist -- alist )
[ rot 3array ] dip ?push ; inline
:: set-assoc2 ( value a b alist -- alist )
{ a b value } alist ?push ; inline
: hash2@ ( a b hash2 -- a b bucket hash2 )
[ 2dup hashcode2 ] dip [ length mod ] keep ; inline
@ -31,8 +33,8 @@ IN: hash2
: hash2 ( a b hash2 -- value/f )
hash2@ nth dup [ assoc2 ] [ 3drop f ] if ;
: set-hash2 ( a b value hash2 -- )
[ -rot ] dip hash2@ [ set-assoc2 ] change-nth ;
:: set-hash2 ( a b value hash2 -- )
value a b hash2 hash2@ [ set-assoc2 ] change-nth ;
: alist>hash2 ( alist size -- hash2 )
<hash2> [ over [ first3 ] dip set-hash2 ] reduce ; inline

View File

@ -4,7 +4,7 @@ definitions assocs sequences kernel namespaces parser arrays
io.streams.string continuations debugger compiler.units eval ;
[ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" (( -- )) eval
"IN: help.crossref.tests USING: help.syntax help.markup ; : foo ( -- ) ; HELP: foo \"foo is great\" ; ARTICLE: \"foo\" \"Foo\" { $subsection foo } ;" eval( -- )
] unit-test
[ $subsection ] [
@ -23,7 +23,7 @@ io.streams.string continuations debugger compiler.units eval ;
] unit-test
[ ] [
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" (( -- )) eval
"IN: help.crossref.tests USING: help.syntax help.markup ; : bar ( -- ) ; HELP: bar \"bar is great\" ; ARTICLE: \"bar\" \"Bar\" { $subsection bar } ;" eval( -- )
] unit-test
[ ] [

View File

@ -32,7 +32,7 @@ IN: help.definitions.tests
"hello" "help.definitions.tests" lookup "help" word-prop
] unit-test
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" (( -- )) eval ] unit-test
[ ] [ "IN: help.definitions.tests USING: help.syntax ; : xxx ( -- ) ; HELP: xxx ;" eval( -- ) ] unit-test
[ ] [ "xxx" "help.definitions.tests" lookup print-topic ] unit-test

View File

@ -4,12 +4,12 @@ IN: help.syntax.tests
[
[ "foobar" ] [
"IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" (( -- )) eval
"IN: help.syntax.tests USE: help.syntax ABOUT: \"foobar\"" eval( -- )
"help.syntax.tests" vocab vocab-help
] unit-test
[ { "foobar" } ] [
"IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" (( -- )) eval
"IN: help.syntax.tests USE: help.syntax ABOUT: { \"foobar\" }" eval( -- )
"help.syntax.tests" vocab vocab-help
] unit-test

View File

@ -29,7 +29,7 @@ SYMBOL: foo
} "\n" join
[
"testfile" source-file file set
(( -- )) eval
eval( -- )
] with-scope
] unit-test

View File

@ -184,6 +184,12 @@ ERROR: download-failed response ;
: http-put ( post-data url -- response data )
<put-request> http-request ;
: <delete-request> ( url -- request )
"DELETE" <client-request> ;
: http-delete ( url -- response data )
<delete-request> http-request ;
USING: vocabs vocabs.loader ;
"debugger" vocab [ "http.client.debugger" require ] when

View File

@ -0,0 +1,8 @@
IN: io.crlf.tests
USING: io.crlf tools.test io.streams.string io ;
[ "Hello, world." ] [ "Hello, world." [ read-crlf ] with-string-reader ] unit-test
[ "Hello, world." ] [ "Hello, world.\r\n" [ read-crlf ] with-string-reader ] unit-test
[ "Hello, world.\r" [ read-crlf ] with-string-reader ] must-fail
[ f ] [ "" [ read-crlf ] with-string-reader ] unit-test
[ "" ] [ "\r\n" [ read-crlf ] with-string-reader ] unit-test

View File

@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg, Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: io kernel ;
USING: io kernel sequences ;
IN: io.crlf
: crlf ( -- )
@ -8,4 +8,4 @@ IN: io.crlf
: read-crlf ( -- seq )
"\r" read-until
[ CHAR: \r assert= read1 CHAR: \n assert= ] when* ;
[ CHAR: \r assert= read1 CHAR: \n assert= ] [ f like ] if* ;

View File

@ -10,13 +10,13 @@ USING: io.launcher.unix.parser tools.test ;
[ V{ "abc" "def" } ] [ "abc def" tokenize-command ] unit-test
[ V{ "abc def" } ] [ "abc\\ def" tokenize-command ] unit-test
[ V{ "abc\\" "def" } ] [ "abc\\\\ def" tokenize-command ] unit-test
[ V{ "abc\\ def" } ] [ "'abc\\\\ def'" tokenize-command ] unit-test
[ V{ "abc\\ def" } ] [ " 'abc\\\\ def'" tokenize-command ] unit-test
[ V{ "abc\\ def" "hey" } ] [ "'abc\\\\ def' hey" tokenize-command ] unit-test
[ V{ "abc def" "hey" } ] [ "'abc def' \"hey\"" tokenize-command ] unit-test
[ "'abc def' \"hey" tokenize-command ] must-fail
[ "'abc def" tokenize-command ] must-fail
[ V{ "abc def" "h\"ey" } ] [ "'abc def' \"h\\\"ey\" " tokenize-command ] unit-test
[ V{ "abc\\ def" } ] [ "\"abc\\\\ def\"" tokenize-command ] unit-test
[ V{ "abc\\ def" } ] [ " \"abc\\\\ def\"" tokenize-command ] unit-test
[ V{ "abc\\ def" "hey" } ] [ "\"abc\\\\ def\" hey" tokenize-command ] unit-test
[ V{ "abc def" "hey" } ] [ "\"abc def\" \"hey\"" tokenize-command ] unit-test
[ "\"abc def\" \"hey" tokenize-command ] must-fail
[ "\"abc def" tokenize-command ] must-fail
[ V{ "abc def" "h\"ey" } ] [ "\"abc def\" \"h\\\"ey\" " tokenize-command ] unit-test
[
V{

View File

@ -1,33 +1,17 @@
! Copyright (C) 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: peg peg.parsers kernel sequences strings words ;
USING: peg peg.ebnf arrays sequences strings kernel ;
IN: io.launcher.unix.parser
! Our command line parser. Supported syntax:
! foo bar baz -- simple tokens
! foo\ bar -- escaping the space
! 'foo bar' -- quotation
! "foo bar" -- quotation
: 'escaped-char' ( -- parser )
"\\" token any-char 2seq [ second ] action ;
: 'quoted-char' ( delimiter -- parser' )
'escaped-char'
swap [ member? not ] curry satisfy
2choice ; inline
: 'quoted' ( delimiter -- parser )
dup 'quoted-char' repeat0 swap dup surrounded-by ;
: 'unquoted' ( -- parser ) " '\"" 'quoted-char' repeat1 ;
: 'argument' ( -- parser )
"\"" 'quoted'
"'" 'quoted'
'unquoted' 3choice
[ >string ] action ;
PEG: tokenize-command ( command -- ast/f )
'argument' " " token repeat1 list-of
" " token repeat0 tuck pack
just ;
EBNF: tokenize-command
space = " "
escaped-char = "\" .:ch => [[ ch ]]
quoted = '"' (escaped-char | [^"])*:a '"' => [[ a ]]
unquoted = (escaped-char | [^ "])+
argument = (quoted | unquoted) => [[ >string ]]
command = space* (argument:a space* => [[ a ]])+:c !(.) => [[ c ]]
;EBNF

View File

@ -98,7 +98,7 @@ IN: io.launcher.windows.nt.tests
<process>
console-vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
] with-directory eval
] with-directory eval( -- alist )
os-envs =
] unit-test
@ -110,7 +110,7 @@ IN: io.launcher.windows.nt.tests
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> contents
] with-directory eval
] with-directory eval( -- alist )
os-envs =
] unit-test
@ -121,7 +121,7 @@ IN: io.launcher.windows.nt.tests
console-vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> contents
] with-directory eval
] with-directory eval( -- alist )
"A" swap at
] unit-test
@ -133,7 +133,7 @@ IN: io.launcher.windows.nt.tests
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> contents
] with-directory eval
] with-directory eval( -- alist )
"USERPROFILE" swap at "XXX" =
] unit-test

View File

@ -192,7 +192,7 @@ M: object (client) ( remote -- client-in client-out local )
] with-destructors ;
: <client> ( remote encoding -- stream local )
[ (client) -rot ] dip <encoder-duplex> swap ;
[ (client) ] dip swap [ <encoder-duplex> ] dip ;
SYMBOL: local-address

View File

@ -25,7 +25,7 @@ SYNTAX: hello "Hi" print ;
"\\ + 1 2 3 4" parse-interactive
"cont" get continue-with
] ignore-errors
"USE: debugger :1" (( -- quot )) eval
"USE: debugger :1" eval( -- quot )
] callcc1
] unit-test
] with-file-vocabs

View File

@ -106,7 +106,8 @@ PRIVATE>
: deep-sequence>cons ( sequence -- cons )
[ <reversed> ] keep nil
[ tuck same? [ deep-sequence>cons ] when swons ] with reduce ;
[ [ nip ] [ same? ] 2bi [ deep-sequence>cons ] when swons ]
with reduce ;
<PRIVATE
:: (lmap>vector) ( acc list quot: ( elt -- elt' ) -- acc )

View File

@ -261,7 +261,7 @@ M:: fixnum next-method-test ( a -- b ) a call-next-method 1 + ;
CONSTANT: new-definition "USING: math ;\nIN: locals.tests\n: a-word-with-locals ( -- x ) 2 3 + ;\n"
[ ] [ new-definition (( -- )) eval ] unit-test
[ ] [ new-definition eval( -- ) ] unit-test
[ t ] [
[ \ a-word-with-locals see ] with-string-writer
@ -461,7 +461,7 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[
"USING: locals fry math ; 1 '[ [let | A [ 10 ] | A _ + ] ]"
(( -- )) eval call
eval( -- ) call
] [ error>> >r/r>-in-fry-error? ] must-fail-with
:: (funny-macro-test) ( obj quot -- ? ) obj { quot } 1&& ; inline
@ -473,10 +473,10 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ f ] [ 2 funny-macro-test ] unit-test
! Some odd parser corner cases
[ "USE: locals [let" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let |" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let | a" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" (( -- )) eval ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let |" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [let | a" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ "USE: locals [|" eval( -- ) ] [ error>> unexpected-eof? ] must-fail-with
[ 25 ] [ 5 [| a | { [ a sq ] } cond ] call ] unit-test
[ 25 ] [ 5 [| | { [| a | a sq ] } ] call first call ] unit-test
@ -491,19 +491,19 @@ M:: integer lambda-method-forget-test ( a -- b ) ;
[ 3 ] [ 3 [| a | \ a ] call ] unit-test
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail
[ "USE: locals [| | { [let | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail
[ "USE: locals [| | { [wlet | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" (( -- )) eval ] must-fail
[ "USE: locals [| | { [let* | a [ 0 ] | a ] } ]" eval( -- ) ] must-fail
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" (( -- )) eval ] must-fail
[ "USE: locals [| | [let | a! [ 0 ] | { a! } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" (( -- )) eval ] must-fail
[ "USE: locals [| | [wlet | a [ 0 ] | { a } ] ]" eval( -- ) ] must-fail
[ "USE: locals [| | { :> a } ]" (( -- )) eval ] must-fail
[ "USE: locals [| | { :> a } ]" eval( -- ) ] must-fail
[ "USE: locals 3 :> a" (( -- )) eval ] must-fail
[ "USE: locals 3 :> a" eval( -- ) ] must-fail
[ 3 ] [ 3 [| | :> a a ] call ] unit-test

View File

@ -13,11 +13,11 @@ unit-test
[ t ] [ \ see-test macro? ] unit-test
[ t ] [
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup (( -- )) eval
"USING: math ;\nIN: macros.tests\n: see-test ( a b -- c ) - ;\n" dup eval( -- )
[ \ see-test see ] with-string-writer =
] unit-test
[ f ] [ \ see-test macro? ] unit-test
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" (( -- )) eval ] unit-test
[ ] [ "USING: macros stack-checker kernel ; IN: hanging-macro MACRO: c ( quot -- ) infer drop [ ] ; : a ( -- ) [ a ] c ;" eval( -- ) ] unit-test

View File

@ -62,8 +62,7 @@ MACRO: match-cond ( assoc -- )
} cond ;
: match-replace ( object pattern1 pattern2 -- result )
-rot
match [ "Pattern does not match" throw ] unless*
[ match [ "Pattern does not match" throw ] unless* ] dip swap
[ replace-patterns ] bind ;
: ?1-tail ( seq -- tail/f )

View File

@ -9,7 +9,7 @@ MEMO: fib ( m -- n )
[ 89 ] [ 10 fib ] unit-test
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" (( -- )) eval ] must-fail
[ "USING: kernel math memoize generalizations ; IN: memoize.tests MEMO: x ( a b c d e -- f g h i j ) [ 1+ ] 4 ndip ;" eval( -- ) ] must-fail
MEMO: see-test ( a -- b ) reverse ;
@ -17,7 +17,7 @@ MEMO: see-test ( a -- b ) reverse ;
[ [ \ see-test see ] with-string-writer ]
unit-test
[ ] [ "IN: memoize.tests : fib ( -- ) ;" (( -- )) eval ] unit-test
[ ] [ "IN: memoize.tests : fib ( -- ) ;" eval( -- ) ] unit-test
[ "IN: memoize.tests\n: fib ( -- ) ;\n" ] [ [ \ fib see ] with-string-writer ] unit-test

View File

@ -56,6 +56,6 @@ TUPLE: color
! Test reshaping with a mirror
1 2 3 color boa <mirror> "mirror" set
[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" (( -- )) eval ] unit-test
[ ] [ "IN: mirrors.tests USE: math TUPLE: color { green integer } { red integer } { blue integer } ;" eval( -- ) ] unit-test
[ 1 ] [ "red" "mirror" get at ] unit-test

View File

@ -45,7 +45,7 @@ TUPLE: single-texture image dim loc texture-coords texture display-list disposed
: adjust-texture-dim ( dim -- dim' )
non-power-of-2-textures? get [
[ next-power-of-2 ] map
[ dup 1 = [ next-power-of-2 ] unless ] map
] unless ;
: (tex-image) ( image bitmap -- )

View File

@ -445,11 +445,11 @@ foo=<foreign any-char> 'd'
] unit-test
{ } [
"USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" (( -- )) eval
"USING: kernel peg.ebnf ; \"a\\n\" [EBNF foo='a' '\n' => [[ drop \"\n\" ]] EBNF] drop" eval( -- )
] unit-test
[
"USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" (( -- )) eval drop
"USING: peg.ebnf ; <EBNF foo='a' foo='b' EBNF>" eval( -- ) drop
] must-fail
{ t } [
@ -521,12 +521,12 @@ Tok = Spaces (Number | Special )
"\\" [EBNF foo="\\" EBNF]
] unit-test
[ "USE: peg.ebnf [EBNF EBNF]" (( -- )) eval ] must-fail
[ "USE: peg.ebnf [EBNF EBNF]" eval( -- ) ] must-fail
[ <" USE: peg.ebnf [EBNF
lol = a
lol = b
EBNF] "> (( -- )) eval
EBNF] "> eval( -- )
] [
error>> [ redefined-rule? ] [ name>> "lol" = ] bi and
] must-fail-with

View File

@ -2,8 +2,8 @@ USING: arrays definitions io.streams.string io.streams.duplex
kernel math namespaces parser prettyprint prettyprint.config
prettyprint.sections sequences tools.test vectors words
effects splitting generic.standard prettyprint.private
continuations generic compiler.units tools.walker eval
accessors make vocabs.parser see ;
continuations generic compiler.units tools.continuations
tools.continuations.private eval accessors make vocabs.parser see ;
IN: prettyprint.tests
[ "4" ] [ 4 unparse ] unit-test
@ -254,7 +254,7 @@ M: class-see-layout class-see-layout ;
! Regression
[ t ] [
"IN: prettyprint.tests\nGENERIC: generic-decl-test ( a -- b ) flushable\n"
dup (( -- )) eval
dup eval( -- )
"generic-decl-test" "prettyprint.tests" lookup
[ see ] with-string-writer =
] unit-test

View File

@ -1 +1,2 @@
Slava Pestov
Alex Chapman

View File

@ -1,38 +1,90 @@
! Copyright (C) 2007 Slava Pestov
! Copyright (C) 2007 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.syntax kernel ;
USING: boxes help.markup help.syntax kernel math namespaces ;
IN: refs
ARTICLE: "refs" "References to assoc entries"
"A " { $emphasis "reference" } " is an object encapsulating an assoc and a key; the reference then refers to either the key itself, or the value associated to the key. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary."
ARTICLE: "refs" "References"
"References provide a uniform way of accessing and changing values. Some examples of referenced values are variables, tuple slots, and keys or values of assocs. References can be read, written, and deleted. References are defined in the " { $vocab-link "refs" } " vocabulary, and new reference types can be made by implementing the " { $link "refs-protocol" } "."
{ $subsection get-ref }
{ $subsection set-ref }
{ $subsection set-ref* }
{ $subsection delete-ref }
"References to keys:"
"References to objects:"
{ $subsection obj-ref }
{ $subsection <obj-ref> }
"References to assoc keys:"
{ $subsection key-ref }
{ $subsection <key-ref> }
"References to values:"
"References to assoc values:"
{ $subsection value-ref }
{ $subsection <value-ref> }
"References to variables:"
{ $subsection var-ref }
{ $subsection <var-ref> }
{ $subsection global-var-ref }
{ $subsection <global-var-ref> }
"References to tuple slots:"
{ $subsection slot-ref }
{ $subsection <slot-ref> }
"Using boxes as references:"
{ $subsection "box-refs" }
"References are used by the UI inspector." ;
ABOUT: "refs"
ARTICLE: "refs-protocol" "Reference Protocol"
"To use a class of objects as references you must implement the reference protocol for that class, and mark your class as an instance of the " { $link ref } " mixin class. All references must implement these two words:"
{ $subsection get-ref }
{ $subsection set-ref }
"References may also implement:"
{ $subsection delete-ref } ;
ARTICLE: "box-refs" "Using Boxes as References"
"Boxes are elements of the " { $link ref } " mixin class, so any box may be used as a reference. Bear in mind that boxes will still throw an error if you call " { $link get-ref } " on an empty box." ;
HELP: ref
{ $class-description "A class whose instances identify a key or value location in an associative structure. Instances of this clas are never used directly; only instances of " { $link key-ref } " and " { $link value-ref } " should be created." } ;
{ $class-description "A mixin class whose instances encapsulate a value which can be read, written, and deleted. Instantiable members of this class include:" { $link obj-ref } ", " { $link var-ref } ", " { $link global-var-ref } ", " { $link slot-ref } ", " { $link box } ", " { $link key-ref } ", and " { $link value-ref } "." } ;
HELP: delete-ref
{ $values { "ref" ref } }
{ $description "Deletes the association entry pointed at by this reference." } ;
{ $description "Deletes the value pointed to by this reference. In most references this simply sets the value to f, but in some cases it is more destructive, such as in " { $link value-ref } " and " { $link key-ref } ", where it actually deletes the entry from the underlying assoc." } ;
HELP: get-ref
{ $values { "ref" ref } { "obj" object } }
{ $description "Outputs the key or the value pointed at by this reference." } ;
{ $description "Outputs the value pointed at by this reference." } ;
HELP: set-ref
{ $values { "obj" object } { "ref" ref } }
{ $description "Stores a new key or value at by this reference." } ;
{ $description "Stores a new value at this reference." } ;
HELP: obj-ref
{ $class-description "Instances of this class contain a value which can be changed using the " { $link "refs-protocol" } ". New object references are created by calling " { $link <obj-ref> } "." } ;
HELP: <obj-ref>
{ $values { "obj" object } { "obj-ref" obj-ref } }
{ $description "Creates a reference which contains the value it references." } ;
HELP: var-ref
{ $class-description "Instances of this class reference a variable as defined by the " { $vocab-link "namespaces" } " vocabulary. New variable references are created by calling " { $link <var-ref> } "." } ;
HELP: <var-ref>
{ $values { "var" object } { "var-ref" var-ref } }
{ $description "Creates a reference to the given variable. Note that this reference behaves just like any variable when it comes to dynamic scope. For example, if you use " { $link set-ref } " in an inner scope and then leave that scope, then calling " { $link get-ref } " may not return the expected value. If this is not what you want, try using an " { $link obj-ref } " instead." } ;
HELP: global-var-ref
{ $class-description "Instances of this class reference a global variable. New global references are created by calling " { $link <global-var-ref> } "." } ;
HELP: <global-var-ref>
{ $values { "var" object } { "global-var-ref" global-var-ref } }
{ $description "Creates a reference to a global variable." } ;
HELP: slot-ref
{ $class-description "Instances of this class identify a particular slot of a particular instance of a tuple. New slot references are created by calling " { $link <slot-ref> } "." } ;
HELP: <slot-ref>
{ $values { "tuple" tuple } { "slot" integer } { "slot-ref" slot-ref } }
{ $description "Creates a reference to the value in a particular slot of the given tuple. The slot must be given as an integer, where the first user-defined slot is number 2. This is mostly just a proof of concept until we have a way of generating this slot number from a slot name." } ;
HELP: key-ref
{ $class-description "Instances of this class identify a key in an associative structure. New key references are created by calling " { $link <key-ref> } "." } ;
@ -47,6 +99,37 @@ HELP: <value-ref>
{ $values { "assoc" "an assoc" } { "key" object } { "value-ref" value-ref } }
{ $description "Creates a reference to the value associated with " { $snippet "key" } " in " { $snippet "assoc" } "." } ;
{ get-ref set-ref delete-ref } related-words
{ get-ref set-ref delete-ref set-ref* } related-words
{ <obj-ref> <var-ref> <global-var-ref> <slot-ref> <key-ref> <value-ref> } related-words
{ <key-ref> <value-ref> } related-words
HELP: set-ref*
{ $values { "ref" ref } { "obj" object } }
{ $description "Just like " { $link set-ref } ", but leave the ref on the stack." } ;
HELP: ref-on
{ $values { "ref" ref } }
{ $description "Sets the value of the ref to t." } ;
HELP: ref-off
{ $values { "ref" ref } }
{ $description "Sets the value of the ref to f." } ;
HELP: ref-inc
{ $values { "ref" ref } }
{ $description "Increment the value of the ref by 1." } ;
HELP: ref-dec
{ $values { "ref" ref } }
{ $description "Decrement the value of the ref by 1." } ;
HELP: take
{ $values { "ref" ref } { "obj" object } }
{ $description "Retrieve the value of the ref and then delete it, returning the value." } ;
{ ref-on ref-off ref-inc ref-dec take } related-words
{ take delete-ref } related-words
{ on ref-on } related-words
{ off ref-off } related-words
{ inc ref-inc } related-words
{ dec ref-dec } related-words

View File

@ -1,5 +1,7 @@
USING: refs tools.test kernel ;
USING: boxes kernel namespaces refs tools.test ;
IN: refs.tests
! assoc-refs
[ 3 ] [
H{ { "a" 3 } } "a" <value-ref> get-ref
] unit-test
@ -20,3 +22,84 @@ USING: refs tools.test kernel ;
set-ref
] keep
] unit-test
SYMBOLS: lion giraffe elephant rabbit ;
! obj-refs
[ rabbit ] [ rabbit <obj-ref> get-ref ] unit-test
[ rabbit ] [ f <obj-ref> rabbit set-ref* get-ref ] unit-test
[ rabbit ] [ rabbit <obj-ref> take ] unit-test
[ rabbit f ] [ rabbit <obj-ref> [ take ] keep get-ref ] unit-test
[ lion ] [ rabbit <obj-ref> dup [ drop lion ] change-ref get-ref ] unit-test
! var-refs
[ giraffe ] [ [ giraffe rabbit set rabbit <var-ref> get-ref ] with-scope ] unit-test
[ rabbit ]
[
[
lion rabbit set [
rabbit rabbit set rabbit <var-ref> get-ref
] with-scope
] with-scope
] unit-test
[ rabbit ] [
rabbit <var-ref>
[
lion rabbit set [
rabbit rabbit set get-ref
] with-scope
] with-scope
] unit-test
[ elephant ] [
rabbit <var-ref>
[
elephant rabbit set [
rabbit rabbit set
] with-scope
get-ref
] with-scope
] unit-test
[ rabbit ] [
rabbit <var-ref>
[
elephant set-ref* [
rabbit set-ref* get-ref
] with-scope
] with-scope
] unit-test
[ elephant ] [
rabbit <var-ref>
[
elephant set-ref* [
rabbit set-ref*
] with-scope
get-ref
] with-scope
] unit-test
! Top Hats
[ lion ] [ lion rabbit set-global rabbit <global-var-ref> get-ref ] unit-test
[ giraffe ] [ rabbit <global-var-ref> giraffe set-ref* get-ref ] unit-test
! Tuple refs
TUPLE: foo bar ;
C: <foo> foo
: test-tuple ( -- tuple )
rabbit <foo> ;
: test-slot-ref ( -- slot-ref )
test-tuple 2 <slot-ref> ; ! hack!
[ rabbit ] [ test-slot-ref get-ref ] unit-test
[ lion ] [ test-slot-ref lion set-ref* get-ref ] unit-test
! Boxes as refs
[ rabbit ] [ <box> rabbit set-ref* get-ref ] unit-test
[ <box> rabbit set-ref* lion set-ref* ] must-fail
[ <box> get-ref ] must-fail

View File

@ -1,22 +1,77 @@
! Copyright (C) 2007, 2008 Slava Pestov
! Copyright (C) 2007, 2008 Slava Pestov, 2009 Alex Chapman
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple kernel assocs accessors ;
USING: kernel assocs accessors boxes math namespaces ;
IN: refs
TUPLE: ref assoc key ;
MIXIN: ref
: >ref< ( ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
: delete-ref ( ref -- ) >ref< delete-at ;
GENERIC: get-ref ( ref -- obj )
GENERIC: set-ref ( obj ref -- )
GENERIC: delete-ref ( ref -- )
TUPLE: key-ref < ref ;
! works like >>slot words
: set-ref* ( ref obj -- ref ) over set-ref ;
! very similar to change, on, off, +@, inc, and dec from namespaces
: change-ref ( ref quot -- )
[ [ get-ref ] keep ] dip dip set-ref ; inline
: ref-on ( ref -- ) t swap set-ref ;
: ref-off ( ref -- ) f swap set-ref ;
: ref-+@ ( n ref -- ) [ 0 or + ] change-ref ;
: ref-inc ( ref -- ) 1 swap ref-+@ ;
: ref-dec ( ref -- ) -1 swap ref-+@ ;
: take ( ref -- obj )
dup get-ref swap delete-ref ;
! delete-ref defaults to setting ref to f
M: ref delete-ref ref-off ;
TUPLE: obj-ref obj ;
C: <obj-ref> obj-ref
M: obj-ref get-ref obj>> ;
M: obj-ref set-ref (>>obj) ;
INSTANCE: obj-ref ref
TUPLE: var-ref var ;
C: <var-ref> var-ref
M: var-ref get-ref var>> get ;
M: var-ref set-ref var>> set ;
INSTANCE: var-ref ref
TUPLE: global-var-ref var ;
C: <global-var-ref> global-var-ref
M: global-var-ref get-ref var>> get-global ;
M: global-var-ref set-ref var>> set-global ;
INSTANCE: global-var-ref ref
USE: slots.private
TUPLE: slot-ref tuple slot ;
C: <slot-ref> slot-ref
: >slot-ref< ( slot-ref -- tuple slot ) [ tuple>> ] [ slot>> ] bi ; inline
M: slot-ref get-ref >slot-ref< slot ;
M: slot-ref set-ref >slot-ref< set-slot ;
INSTANCE: slot-ref ref
M: box get-ref box> ;
M: box set-ref >box ;
M: box delete-ref box> drop ;
INSTANCE: box ref
TUPLE: assoc-ref assoc key ;
: >assoc-ref< ( assoc-ref -- key value ) [ key>> ] [ assoc>> ] bi ; inline
M: assoc-ref delete-ref ( assoc-ref -- ) >assoc-ref< delete-at ;
TUPLE: key-ref < assoc-ref ;
C: <key-ref> key-ref
M: key-ref get-ref key>> ;
M: key-ref set-ref >ref< rename-at ;
M: key-ref set-ref >assoc-ref< rename-at ;
INSTANCE: key-ref ref
TUPLE: value-ref < ref ;
TUPLE: value-ref < assoc-ref ;
C: <value-ref> value-ref
M: value-ref get-ref >ref< at ;
M: value-ref set-ref >ref< set-at ;
M: value-ref get-ref >assoc-ref< at ;
M: value-ref set-ref >assoc-ref< set-at ;
INSTANCE: value-ref ref

View File

@ -262,11 +262,11 @@ IN: regexp-tests
! Comment inside a regular expression
[ t ] [ "ac" "a(?#boo)c" <regexp> matches? ] unit-test
[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" (( -- )) eval ] unit-test
[ ] [ "USING: regexp kernel ; R' -{3}[+]{1,6}(?:!!)?\\s' drop" eval( -- ) ] unit-test
[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" (( -- )) eval ] unit-test
[ ] [ "USING: regexp kernel ; R' (ftp|http|https)://(\\w+:?\\w*@)?(\\S+)(:[0-9]+)?(/|/([\\w#!:.?+=&%@!\\-/]))?' drop" eval( -- ) ] unit-test
[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" (( -- )) eval ] unit-test
[ ] [ "USING: regexp kernel ; R' \\*[^\s*][^*]*\\*' drop" eval( -- ) ] unit-test
[ "ab" ] [ "ab" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test
[ "abc" ] [ "abc" "(a|ab)(bc)?" <regexp> first-match >string ] unit-test

View File

@ -1,3 +1,5 @@
Elie Chaftari
Dirk Vleugels
Slava Pestov
Doug Coleman
Daniel Ehrenberg

View File

@ -36,6 +36,7 @@ SYMBOL: data-mode
: process ( -- )
read-crlf {
{ [ dup not ] [ f ] }
{
[ dup [ "HELO" head? ] [ "EHLO" head? ] bi or ]
[ "220 and..?\r\n" write flush t ]

View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel quotations help.syntax help.markup
io.sockets strings calendar ;
io.sockets strings calendar io.encodings.utf8 ;
IN: smtp
HELP: smtp-domain
@ -41,7 +41,9 @@ HELP: email
{ { $slot "to" } "The recipients of the e-mail. A sequence of e-mail addresses." }
{ { $slot "cc" } "Carbon-copy. A sequence of e-mail addresses." }
{ { $slot "bcc" } "Blind carbon-copy. A sequence of e-mail addresses." }
{ { $slot "subject" } " The subject of the e-mail. A string." }
{ { $slot "subject" } "The subject of the e-mail. A string." }
{ { $slot "content-type" } { "The MIME type of the body. A string, default is " { $snippet "text/plain" } "." } }
{ { $slot "encoding" } { "An encoding to send the body as. Default is " { $link utf8 } "." } }
{ { $slot "body" } " The body of the e-mail. A string." }
}
"The " { $slot "from" } " and " { $slot "to" } " slots are required; the rest are optional."

View File

@ -16,7 +16,7 @@ IN: smtp.tests
[ { "hello" "." "world" } validate-message ] must-fail
[ "aGVsbG8Kd29ybGQ=\r\n.\r\n" ] [
"hello\nworld" [ send-body ] with-string-writer
T{ email { body "hello\nworld" } } [ send-body ] with-string-writer
] unit-test
[ { "500 syntax error" } <response> check-response ]
@ -51,7 +51,7 @@ IN: smtp.tests
[
{
{ "Content-Transfer-Encoding" "base64" }
{ "Content-Type" "Text/plain; charset=utf-8" }
{ "Content-Type" "text/plain; charset=UTF-8" }
{ "From" "Doug <erg@factorcode.org>" }
{ "MIME-Version" "1.0" }
{ "Subject" "Factor rules" }

View File

@ -1,12 +1,12 @@
! Copyright (C) 2007, 2008 Elie CHAFTARI, Dirk Vleugels,
! Slava Pestov, Doug Coleman.
! Slava Pestov, Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays namespaces make io io.encodings.string
io.encodings.utf8 io.timeouts io.sockets io.sockets.secure
io.encodings.ascii kernel logging sequences combinators
splitting assocs strings math.order math.parser random system
calendar summary calendar.format accessors sets hashtables
base64 debugger classes prettyprint io.crlf ;
USING: arrays namespaces make io io.encodings.string io.encodings.utf8
io.encodings.iana io.timeouts io.sockets io.sockets.secure
io.encodings.ascii kernel logging sequences combinators splitting
assocs strings math.order math.parser random system calendar summary
calendar.format accessors sets hashtables base64 debugger classes
prettyprint io.crlf words ;
IN: smtp
SYMBOL: smtp-domain
@ -44,6 +44,8 @@ TUPLE: email
{ cc array }
{ bcc array }
{ subject string }
{ content-type string initial: "text/plain" }
{ encoding word initial: utf8 }
{ body string } ;
: <email> ( -- email ) email new ; inline
@ -85,8 +87,8 @@ M: message-contains-dot summary ( obj -- string )
"." over member?
[ message-contains-dot ] when ;
: send-body ( body -- )
utf8 encode
: send-body ( email -- )
[ body>> ] [ encoding>> ] bi encode
>base64-lines write crlf
"." command ;
@ -162,9 +164,8 @@ M: plain-auth send-auth
: encode-header ( string -- string' )
dup aux>> [
"=?utf-8?B?"
swap utf8 encode >base64
"?=" 3append
utf8 encode >base64
"=?utf-8?B?" "?=" surround
] when ;
ERROR: invalid-header-string string ;
@ -195,24 +196,23 @@ ERROR: invalid-header-string string ;
! This could be much smarter.
" " split1-last swap or "<" ?head drop ">" ?tail drop ;
: utf8-mime-header ( -- alist )
{
{ "MIME-Version" "1.0" }
{ "Content-Transfer-Encoding" "base64" }
{ "Content-Type" "Text/plain; charset=utf-8" }
} ;
: email-content-type ( email -- content-type )
[ content-type>> ] [ encoding>> encoding>name ] bi "; charset=" glue ;
: email>headers ( email -- hashtable )
: email>headers ( email -- assoc )
[
now timestamp>rfc822 "Date" set
message-id "Message-Id" set
"1.0" "MIME-Version" set
"base64" "Content-Transfer-Encoding" set
{
[ from>> "From" set ]
[ to>> ", " join "To" set ]
[ cc>> ", " join [ "Cc" set ] unless-empty ]
[ subject>> "Subject" set ]
[ email-content-type "Content-Type" set ]
} cleave
now timestamp>rfc822 "Date" set
message-id "Message-Id" set
] { } make-assoc utf8-mime-header append ;
] { } make-assoc ;
: (send-email) ( headers email -- )
[
@ -227,7 +227,7 @@ ERROR: invalid-header-string string ;
data get-ok
swap write-headers
crlf
body>> send-body get-ok
send-body get-ok
quit get-ok
] with-smtp-connection ;

View File

@ -6,19 +6,21 @@ IN: sorting.slots
HELP: compare-slots
{ $values
{ "sort-specs" "a sequence of accessors ending with a comparator" }
{ "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
{ "obj1" object }
{ "obj2" object }
{ "sort-specs" "a sequence of accessors ending with a comparator" }
{ "<=>" { $link +lt+ } " " { $link +eq+ } " or " { $link +gt+ } }
}
{ $description "Compares two objects using a chain of intrinsic linear orders such that if two objects are " { $link +eq+ } ", then the next comparator is tried. The comparators are slot-name/comparator pairs." } ;
HELP: sort-by-slots
HELP: sort-by
{ $values
{ "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
{ "sortedseq" sequence }
{ "seq'" sequence }
}
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
{ $examples
"Sort by slot c, then b descending:"
"Sort by slot a, then b descending:"
{ $example
"USING: accessors math.order prettyprint sorting.slots ;"
"IN: scratchpad"
@ -27,32 +29,18 @@ HELP: sort-by-slots
" T{ sort-me f 2 3 } T{ sort-me f 3 2 }"
" T{ sort-me f 4 3 } T{ sort-me f 2 1 }"
"}"
"{ { a>> <=> } { b>> >=< } } sort-by-slots ."
"{ { a>> <=> } { b>> >=< } } sort-by ."
"{\n T{ sort-me { a 2 } { b 3 } }\n T{ sort-me { a 2 } { b 1 } }\n T{ sort-me { a 3 } { b 2 } }\n T{ sort-me { a 4 } { b 3 } }\n}"
}
} ;
HELP: split-by-slots
{ $values
{ "accessor-seqs" "a sequence of sequences of tuple accessors" }
{ "quot" quotation }
}
{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
HELP: sort-by
{ $values
{ "seq" sequence } { "sort-seq" "a sequence of comparators" }
{ "sortedseq" sequence }
}
{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
ARTICLE: "sorting.slots" "Sorting by slots"
"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
"Comparing two objects by a sequence of slots:"
{ $subsection compare-slots }
"Sorting a sequence of tuples by a slot/comparator pairs:"
{ $subsection sort-by-slots }
"Sorting a sequence by a sequence of comparators:"
{ $subsection sort-by } ;
{ $subsection sort-by }
{ $subsection sort-keys-by }
{ $subsection sort-values-by } ;
ABOUT: "sorting.slots"

View File

@ -24,7 +24,7 @@ TUPLE: tuple2 d ;
T{ sort-test f 1 1 11 }
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
} { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots
} { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by
] unit-test
[
@ -42,43 +42,14 @@ TUPLE: tuple2 d ;
T{ sort-test f 1 1 11 }
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
} { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by-slots
} { { a>> human<=> } { b>> human>=< } { c>> <=> } } sort-by
] unit-test
[
{
{
T{ sort-test { a 1 } { b 1 } { c 10 } }
T{ sort-test { a 1 } { b 1 } { c 11 } }
}
{ T{ sort-test { a 1 } { b 3 } { c 9 } } }
{
T{ sort-test { a 2 } { b 5 } { c 3 } }
T{ sort-test { a 2 } { b 5 } { c 2 } }
}
}
] [
{
T{ sort-test f 1 3 9 }
T{ sort-test f 1 1 10 }
T{ sort-test f 1 1 11 }
T{ sort-test f 2 5 3 }
T{ sort-test f 2 5 2 }
}
{ { a>> human<=> } { b>> <=> } } [ sort-by-slots ] keep
[ but-last-slice ] map split-by-slots [ >array ] map
] unit-test
: split-test ( seq -- seq' )
{ { a>> } { b>> } } split-by-slots ;
[ split-test ] must-infer
[ { } ]
[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by ] unit-test
[ { } ]
[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
[ { } ]
[ { } { } sort-by-slots ] unit-test
[ { } { } sort-by ] unit-test
[
{
@ -97,55 +68,7 @@ TUPLE: tuple2 d ;
T{ sort-test f 6 f f T{ tuple2 f 3 } }
T{ sort-test f 5 f f T{ tuple2 f 3 } }
T{ sort-test f 6 f f T{ tuple2 f 2 } }
} { { tuple2>> d>> <=> } { a>> <=> } } sort-by-slots
] unit-test
[
{
{
T{ sort-test
{ a 6 }
{ tuple2 T{ tuple2 { d 1 } } }
}
}
{
T{ sort-test
{ a 6 }
{ tuple2 T{ tuple2 { d 2 } } }
}
}
{
T{ sort-test
{ a 5 }
{ tuple2 T{ tuple2 { d 3 } } }
}
}
{
T{ sort-test
{ a 6 }
{ tuple2 T{ tuple2 { d 3 } } }
}
T{ sort-test
{ a 6 }
{ tuple2 T{ tuple2 { d 3 } } }
}
}
{
T{ sort-test
{ a 5 }
{ tuple2 T{ tuple2 { d 4 } } }
}
}
}
] [
{
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 2 } } } }
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 3 } } } }
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 3 } } } }
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
} { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
} { { tuple2>> d>> <=> } { a>> <=> } } sort-by
] unit-test
@ -159,3 +82,15 @@ TUPLE: tuple2 d ;
{ { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
{ length-test<=> <=> } sort-by
] unit-test
[ { { 0 1 } { 1 2 } { 1 1 } { 3 2 } } ]
[
{ { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
{ length-test<=> <=> } sort-keys-by
] unit-test
[ { { 0 1 } { 1 1 } { 3 2 } { 1 2 } } ]
[
{ { 3 2 } { 1 2 } { 0 1 } { 1 1 } }
{ length-test<=> <=> } sort-values-by
] unit-test

View File

@ -1,45 +1,28 @@
! Copyright (C) 2009 Slava Pestov, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators.short-circuit fry kernel macros math.order
sequences words sorting sequences.deep assocs splitting.monotonic
math ;
USING: arrays fry kernel math.order sequences sorting ;
IN: sorting.slots
<PRIVATE
: execute-comparator ( obj1 obj2 word -- <=>/f )
execute( obj1 obj2 -- <=> ) dup +eq+ eq? [ drop f ] when ;
: short-circuit-comparator ( obj1 obj2 word -- comparator/? )
execute dup +eq+ eq? [ drop f ] when ; inline
: execute-accessor ( obj1 obj2 word -- obj1' obj2' )
'[ _ execute( tuple -- value ) ] bi@ ;
: slot-comparator ( seq -- quot )
[
but-last-slice
[ '[ [ _ execute ] bi@ ] ] map concat
] [
peek
'[ @ _ short-circuit-comparator ]
] bi ;
PRIVATE>
MACRO: compare-slots ( sort-specs -- <=> )
: compare-slots ( obj1 obj2 sort-specs -- <=> )
#! sort-spec: { accessors comparator }
[ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
[
dup array? [
unclip-last-slice
[ [ execute-accessor ] each ] dip
] when execute-comparator
] with with map-find drop +eq+ or ;
MACRO: sort-by-slots ( sort-specs -- quot )
'[ [ _ compare-slots ] sort ] ;
: sort-by-with ( seq sort-specs quot -- seq' )
swap '[ _ bi@ _ compare-slots ] sort ; inline
MACRO: compare-seq ( seq -- quot )
[ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
: sort-by ( seq sort-specs -- seq' ) [ ] sort-by-with ;
MACRO: sort-by ( sort-seq -- quot )
'[ [ _ compare-seq ] sort ] ;
: sort-keys-by ( seq sort-seq -- seq' ) [ first ] sort-by-with ;
MACRO: sort-keys-by ( sort-seq -- quot )
'[ [ first ] bi@ _ compare-seq ] sort ;
MACRO: sort-values-by ( sort-seq -- quot )
'[ [ second ] bi@ _ compare-seq ] sort ;
MACRO: split-by-slots ( accessor-seqs -- quot )
[ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
'[ [ _ 2&& ] slice monotonic-slice ] ;
: sort-values-by ( seq sort-seq -- seq' ) [ second ] sort-by-with ;

View File

@ -524,7 +524,7 @@ ERROR: custom-error ;
{ 2 1 } [ [ + ] inference-invalidation-b ] must-infer-as
[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" (( -- )) eval ] unit-test
[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- a b ) 1 2 ;" eval( -- ) ] unit-test
[ 3 ] [ inference-invalidation-c ] unit-test
@ -536,7 +536,7 @@ M: object inference-invalidation-d inference-invalidation-c 2drop ;
\ inference-invalidation-d must-infer
[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" (( -- )) eval ] unit-test
[ ] [ "IN: stack-checker.tests : inference-invalidation-a ( -- ) ;" eval( -- ) ] unit-test
[ [ inference-invalidation-d ] infer ] must-fail

View File

@ -18,7 +18,7 @@ M: integer some-generic 1+ ;
[ 4 ] [ 3 some-generic ] unit-test
[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" (( -- )) eval ] unit-test
[ ] [ "IN: tools.annotations.tests USE: math M: integer some-generic 1- ;" eval( -- ) ] unit-test
[ 2 ] [ 3 some-generic ] unit-test
@ -33,7 +33,7 @@ M: object another-generic ;
\ another-generic watch
[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" (( -- )) eval ] unit-test
[ ] [ "IN: tools.annotations.tests GENERIC: another-generic ( a -- b )" eval( -- ) ] unit-test
[ ] [ \ another-generic reset ] unit-test

View File

@ -3,20 +3,20 @@
USING: accessors kernel arrays sequences math namespaces
strings io fry vectors words assocs combinators sorting
unicode.case unicode.categories math.order vocabs
tools.vocabs unicode.data ;
tools.vocabs unicode.data locals ;
IN: tools.completion
: (fuzzy) ( accum ch i full -- accum i ? )
index-from
[
[ swap push ] 2keep 1+ t
:: (fuzzy) ( accum i full ch -- accum i full ? )
ch i full index-from [
:> i i accum push
accum i 1+ full t
] [
drop f -1 f
f -1 full f
] if* ;
: fuzzy ( full short -- indices )
dup length <vector> -rot 0 -rot
[ -rot [ (fuzzy) ] keep swap ] all? 3drop ;
dup [ length <vector> 0 ] curry 2dip
[ (fuzzy) ] all? 3drop ;
: (runs) ( runs n seq -- runs n )
[

View File

@ -357,7 +357,7 @@ IN: tools.deploy.shaker
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
[ save-image-and-exit ] call-clear ;
save-image-and-exit ;
SYMBOL: deploy-vocab
@ -421,10 +421,10 @@ SYMBOL: deploy-vocab
: deploy-error-handler ( quot -- )
[
strip-debugger?
[ error-continuation get call>> callstack>array die ]
[ error-continuation get call>> callstack>array die 1 exit ]
! Don't reference these words literally, if we're stripping the
! debugger out we don't want to load the prettyprinter at all
[ [:c] execute nl [print-error] execute flush ] if
[ [:c] execute( -- ) nl [print-error] execute( error -- ) flush ] if
1 exit
] recover ; inline

View File

@ -1,5 +1,35 @@
IN: tools.errors
USING: help.markup help.syntax source-files.errors ;
USING: help.markup help.syntax source-files.errors words io
compiler.errors ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"After loading a vocabulary, you might see messages like:"
{ $code
":errors - print 2 compiler errors"
":warnings - print 50 compiler warnings"
}
"These messages arise from the compiler's stack effect checker. Production code should not have any warnings and errors in it. Warning and error conditions are documented in " { $link "inference-errors" } "."
$nl
"Words to view warnings and errors:"
{ $subsection :warnings }
{ $subsection :errors }
{ $subsection :linkage }
"Compiler warnings and errors are reported using the " { $link "tools.errors" } " mechanism and are shown in the " { $link "ui.tools.error-list" } "." ;
HELP: compiler-error
{ $values { "error" "an error" } { "word" word } }
{ $description "Saves the error for future persual via " { $link :errors } ", " { $link :warnings } " and " { $link :linkage } "." } ;
HELP: :errors
{ $description "Prints all serious compiler errors from the most recent compile to " { $link output-stream } "." } ;
HELP: :warnings
{ $description "Prints all ignorable compiler warnings from the most recent compile to " { $link output-stream } "." } ;
HELP: :linkage
{ $description "Prints all C library interface linkage errors from the most recent compile to " { $link output-stream } "." } ;
{ :errors :warnings :linkage } related-words
HELP: errors.
{ $values { "errors" "a sequence of " { $link source-file-error } " instances" } }

View File

@ -1,35 +1,28 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs debugger io kernel sequences source-files.errors
summary accessors continuations make math.parser io.styles namespaces ;
summary accessors continuations make math.parser io.styles namespaces
compiler.errors ;
IN: tools.errors
#! Tools for source-files.errors. Used by tools.tests and others
#! for error reporting
M: source-file-error summary
error>> summary ;
M: source-file-error compute-restarts
error>> compute-restarts ;
M: source-file-error error-help
error>> error-help ;
M: source-file-error error.
M: source-file-error summary
[
[
[
[ file>> [ % ": " % ] when* ]
[ line#>> [ # "\n" % ] when* ] bi
] "" make
] [
[
presented set
bold font-style set
] H{ } make-assoc
] bi format
] [ error>> error. ] bi ;
[ file>> [ % ": " % ] [ "<Listener input>" % ] if* ]
[ line#>> [ # ] when* ] bi
] "" make
;
M: source-file-error error.
[ summary print nl ] [ error>> error. ] bi ;
: errors. ( errors -- )
group-by-source-file sort-errors
@ -38,3 +31,12 @@ M: source-file-error error.
[ [ nl ] [ error. ] interleave ]
bi*
] assoc-each ;
: compiler-errors. ( type -- )
errors-of-type values errors. ;
: :errors ( -- ) +compiler-error+ compiler-errors. ;
: :warnings ( -- ) +compiler-warning+ compiler-errors. ;
: :linkage ( -- ) +linkage-error+ compiler-errors. ;

View File

@ -75,7 +75,7 @@ M: object file-spec>string ( file-listing spec -- string )
: list-files-slow ( listing-tool -- array )
[ path>> ] [ sort>> ] [ specs>> ] tri '[
[ dup name>> file-info file-listing boa ] map
_ [ sort-by-slots ] when*
_ [ sort-by ] when*
[ _ [ file-spec>string ] with map ] map
] with-directory-entries ; inline

View File

@ -5,7 +5,8 @@ io.encodings.utf8 hashtables kernel namespaces sequences
vocabs.loader io combinators calendar accessors math.parser
io.streams.string ui.tools.operations quotations strings arrays
prettyprint words vocabs sorting sets classes math alien urls
splitting ascii combinators.short-circuit alarms words.symbol ;
splitting ascii combinators.short-circuit alarms words.symbol
system ;
IN: tools.scaffold
SYMBOL: developer-name
@ -24,6 +25,9 @@ ERROR: no-vocab vocab ;
: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
: ensure-vocab-exists ( string -- string )
dup vocabs member? [ no-vocab ] unless ;
: check-vocab-name ( string -- string )
[ ]
[ contains-dot? [ vocab-name-contains-dot ] when ]
@ -234,6 +238,7 @@ PRIVATE>
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
: scaffold-help ( vocab -- )
ensure-vocab-exists
[
dup "-docs.factor" vocab/suffix>path scaffolding? [
set-scaffold-docs-file
@ -268,6 +273,7 @@ PRIVATE>
PRIVATE>
: scaffold-tests ( vocab -- )
ensure-vocab-exists
dup "-tests.factor" vocab/suffix>path
scaffolding? [
set-scaffold-tests-file
@ -296,8 +302,10 @@ SYMBOL: examples-flag
[ home ] dip append-path
[ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ;
: scaffold-factor-boot-rc ( -- )
os windows? "factor-boot-rc" ".factor-boot-rc" ? scaffold-rc ;
: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ;
: scaffold-factor-rc ( -- )
os windows? "factor-rc" ".factor-rc" ? scaffold-rc ;
: scaffold-emacs ( -- ) ".emacs" scaffold-rc ;

View File

@ -129,13 +129,13 @@ TEST: must-infer
TEST: must-fail-with
TEST: must-fail
M: test-failure summary
asset>> [ [ experiment. ] with-string-writer ] [ "Top-level form" ] if* ;
M: test-failure error. ( error -- )
[ call-next-method ]
[ traceback-button. ]
bi ;
{
[ summary print nl ]
[ asset>> [ experiment. nl ] when* ]
[ error>> error. ]
[ traceback-button. ]
} cleave ;
: :test-failures ( -- ) test-failures get errors. ;

View File

@ -3,11 +3,11 @@
USING: accessors alien alien.c-types arrays ui ui.private ui.gadgets
ui.gadgets.private ui.gestures ui.backend ui.clipboards
ui.gadgets.worlds ui.render ui.event-loop assocs kernel math
namespaces opengl sequences strings x11.xlib x11.events x11.xim
x11.glx x11.clipboard x11.constants x11.windows io.encodings.string
io.encodings.ascii io.encodings.utf8 combinators command-line
math.vectors classes.tuple opengl.gl threads math.rectangles
environment ascii ;
namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
x11.glx x11.clipboard x11.constants x11.windows x11.io
io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
command-line math.vectors classes.tuple opengl.gl threads
math.rectangles environment ascii ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
@ -196,7 +196,7 @@ M: world client-event
QueuedAfterFlush events-queued 0 > [
next-event dup
None XFilterEvent 0 = [ drop wait-event ] unless
] [ ui-wait wait-event ] if ;
] [ wait-for-display wait-event ] if ;
M: x11-ui-backend do-events
wait-event dup XAnyEvent-window window dup

View File

@ -3,7 +3,7 @@
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
concurrency.flags math.order math.rectangles fry ;
concurrency.flags math.order math.rectangles fry locals ;
IN: ui.gadgets
! Values for orientation slot
@ -66,8 +66,8 @@ M: gadget children-on nip children>> ;
: ((fast-children-on)) ( gadget dim axis -- <=> )
[ swap loc>> v- ] dip v. 0 <=> ;
: (fast-children-on) ( dim axis children -- i )
-rot '[ _ _ ((fast-children-on)) ] search drop ;
:: (fast-children-on) ( dim axis children -- i )
children [ dim axis ((fast-children-on)) ] search drop ;
PRIVATE>

View File

@ -27,7 +27,7 @@ INSTANCE: fake-break word-break
[ { 0 0 } ] [ "a" get loc>> ] unit-test
[ { 45 15 } ] [ "b" get loc>> ] unit-test
[ { 45 7 } ] [ "b" get loc>> ] unit-test
[ { 0 30 } ] [ "c" get loc>> ] unit-test

View File

@ -46,7 +46,7 @@ HELP: offset>x
HELP: line-metrics
{ $values { "font" font } { "string" string } { "metrics" line-metrics } }
{ $contract "Outputs a " { $link line-metrics } " object with text measurements." } ;
{ $contract "Outputs a " { $link metrics } " object with text measurements." } ;
ARTICLE: "text-rendering" "Rendering text"
"The " { $vocab-link "ui.text" } " vocabulary provides a cross-platform interface to the operating system's native font rendering engine. Currently, it uses Core Text on Mac OS X and FreeType on Windows and X11."

View File

@ -26,7 +26,7 @@ MEMO: error-icon ( type -- image-name )
: <error-toggle> ( -- model gadget )
#! Linkage errors are not shown by default.
error-types get keys [ dup +linkage-error+ eq? not <model> ] { } map>assoc
error-types get [ fatal?>> <model> ] assoc-map
[ [ [ error-icon ] dip ] assoc-map <checkboxes> ]
[ <mapping> ] bi ;
@ -80,7 +80,7 @@ M: error-renderer row-columns
{
[ error-type error-icon ]
[ line#>> [ number>string ] [ "" ] if* ]
[ asset>> unparse-short ]
[ asset>> [ unparse-short ] [ "" ] if* ]
[ error>> summary ]
} cleave
] output>array ;

View File

@ -358,9 +358,8 @@ interactor "completion" f {
} define-command-map
: ui-error-summary ( -- )
all-errors [
[ error-type ] map prune
[ error-icon-path 1array \ $image prefix " " 2array ] { } map-as
error-counts keys [
[ icon>> 1array \ $image prefix " " 2array ] { } map-as
{ "Press " { $command tool "common" show-error-list } " to view errors." }
append print-element nl
] unless-empty ;

View File

@ -7,7 +7,11 @@ HELP: url-decode
HELP: url-encode
{ $values { "str" string } { "encoded" string } }
{ $description "URL-encodes a string." } ;
{ $description "URL-encodes a string, excluding certain characters, such as \"/\"." } ;
HELP: url-encode-full
{ $values { "str" string } { "encoded" string } }
{ $description "URL-encodes a string, including all reserved characters, such as \"/\"." } ;
HELP: url-quotable?
{ $values { "ch" "a character" } { "?" "a boolean" } }

View File

@ -14,6 +14,25 @@ IN: urls.encoding
[ "/_-.:" member? ]
} 1|| ; foldable
! see http://tools.ietf.org/html/rfc3986#section-2.2
: gen-delim? ( ch -- ? )
":/?#[]@" member? ; foldable
: sub-delim? ( ch -- ? )
"!$&'()*+,;=" member? ; foldable
: reserved? ( ch -- ? )
[ gen-delim? ] [ sub-delim? ] bi or ; foldable
! see http://tools.ietf.org/html/rfc3986#section-2.3
: unreserved? ( ch -- ? )
{
[ letter? ]
[ LETTER? ]
[ digit? ]
[ "-._~" member? ]
} 1|| ; foldable
<PRIVATE
: push-utf8 ( ch -- )
@ -27,6 +46,11 @@ PRIVATE>
[ dup url-quotable? [ , ] [ push-utf8 ] if ] each
] "" make ;
: url-encode-full ( str -- encoded )
[
[ dup unreserved? [ , ] [ push-utf8 ] if ] each
] "" make ;
<PRIVATE
: url-decode-hex ( index str -- )

View File

@ -1,5 +1,6 @@
USING: alien.syntax kernel math windows.types math.bitwise ;
IN: windows.advapi32
LIBRARY: advapi32
CONSTANT: PROV_RSA_FULL 1
@ -122,6 +123,34 @@ C-STRUCT: ACCESS_ALLOWED_CALLBACK_ACE
TYPEDEF: ACCESS_ALLOWED_CALLBACK_ACE* PACCESS_ALLOWED_CALLBACK_ACE
C-STRUCT: SECURITY_DESCRIPTOR
{ "UCHAR" "Revision" }
{ "UCHAR" "Sbz1" }
{ "WORD" "Control" }
{ "PVOID" "Owner" }
{ "PVOID" "Group" }
{ "PACL" "Sacl" }
{ "PACL" "Dacl" } ;
TYPEDEF: SECURITY_DESCRIPTOR* PSECURITY_DESCRIPTOR
CONSTANT: SE_OWNER_DEFAULTED 1
CONSTANT: SE_GROUP_DEFAULTED 2
CONSTANT: SE_DACL_PRESENT 4
CONSTANT: SE_DACL_DEFAULTED 8
CONSTANT: SE_SACL_PRESENT 16
CONSTANT: SE_SACL_DEFAULTED 32
CONSTANT: SE_DACL_AUTO_INHERIT_REQ 256
CONSTANT: SE_SACL_AUTO_INHERIT_REQ 512
CONSTANT: SE_DACL_AUTO_INHERITED 1024
CONSTANT: SE_SACL_AUTO_INHERITED 2048
CONSTANT: SE_DACL_PROTECTED 4096
CONSTANT: SE_SACL_PROTECTED 8192
CONSTANT: SE_SELF_RELATIVE 32768
TYPEDEF: DWORD SECURITY_DESCRIPTOR_CONTROL
TYPEDEF: SECURITY_DESCRIPTOR_CONTROL* PSECURITY_DESCRIPTOR_CONTROL
! typedef enum _TOKEN_INFORMATION_CLASS {
CONSTANT: TokenUser 1
@ -141,6 +170,140 @@ CONSTANT: TokenSessionReference 14
CONSTANT: TokenSandBoxInert 15
! } TOKEN_INFORMATION_CLASS;
TYPEDEF: DWORD ACCESS_MODE
C-ENUM:
NOT_USED_ACCESS
GRANT_ACCESS
SET_ACCESS
DENY_ACCESS
REVOKE_ACCESS
SET_AUDIT_SUCCESS
SET_AUDIT_FAILURE ;
TYPEDEF: DWORD MULTIPLE_TRUSTEE_OPERATION
C-ENUM:
NO_MULTIPLE_TRUSTEE
TRUSTEE_IS_IMPERSONATE ;
TYPEDEF: DWORD TRUSTEE_FORM
C-ENUM:
TRUSTEE_IS_SID
TRUSTEE_IS_NAME
TRUSTEE_BAD_FORM
TRUSTEE_IS_OBJECTS_AND_SID
TRUSTEE_IS_OBJECTS_AND_NAME ;
TYPEDEF: DWORD TRUSTEE_TYPE
C-ENUM:
TRUSTEE_IS_UNKNOWN
TRUSTEE_IS_USER
TRUSTEE_IS_GROUP
TRUSTEE_IS_DOMAIN
TRUSTEE_IS_ALIAS
TRUSTEE_IS_WELL_KNOWN_GROUP
TRUSTEE_IS_DELETED
TRUSTEE_IS_INVALID
TRUSTEE_IS_COMPUTER ;
TYPEDEF: DWORD SE_OBJECT_TYPE
C-ENUM:
SE_UNKNOWN_OBJECT_TYPE
SE_FILE_OBJECT
SE_SERVICE
SE_PRINTER
SE_REGISTRY_KEY
SE_LMSHARE
SE_KERNEL_OBJECT
SE_WINDOW_OBJECT
SE_DS_OBJECT
SE_DS_OBJECT_ALL
SE_PROVIDER_DEFINED_OBJECT
SE_WMIGUID_OBJECT
SE_REGISTRY_WOW64_32KEY ;
TYPEDEF: TRUSTEE* PTRUSTEE
C-STRUCT: TRUSTEE
{ "PTRUSTEE" "pMultipleTrustee" }
{ "MULTIPLE_TRUSTEE_OPERATION" "MultipleTrusteeOperation" }
{ "TRUSTEE_FORM" "TrusteeForm" }
{ "TRUSTEE_TYPE" "TrusteeType" }
{ "LPTSTR" "ptstrName" } ;
C-STRUCT: EXPLICIT_ACCESS
{ "DWORD" "grfAccessPermissions" }
{ "ACCESS_MODE" "grfAccessMode" }
{ "DWORD" "grfInheritance" }
{ "TRUSTEE" "Trustee" } ;
C-STRUCT: SID_IDENTIFIER_AUTHORITY
{ { "BYTE" 6 } "Value" } ;
TYPEDEF: SID_IDENTIFIER_AUTHORITY* PSID_IDENTIFIER_AUTHORITY
CONSTANT: SECURITY_NULL_SID_AUTHORITY 0
CONSTANT: SECURITY_WORLD_SID_AUTHORITY 1
CONSTANT: SECURITY_LOCAL_SID_AUTHORITY 2
CONSTANT: SECURITY_CREATOR_SID_AUTHORITY 3
CONSTANT: SECURITY_NON_UNIQUE_AUTHORITY 4
CONSTANT: SECURITY_NT_AUTHORITY 5
CONSTANT: SECURITY_RESOURCE_MANAGER_AUTHORITY 6
CONSTANT: SECURITY_NULL_RID 0
CONSTANT: SECURITY_WORLD_RID 0
CONSTANT: SECURITY_LOCAL_RID 0
CONSTANT: SECURITY_CREATOR_OWNER_RID 0
CONSTANT: SECURITY_CREATOR_GROUP_RID 1
CONSTANT: SECURITY_CREATOR_OWNER_SERVER_RID 2
CONSTANT: SECURITY_CREATOR_GROUP_SERVER_RID 3
CONSTANT: SECURITY_DIALUP_RID 1
CONSTANT: SECURITY_NETWORK_RID 2
CONSTANT: SECURITY_BATCH_RID 3
CONSTANT: SECURITY_INTERACTIVE_RID 4
CONSTANT: SECURITY_SERVICE_RID 6
CONSTANT: SECURITY_ANONYMOUS_LOGON_RID 7
CONSTANT: SECURITY_PROXY_RID 8
CONSTANT: SECURITY_SERVER_LOGON_RID 9
CONSTANT: SECURITY_PRINCIPAL_SELF_RID 10
CONSTANT: SECURITY_AUTHENTICATED_USER_RID 11
CONSTANT: SECURITY_LOGON_IDS_RID 5
CONSTANT: SECURITY_LOGON_IDS_RID_COUNT 3
CONSTANT: SECURITY_LOCAL_SYSTEM_RID 18
CONSTANT: SECURITY_NT_NON_UNIQUE 21
CONSTANT: SECURITY_BUILTIN_DOMAIN_RID 32
CONSTANT: DOMAIN_USER_RID_ADMIN 500
CONSTANT: DOMAIN_USER_RID_GUEST 501
CONSTANT: DOMAIN_GROUP_RID_ADMINS 512
CONSTANT: DOMAIN_GROUP_RID_USERS 513
CONSTANT: DOMAIN_GROUP_RID_GUESTS 514
CONSTANT: DOMAIN_ALIAS_RID_ADMINS 544
CONSTANT: DOMAIN_ALIAS_RID_USERS 545
CONSTANT: DOMAIN_ALIAS_RID_GUESTS 546
CONSTANT: DOMAIN_ALIAS_RID_POWER_USERS 547
CONSTANT: DOMAIN_ALIAS_RID_ACCOUNT_OPS 548
CONSTANT: DOMAIN_ALIAS_RID_SYSTEM_OPS 549
CONSTANT: DOMAIN_ALIAS_RID_PRINT_OPS 550
CONSTANT: DOMAIN_ALIAS_RID_BACKUP_OPS 551
CONSTANT: DOMAIN_ALIAS_RID_REPLICATOR 552
CONSTANT: SE_GROUP_MANDATORY 1
CONSTANT: SE_GROUP_ENABLED_BY_DEFAULT 2
CONSTANT: SE_GROUP_ENABLED 4
CONSTANT: SE_GROUP_OWNER 8
CONSTANT: SE_GROUP_LOGON_ID -1073741824
! SID is a variable length structure
TYPEDEF: void* PSID
TYPEDEF: EXPLICIT_ACCESS* PEXPLICIT_ACCESS
TYPEDEF: DWORD SECURITY_INFORMATION
TYPEDEF: SECURITY_INFORMATION* PSECURITY_INFORMATION
CONSTANT: OWNER_SECURITY_INFORMATION 1
CONSTANT: GROUP_SECURITY_INFORMATION 2
CONSTANT: DACL_SECURITY_INFORMATION 4
CONSTANT: SACL_SECURITY_INFORMATION 8
CONSTANT: DELETE HEX: 00010000
CONSTANT: READ_CONTROL HEX: 00020000
CONSTANT: WRITE_DAC HEX: 00040000
@ -187,6 +350,34 @@ CONSTANT: TOKEN_ADJUST_DEFAULT HEX: 0080
TOKEN_ADJUST_DEFAULT
} flags ; foldable
CONSTANT: HKEY_CLASSES_ROOT 1
CONSTANT: HKEY_CURRENT_CONFIG 2
CONSTANT: HKEY_CURRENT_USER 3
CONSTANT: HKEY_LOCAL_MACHINE 4
CONSTANT: HKEY_USERS 5
CONSTANT: KEY_ALL_ACCESS HEX: 0001
CONSTANT: KEY_CREATE_LINK HEX: 0002
CONSTANT: KEY_CREATE_SUB_KEY HEX: 0004
CONSTANT: KEY_ENUMERATE_SUB_KEYS HEX: 0008
CONSTANT: KEY_EXECUTE HEX: 0010
CONSTANT: KEY_NOTIFY HEX: 0020
CONSTANT: KEY_QUERY_VALUE HEX: 0040
CONSTANT: KEY_READ HEX: 0080
CONSTANT: KEY_SET_VALUE HEX: 0100
CONSTANT: KEY_WOW64_64KEY HEX: 0200
CONSTANT: KEY_WOW64_32KEY HEX: 0400
CONSTANT: KEY_WRITE HEX: 0800
CONSTANT: REG_BINARY 1
CONSTANT: REG_DWORD 2
CONSTANT: REG_EXPAND_SZ 3
CONSTANT: REG_MULTI_SZ 4
CONSTANT: REG_QWORD 5
CONSTANT: REG_SZ 6
TYPEDEF: DWORD REGSAM
! : I_ScGetCurrentGroupStateW ;
! : A_SHAFinal ;
@ -224,7 +415,19 @@ FUNCTION: BOOL AdjustTokenPrivileges ( HANDLE TokenHandle,
PTOKEN_PRIVILEGES PreviousState,
PDWORD ReturnLength ) ;
! : AllocateAndInitializeSid ;
FUNCTION: BOOL AllocateAndInitializeSid (
PSID_IDENTIFIER_AUTHORITY pIdentifierAuthority,
BYTE nSubAuthorityCount,
DWORD dwSubAuthority0,
DWORD dwSubAuthority1,
DWORD dwSubAuthority2,
DWORD dwSubAuthority3,
DWORD dwSubAuthority4,
DWORD dwSubAuthority5,
DWORD dwSubAuthority6,
DWORD dwSubAuthority7,
PSID* pSid ) ;
! : AllocateLocallyUniqueId ;
! : AreAllAccessesGranted ;
! : AreAnyAccessesGranted ;
@ -442,7 +645,8 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
! : GetExplicitEntriesFromAclA ;
! : GetExplicitEntriesFromAclW ;
! : GetFileSecurityA ;
! : GetFileSecurityW ;
FUNCTION: BOOL GetFileSecurityW ( LPCTSTR lpFileName, SECURITY_INFORMATION RequestedInformation, PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD nLength, LPDWORD lpnLengthNeeded ) ;
ALIAS: GetFileSecurity GetFileSecurityW
! : GetInformationCodeAuthzLevelW ;
! : GetInformationCodeAuthzPolicyW ;
! : GetInheritanceSourceA ;
@ -459,19 +663,20 @@ FUNCTION: BOOL CryptReleaseContext ( HCRYPTPROV hProv, DWORD dwFlags ) ;
! : GetMultipleTrusteeW ;
! : GetNamedSecurityInfoA ;
! : GetNamedSecurityInfoExA ;
! : GetNamedSecurityInfoExW ;
! : GetNamedSecurityInfoW ;
! FUNCTION: DWORD GetNamedSecurityInfoExW
FUNCTION: DWORD GetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID* ppsidOwner, PSID* ppsidGroup, PACL* ppDacl, PACL* ppSacl, PSECURITY_DESCRIPTOR* ppSecurityDescriptor ) ;
ALIAS: GetNamedSecurityInfo GetNamedSecurityInfoW
! : GetNumberOfEventLogRecords ;
! : GetOldestEventLogRecord ;
! : GetOverlappedAccessResults ;
! : GetPrivateObjectSecurity ;
! : GetSecurityDescriptorControl ;
! : GetSecurityDescriptorDacl ;
! : GetSecurityDescriptorGroup ;
! : GetSecurityDescriptorLength ;
! : GetSecurityDescriptorOwner ;
! : GetSecurityDescriptorRMControl ;
! : GetSecurityDescriptorSacl ;
FUNCTION: BOOL GetSecurityDescriptorControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSECURITY_DESCRIPTOR_CONTROL pControl, LPDWORD lpdwRevision ) ;
FUNCTION: BOOL GetSecurityDescriptorDacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbDaclPresent, PACL* pDacl, LPBOOL lpDaclDefaulted ) ;
FUNCTION: BOOL GetSecurityDescriptorGroup ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pGroup, LPBOOL lpGroupDefaulted ) ;
FUNCTION: BOOL GetSecurityDescriptorLength ( PSECURITY_DESCRIPTOR pSecurityDescriptor ) ;
FUNCTION: BOOL GetSecurityDescriptorOwner ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PSID* pOwner, LPBOOL lpOwnerDefaulted ) ;
FUNCTION: BOOL GetSecurityDescriptorRMControl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, PUCHAR RMControl ) ;
FUNCTION: BOOL GetSecurityDescriptorSacl ( PSECURITY_DESCRIPTOR pSecurityDescriptor, LPBOOL lpbSaclPresent, PACL* pSacl, LPBOOL lpSaclDefaulted ) ;
! : GetSecurityInfo ;
! : GetSecurityInfoExA ;
! : GetSecurityInfoExW ;
@ -510,7 +715,7 @@ ALIAS: GetUserName GetUserNameW
! : ImpersonateNamedPipeClient ;
! : ImpersonateSelf ;
FUNCTION: BOOL InitializeAcl ( PACL pAcl, DWORD nAclLength, DWORD dwAclRevision ) ;
! : InitializeSecurityDescriptor ;
FUNCTION: BOOL InitializeSecurityDescriptor ( PSECURITY_DESCRIPTOR pSecurityDescriptor, DWORD dwRevision ) ;
! : InitializeSid ;
! : InitiateSystemShutdownA ;
! : InitiateSystemShutdownExA ;
@ -674,8 +879,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : RegConnectRegistryW ;
! : RegCreateKeyA ;
! : RegCreateKeyExA ;
! : RegCreateKeyExW ;
! : RegCreateKeyW ;
FUNCTION: LONG RegCreateKeyExW ( HKEY hKey, LPCTSTR lpSubKey, DWORD Reserved, LPTSTR lpClass, DWORD dwOptions, REGSAM samDesired, LPSECURITY_ATTRIBUTES lpSecurityAttributes, PHKEY phkResult, LPDWORD lpdwDisposition ) ;
! : RegCreateKeyW
! : RegDeleteKeyA ;
! : RegDeleteKeyW ;
! : RegDeleteValueA ;
@ -692,7 +897,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : RegLoadKeyA ;
! : RegLoadKeyW ;
! : RegNotifyChangeKeyValue ;
! : RegOpenCurrentUser ;
FUNCTION: LONG RegOpenCurrentUser ( REGSAM samDesired, PHKEY phkResult ) ;
! : RegOpenKeyA ;
! : RegOpenKeyExA ;
! : RegOpenKeyExW ;
@ -705,7 +910,7 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : RegQueryMultipleValuesW ;
! : RegQueryValueA ;
! : RegQueryValueExA ;
! : RegQueryValueExW ;
FUNCTION: LONG RegQueryValueExW ( HKEY hKey, LPCTSTR lpValueName, LPWORD lpReserved, LPDWORD lpType, LPBYTE lpData, LPDWORD lpcbData ) ;
! : RegQueryValueW ;
! : RegReplaceKeyA ;
! : RegReplaceKeyW ;
@ -756,7 +961,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : SetEntriesInAccessListA ;
! : SetEntriesInAccessListW ;
! : SetEntriesInAclA ;
! : SetEntriesInAclW ;
FUNCTION: DWORD SetEntriesInAclW ( ULONG cCountOfExplicitEntries, PEXPLICIT_ACCESS pListOfExplicitEntries, PACL OldAcl, PACL* NewAcl ) ;
ALIAS: SetEntriesInAcl SetEntriesInAclW
! : SetEntriesInAuditListA ;
! : SetEntriesInAuditListW ;
! : SetFileSecurityA ;
@ -767,7 +973,8 @@ FUNCTION: BOOL OpenThreadToken ( HANDLE ThreadHandle, DWORD DesiredAccess, BOOL
! : SetNamedSecurityInfoA ;
! : SetNamedSecurityInfoExA ;
! : SetNamedSecurityInfoExW ;
! : SetNamedSecurityInfoW ;
FUNCTION: DWORD SetNamedSecurityInfoW ( LPTSTR pObjectName, SE_OBJECT_TYPE ObjectType, SECURITY_INFORMATION SecurityInfo, PSID psidOwner, PSID psidGroup, PACL pDacl, PACL pSacl ) ;
ALIAS: SetNamedSecurityInfo SetNamedSecurityInfoW
! : SetPrivateObjectSecurity ;
! : SetPrivateObjectSecurityEx ;
! : SetSecurityDescriptorControl ;

View File

@ -0,0 +1,5 @@
IN: windows.dinput.constants.tests
USING: tools.test windows.dinput.constants.private ;
[ ] [ define-constants ] unit-test
[ ] [ free-dinput-constants ] unit-test

View File

@ -27,12 +27,12 @@ SYMBOLS:
: (flag) ( thing -- integer )
{
{ [ dup word? ] [ execute ] }
{ [ dup callable? ] [ call ] }
{ [ dup word? ] [ execute( -- value ) ] }
{ [ dup callable? ] [ call( -- value ) ] }
[ ]
} cond ;
: (flags) ( array -- )
: (flags) ( array -- n )
0 [ (flag) bitor ] reduce ;
: (DIOBJECTDATAFORMAT) ( pguid dwOfs dwType dwFlags alien -- alien )
@ -63,14 +63,16 @@ SYMBOLS:
] ;
: (DIDATAFORMAT) ( dwSize dwObjSize dwFlags dwDataSize dwNumObjs rgodf alien -- alien )
[ {
[ set-DIDATAFORMAT-rgodf ]
[ set-DIDATAFORMAT-dwNumObjs ]
[ set-DIDATAFORMAT-dwDataSize ]
[ set-DIDATAFORMAT-dwFlags ]
[ set-DIDATAFORMAT-dwObjSize ]
[ set-DIDATAFORMAT-dwSize ]
} cleave ] keep ;
[
{
[ set-DIDATAFORMAT-rgodf ]
[ set-DIDATAFORMAT-dwNumObjs ]
[ set-DIDATAFORMAT-dwDataSize ]
[ set-DIDATAFORMAT-dwFlags ]
[ set-DIDATAFORMAT-dwObjSize ]
[ set-DIDATAFORMAT-dwSize ]
} cleave
] keep ;
: <DIDATAFORMAT> ( dwFlags dwDataSize struct rgodf-array -- alien )
[ "DIDATAFORMAT" heap-size "DIOBJECTDATAFORMAT" heap-size ] 4 ndip
@ -78,9 +80,10 @@ SYMBOLS:
"DIDATAFORMAT" <c-object> (DIDATAFORMAT) ;
: (malloc-guid-symbol) ( symbol guid -- )
global swap '[ [
_ execute [ byte-length malloc ] [ over byte-array>memory ] bi
] unless* ] change-at ;
'[
_ execute( -- value )
[ byte-length malloc ] [ over byte-array>memory ] bi
] initialize ;
: define-guid-constants ( -- )
{
@ -105,7 +108,7 @@ SYMBOLS:
} [ first2 (malloc-guid-symbol) ] each ;
: define-joystick-format-constant ( -- )
c_dfDIJoystick2 global [ [
c_dfDIJoystick2 [
DIDF_ABSAXIS
"DIJOYSTATE2" heap-size
"DIJOYSTATE2" {
@ -274,10 +277,10 @@ SYMBOLS:
{ GUID_Slider_malloced "rglFSlider" 0 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE }
{ GUID_Slider_malloced "rglFSlider" 1 { DIDFT_OPTIONAL DIDFT_AXIS DIDFT_ANYINSTANCE } DIDOI_ASPECTFORCE }
} <DIDATAFORMAT>
] unless* ] change-at ;
] initialize ;
: define-mouse-format-constant ( -- )
c_dfDIMouse2 global [ [
c_dfDIMouse2 [
DIDF_RELAXIS
"DIMOUSESTATE2" heap-size
"DIMOUSESTATE2" {
@ -293,13 +296,13 @@ SYMBOLS:
{ GUID_Button_malloced "rgbButtons" 6 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 }
{ GUID_Button_malloced "rgbButtons" 7 { DIDFT_OPTIONAL DIDFT_ANYINSTANCE DIDFT_BUTTON } 0 }
} <DIDATAFORMAT>
] unless* ] change-at ;
] initialize ;
! Not a standard DirectInput format. Included for cross-platform niceness.
! This format returns the keyboard keys in USB HID order rather than Windows
! order
: define-hid-keyboard-format-constant ( -- )
c_dfDIKeyboard_HID global [ [
c_dfDIKeyboard_HID [
DIDF_RELAXIS
256
f {
@ -560,10 +563,10 @@ SYMBOLS:
{ GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 }
{ GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 0 DIDFT_MAKEINSTANCE ] } 0 }
} <DIDATAFORMAT>
] unless* ] change-at ;
] initialize ;
: define-keyboard-format-constant ( -- )
c_dfDIKeyboard global [ [
c_dfDIKeyboard [
DIDF_RELAXIS
256
f {
@ -824,7 +827,7 @@ SYMBOLS:
{ GUID_Key_malloced f 254 { DIDFT_OPTIONAL DIDFT_BUTTON [ 254 DIDFT_MAKEINSTANCE ] } 0 }
{ GUID_Key_malloced f 255 { DIDFT_OPTIONAL DIDFT_BUTTON [ 255 DIDFT_MAKEINSTANCE ] } 0 }
} <DIDATAFORMAT>
] unless* ] change-at ;
] initialize ;
: define-format-constants ( -- )
define-joystick-format-constant
@ -837,7 +840,9 @@ SYMBOLS:
define-format-constants ;
[ define-constants ] "windows.dinput.constants" add-init-hook
define-constants
: uninitialize ( variable quot -- )
[ global ] dip '[ _ when* f ] change-at ; inline
: free-dinput-constants ( -- )
{
@ -846,10 +851,11 @@ define-constants
GUID_Slider_malloced GUID_Button_malloced GUID_Key_malloced GUID_POV_malloced GUID_Unknown_malloced
GUID_SysMouse_malloced GUID_SysKeyboard_malloced GUID_Joystick_malloced GUID_SysMouseEm_malloced
GUID_SysMouseEm2_malloced GUID_SysKeyboardEm_malloced GUID_SysKeyboardEm2_malloced
} [ global [ [ free ] when* f ] change-at ] each
} [ [ free ] uninitialize ] each
{
c_dfDIKeyboard c_dfDIKeyboard_HID c_dfDIMouse2 c_dfDIJoystick2
} [ global [ [ DIDATAFORMAT-rgodf free ] when* f ] change-at ] each ;
} [ [ DIDATAFORMAT-rgodf free ] uninitialize ] each ;
PRIVATE>

View File

@ -1501,7 +1501,6 @@ DESTRUCTOR: DeleteObject
FUNCTION: BOOL ExtTextOutW ( HDC hdc, int X, int Y, UINT fuOptions, RECT* lprc, LPCTSTR lpString, UINT cbCount, INT* lpDx ) ;
ALIAS: ExtTextOut ExtTextOutW
! FUNCTION: FillPath
FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
! FUNCTION: FillRgn
! FUNCTION: FixBrushOrgEx
! FUNCTION: FlattenPath

View File

@ -1477,7 +1477,7 @@ ALIAS: LoadLibraryEx LoadLibraryExW
! FUNCTION: LoadLibraryW
! FUNCTION: LoadModule
! FUNCTION: LoadResource
! FUNCTION: LocalAlloc
FUNCTION: HLOCAL LocalAlloc ( UINT uFlags, SIZE_T uBytes ) ;
! FUNCTION: LocalCompact
! FUNCTION: LocalFileTimeToFileTime
! FUNCTION: LocalFlags

View File

@ -807,7 +807,7 @@ FUNCTION: UINT EnumClipboardFormats ( UINT format ) ;
! FUNCTION: EqualRect
! FUNCTION: ExcludeUpdateRgn
! FUNCTION: ExitWindowsEx
! FUNCTION: FillRect
FUNCTION: int FillRect ( HDC hDC, RECT* lprc, HBRUSH hbr ) ;
FUNCTION: HWND FindWindowA ( char* lpClassName, char* lpWindowName ) ;
FUNCTION: HWND FindWindowExA ( HWND hwndParent, HWND childAfter, char* lpClassName, char* lpWindowName ) ;
! FUNCTION: FindWindowExW

Some files were not shown because too many files have changed in this diff Show More