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

db4
Bruno Deferrari 2008-11-18 22:40:46 -02:00
commit 94a81a50c5
243 changed files with 2440 additions and 928 deletions

View File

@ -164,7 +164,7 @@ GENERIC: stack-size ( type -- size ) foldable
M: string stack-size c-type stack-size ;
M: c-type stack-size size>> ;
M: c-type stack-size size>> cell align ;
GENERIC: byte-length ( seq -- n ) flushable
@ -436,6 +436,6 @@ M: long-long-type box-return ( type -- )
"double" define-primitive-type
"long" "ptrdiff_t" typedef
"long" "intptr_t" typedef
"ulong" "size_t" typedef
] with-compilation-unit

View File

@ -1,14 +1,10 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc
math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture ;
IN: alien.structs
: if-value-structs? ( ctype true false -- )
value-structs?
[ drop call ] [ >r 2drop "void*" r> call ] if ; inline
TUPLE: struct-type size align fields ;
M: struct-type heap-size size>> ;
@ -17,20 +13,26 @@ M: struct-type c-type-align align>> ;
M: struct-type c-type-stack-align? drop f ;
M: struct-type unbox-parameter
[ %unbox-struct ] [ unbox-parameter ] if-value-structs? ;
: if-value-struct ( ctype true false -- )
[ dup value-struct? ] 2dip '[ drop "void*" @ ] if ; inline
M: struct-type unbox-return
f swap %unbox-struct ;
M: struct-type unbox-parameter
[ %unbox-large-struct ] [ unbox-parameter ] if-value-struct ;
M: struct-type box-parameter
[ %box-struct ] [ box-parameter ] if-value-structs? ;
[ %box-large-struct ] [ box-parameter ] if-value-struct ;
: if-small-struct ( c-type true false -- ? )
[ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
M: struct-type unbox-return
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
M: struct-type box-return
f swap %box-struct ;
[ %box-small-struct ] [ %box-large-struct ] if-small-struct ;
M: struct-type stack-size
[ heap-size ] [ stack-size ] if-value-structs? ;
[ heap-size ] [ stack-size ] if-value-struct ;
: c-struct? ( type -- ? ) (c-type) struct-type? ;
@ -40,7 +42,7 @@ M: struct-type stack-size
-rot define-c-type ;
: define-struct-early ( name vocab fields -- fields )
-rot [ rot first2 <field-spec> ] 2curry map ;
[ first2 <field-spec> ] with with map ;
: compute-struct-align ( types -- n )
[ c-type-align ] map supremum ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: http.client checksums checksums.openssl splitting assocs
USING: http.client checksums checksums.md5 splitting assocs
kernel io.files bootstrap.image sequences io urls ;
IN: bootstrap.image.download
@ -13,7 +13,7 @@ IN: bootstrap.image.download
: need-new-image? ( image -- ? )
dup exists?
[
[ openssl-md5 checksum-file hex-string ]
[ md5 checksum-file hex-string ]
[ download-checksums at ]
bi = not
] [ drop t ] if ;

1
basis/calendar/windows/tags.txt Normal file → Executable file
View File

@ -1,2 +1 @@
unportable
windows

View File

@ -2,10 +2,10 @@ USING: help.markup help.syntax parser vocabs.loader strings ;
IN: command-line
HELP: run-bootstrap-init
{ $description "Runs the " { $snippet ".factor-boot-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
{ $description "Runs the bootstrap initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-boot-rc" } " on Unix and " { $snippet "factor-boot-rc" } " on Windows." } ;
HELP: run-user-init
{ $description "Runs the " { $snippet ".factor-rc" } " file in the user's home directory unless the " { $snippet "-no-user-init" } " command line switch was given." } ;
{ $description "Runs the startup initialization file in the user's home directory, unless the " { $snippet "-no-user-init" } " command line switch was given. This file is named " { $snippet ".factor-rc" } " on Unix and " { $snippet "factor-rc" } " on Windows." } ;
HELP: cli-param
{ $values { "param" string } }
@ -57,7 +57,7 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"A number of command line switches can be passed to a bootstrap image to modify the behavior of the resulting image:"
{ $table
{ { $snippet "-output-image=" { $emphasis "image" } } { "Save the result to " { $snippet "image" } ". The default is " { $snippet "factor.image" } "." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-boot-rc" } " file in the user's home directory." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-include=" { $emphasis "components..." } } "A list of components to include (see below)." }
{ { $snippet "-exclude=" { $emphasis "components..." } } "A list of components to exclude." }
{ { $snippet "-ui-backend=" { $emphasis "backend" } } { "One of " { $snippet "x11" } ", " { $snippet "windows" } ", or " { $snippet "cocoa" } ". The default is platform-specific." } }
@ -74,9 +74,9 @@ ARTICLE: "bootstrap-cli-args" "Command line switches for bootstrap"
"By default, all optional components are loaded. To load all optional components except for a given list, use the " { $snippet "-exclude=" } " switch; to only load specified optional components, use the " { $snippet "-include=" } "."
$nl
"For example, to build an image with the compiler but no other components, you could do:"
{ $code "./factor -i=boot.ppc.image -include=compiler" }
{ $code "./factor -i=boot.macosx-ppc.image -include=compiler" }
"To build an image with everything except for the user interface and graphical tools,"
{ $code "./factor -i=boot.ppc.image -exclude=\"ui ui.tools\"" }
{ $code "./factor -i=boot.macosx-ppc.image -exclude=\"ui ui.tools\"" }
"To generate a bootstrap image in the first place, see " { $link "bootstrap.image" } "." ;
ARTICLE: "standard-cli-args" "Command line switches for general usage"
@ -84,17 +84,43 @@ ARTICLE: "standard-cli-args" "Command line switches for general usage"
{ $table
{ { $snippet "-e=" { $emphasis "code" } } { "This specifies a code snippet to evaluate. If you want Factor to exit immediately after, also specify " { $snippet "-run=none" } "." } }
{ { $snippet "-run=" { $emphasis "vocab" } } { { $snippet { $emphasis "vocab" } } " is the name of a vocabulary with a " { $link POSTPONE: MAIN: } " hook to run on startup, for example " { $vocab-link "listener" } ", " { $vocab-link "ui" } " or " { $vocab-link "none" } "." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of the " { $snippet ".factor-rc" } " file in the user's home directory on startup." } }
{ { $snippet "-no-user-init" } { "Inhibits the running of user initialization files on startup. See " { $link "rc-files" } "." } }
{ { $snippet "-quiet" } { "If set, " { $link run-file } " and " { $link require } " will not print load messages." } }
{ { $snippet "-script" } { "Equivalent to " { $snippet "-quiet -run=none" } "." $nl "On Unix systems, Factor can be used for scripting - just create an executable text file whose first line is:" { $code "#! /usr/local/bin/factor -script" } "The space after " { $snippet "#!" } " is necessary because of Factor syntax." } }
} ;
ARTICLE: "rc-files" "Running code on startup"
"Unless the " { $snippet "-no-user-init" } " command line switch is specified, The startup routine runs the " { $snippet ".factor-rc" } " file in the user's home directory, if it exists. This file can contain initialization and customization for your development environment."
ARTICLE: "factor-boot-rc" "Bootstrap initialization file"
"The botstrap initialization file is named " { $snippet "factor-boot-rc" } " on Windows and " { $snippet ".factor-boot-rc" } " on Unix. This file can contain " { $link require } " calls for vocabularies you use frequently, and other such long-running tasks that you do not want to perform every time Factor starts."
$nl
"The " { $snippet ".factor-rc" } " and " { $snippet ".factor-boot-rc" } " files can be run explicitly:"
{ $subsection run-user-init }
{ $subsection run-bootstrap-init } ;
"A word to run this file from an existing Factor session:"
{ $subsection run-bootstrap-init }
"For example, if you changed " { $snippet ".factor-boot-rc" } " and do not want to bootstrap again, you can just invoke " { $link run-bootstrap-init } " in the listener." ;
ARTICLE: "factor-rc" "Startup initialization file"
"The startup initialization file is named " { $snippet "factor-rc" } " on Windows and " { $snippet ".factor-rc" } " on Unix. If it exists, it is run every time Factor starts."
$nl
"A word to run this file from an existing Factor session:"
{ $subsection run-user-init } ;
ARTICLE: "rc-files" "Running code on startup"
"Factor looks for two files in your home directory."
{ $subsection "factor-boot-rc" }
{ $subsection "factor-rc" }
"The " { $snippet "-no-user-init" } " command line switch will inhibit the running of these files."
$nl
"If you are unsure where the files should be located, evaluate the following code:"
{ $code
"USE: command-line"
"\"factor-rc\" rc-path print"
"\"factor-boot-rc\" rc-path print"
}
"Here is an example " { $snippet ".factor-boot-rc" } " which sets up GVIM editor integration, adds an additional vocabulary root (see " { $link "vocabs.roots" } "), and increases the font size in the UI by setting the DPI (dots-per-inch) variable:"
{ $code
"USING: editors.gvim vocabs.loader ui.freetype namespaces sequences ;"
"\"/opt/local/bin\" \\ gvim-path set-global"
"\"/home/jane/src/\" vocab-roots get push"
"100 dpi set-global"
} ;
ARTICLE: "cli" "Command line usage"
"Zero or more command line arguments may be passed to the Factor runtime. Command line arguments starting with a dash (" { $snippet "-" } ") is interpreted as switches. All other arguments are taken to be file names to be run by " { $link run-file } "."

View File

@ -5,14 +5,18 @@ kernel.private namespaces parser sequences strings system
splitting io.files eval ;
IN: command-line
: rc-path ( name -- path )
os windows? [ "." prepend ] unless
home prepend-path ;
: run-bootstrap-init ( -- )
"user-init" get [
home ".factor-boot-rc" append-path ?run-file
"factor-boot-rc" rc-path ?run-file
] when ;
: run-user-init ( -- )
"user-init" get [
home ".factor-rc" append-path ?run-file
"factor-rc" rc-path ?run-file
] when ;
: cli-var-param ( name value -- ) swap set-global ;

View File

@ -235,7 +235,7 @@ M: float-regs reg-class-variable drop float-regs ;
GENERIC: inc-reg-class ( register-class -- )
: ?dummy-stack-params ( reg-class -- )
dummy-stack-params? [ reg-size stack-params +@ ] [ drop ] if ;
dummy-stack-params? [ reg-size cell align stack-params +@ ] [ drop ] if ;
: ?dummy-int-params ( reg-class -- )
dummy-int-params? [ reg-size cell /i 1 max int-regs +@ ] [ drop ] if ;
@ -264,7 +264,7 @@ M: object reg-class-full?
: spill-param ( reg-class -- n reg-class )
stack-params get
>r reg-size stack-params +@ r>
>r reg-size cell align stack-params +@ r>
stack-params ;
: fastcall-param ( reg-class -- n reg-class )

View File

@ -6,7 +6,7 @@ HELP: enable-compiler
{ $description "Enables the optimizing compiler." } ;
HELP: disable-compiler
{ $description "Enables the optimizing compiler." } ;
{ $description "Disable the optimizing compiler." } ;
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically. This can be changed:"

View File

@ -146,13 +146,21 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
! Make sure XT doesn't get clobbered in stack frame
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a ptr -- result y )
"void"
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
"int"
f "ffi_test_31"
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
alien-invoke gc 3 ;
[ 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
[ 861 3 ] [ 42 [ ] each ffi_test_31 ] unit-test
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
"float"
f "ffi_test_31_point_5"
{ "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
alien-invoke ;
[ 861.0 ] [ 42 [ >float ] each ffi_test_31_point_5 ] unit-test
FUNCTION: longlong ffi_test_21 long x long y ;

View File

@ -34,14 +34,10 @@ IN: compiler.tree.builder
if ;
: (build-tree-from-word) ( word -- )
dup
[ "inline" word-prop ]
[ "recursive" word-prop ] bi and [
1quotation f initial-recursive-state infer-quot
] [
[ specialized-def ] [ initial-recursive-state ] bi
infer-quot
] if ;
dup initial-recursive-state recursive-state set
dup [ "inline" word-prop ] [ "recursive" word-prop ] bi and
[ 1quotation ] [ specialized-def ] if
infer-quot-here ;
: check-cannot-infer ( word -- )
dup "cannot-infer" word-prop [ cannot-infer-effect ] [ drop ] if ;

View File

@ -141,10 +141,10 @@ HOOK: %loop-entry cpu ( -- )
HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( heap-size -- ? )
HOOK: struct-small-enough? cpu ( c-type -- ? )
! Do we pass value structs by value or hidden reference?
HOOK: value-structs? cpu ( -- ? )
! Do we pass this struct by value or hidden reference?
HOOK: value-struct? cpu ( c-type -- ? )
! If t, all parameters are shadowed by dummy stack parameters
HOOK: dummy-stack-params? cpu ( -- ? )
@ -207,14 +207,3 @@ M: object %callback-return drop %return ;
M: stack-params param-reg drop ;
M: stack-params param-regs drop f ;
: if-small-struct ( n size true false -- ? )
[ 2dup [ not ] [ struct-small-enough? ] bi* and ] 2dip
[ '[ nip @ ] ] dip if ;
inline
: %unbox-struct ( n c-type -- )
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;
: %box-struct ( n c-type -- )
[ %box-small-struct ] [ %box-large-struct ] if-small-struct ;

View File

@ -15,7 +15,7 @@ M: linux lr-save 1 cells ;
M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 } ;
M: ppc value-structs? f ;
M: ppc value-struct? drop f ;
M: ppc dummy-stack-params? f ;

View File

@ -16,7 +16,7 @@ M: macosx lr-save 2 cells ;
M: float-regs param-regs drop { 1 2 3 4 5 6 7 8 9 10 11 12 13 } ;
M: ppc value-structs? t ;
M: ppc value-struct? drop t ;
M: ppc dummy-stack-params? t ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel layouts system math alien.c-types
USING: kernel layouts system math alien.c-types sequences
compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
IN: cpu.x86.64.winnt
@ -10,8 +10,9 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
M: x86.64 reserved-area-size 4 cells ;
M: x86.64 struct-small-enough? ( size -- ? )
heap-size cell <= ;
M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ;
M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;
M: x86.64 dummy-stack-params? f ;
@ -21,6 +22,7 @@ M: x86.64 dummy-fp-params? t ;
<<
"longlong" "ptrdiff_t" typedef
"longlong" "intptr_t" typedef
"int" "long" typedef
"uint" "ulong" typedef
>>

View File

@ -507,7 +507,7 @@ M: x86 %prepare-alien-invoke
temp-reg-1 2 cells [+] ds-reg MOV
temp-reg-1 3 cells [+] rs-reg MOV ;
M: x86 value-structs? t ;
M: x86 value-struct? drop t ;
M: x86 small-enough? ( n -- ? )
HEX: -80000000 HEX: 7fffffff between? ;

View File

@ -1,11 +1,11 @@
USING: definitions io.launcher kernel parser words sequences math
math.parser namespaces editors make ;
math.parser namespaces editors make system ;
IN: editors.emacs
: emacsclient ( file line -- )
[
\ emacsclient get "emacsclient" or ,
"--no-wait" ,
os windows? [ "--no-wait" , ] unless
"+" swap number>string append ,
,
] { } make try-process ;

View File

@ -64,7 +64,7 @@ C-STRUCT: glyph
{ "FT_Pos" "advance-x" }
{ "FT_Pos" "advance-y" }
{ "long" "format" }
{ "intptr_t" "format" }
{ "int" "bitmap-rows" }
{ "int" "bitmap-width" }

View File

@ -4,7 +4,6 @@ USING: kernel sequences db.tuples alarms calendar db fry
furnace.db
furnace.cache
furnace.asides
furnace.referrer
furnace.sessions
furnace.conversations
furnace.auth.providers
@ -24,8 +23,7 @@ IN: furnace.alloy
<conversations>
<sessions>
] dip
<db-persistence>
<check-form-submissions> ;
<db-persistence> ;
: start-expiring ( db -- )
'[

View File

@ -61,7 +61,7 @@
</table>
<p>
<button>Update</button>
<button type="submit">Update</button>
<t:validation-errors />
</p>

View File

@ -32,7 +32,7 @@
</table>
<button>Recover password</button>
<button type="submit">Recover password</button>
</t:form>

View File

@ -31,7 +31,7 @@
</table>
<p>
<button>Set password</button>
<button type="submit">Set password</button>
<t:validation-errors />
</p>

View File

@ -62,7 +62,7 @@
<p>
<button>Register</button>
<button type="submit">Register</button>
<t:validation-errors />
</p>

View File

@ -35,7 +35,7 @@
<p>
<button>Log in</button>
<button type="submit">Log in</button>
<t:validation-errors />
</p>

View File

@ -97,7 +97,7 @@ HELP: with-exit-continuation
{ $notes "Furnace actions and authentication realms wrap their execution in this combinator, allowing form validation failures and login requests, respectively, to immediately return an HTTP response to the client without running any more responder code." } ;
ARTICLE: "furnace.extension-points" "Furnace extension points"
"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the setateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
"Furnace features such as session management, conversation scope and asides need to modify URLs in links and redirects, and insert hidden form fields, to implement state on top of the stateless HTTP protocol. In order to decouple the server-side state management code from the HTML templating code, a series of hooks are used."
$nl
"Responders can implement methods on the following generic words:"
{ $subsection modify-query }

View File

@ -10,17 +10,15 @@ IN: help.html
: escape-char ( ch -- )
dup H{
{ CHAR: " "__quote__" }
{ CHAR: " "__quo__" }
{ CHAR: * "__star__" }
{ CHAR: : "__colon__" }
{ CHAR: < "__lt__" }
{ CHAR: > "__gt__" }
{ CHAR: ? "__question__" }
{ CHAR: \\ "__backslash__" }
{ CHAR: ? "__que__" }
{ CHAR: \\ "__back__" }
{ CHAR: | "__pipe__" }
{ CHAR: _ "__underscore__" }
{ CHAR: / "__slash__" }
{ CHAR: \\ "__backslash__" }
{ CHAR: , "__comma__" }
{ CHAR: @ "__at__" }
} at [ % ] [ , ] ?if ;
@ -117,10 +115,10 @@ M: result link-href href>> ;
[ [ title>> ] compare ] sort ;
: article-apropos ( string -- results )
"articles.idx" temp-file offline-apropos ;
"articles.idx" offline-apropos ;
: word-apropos ( string -- results )
"words.idx" temp-file offline-apropos ;
"words.idx" offline-apropos ;
: vocab-apropos ( string -- results )
"vocabs.idx" temp-file offline-apropos ;
"vocabs.idx" offline-apropos ;

View File

@ -1,6 +1,6 @@
USING: io io.files io.streams.string io.encodings.utf8
html.templates html.templates.fhtml kernel
tools.test sequences parser ;
tools.test sequences parser splitting prettyprint ;
IN: html.templates.fhtml.tests
: test-template ( path -- ? )
@ -8,8 +8,10 @@ IN: html.templates.fhtml.tests
prepend
[
".fhtml" append <fhtml> [ call-template ] with-string-writer
<string-reader> lines
] keep
".html" append utf8 file-contents = ;
".html" append utf8 file-lines
[ . . ] [ = ] 2bi ;
[ t ] [ "example" test-template ] unit-test
[ t ] [ "bug" test-template ] unit-test

View File

@ -3,4 +3,6 @@
USING: tools.test io.files.listing strings kernel ;
IN: io.files.listing.tests
\ directory. must-infer
[ ] [ "" directory. ] unit-test

View File

@ -114,19 +114,29 @@ M: threaded-server handle-client* handler>> call ;
] when*
] unless ;
: (start-server) ( threaded-server -- )
init-server
dup threaded-server [
dup name>> [
[ listen-on [ start-accept-loop ] parallel-each ]
[ ready>> raise-flag ]
bi
] with-logging
] with-variable ;
PRIVATE>
: start-server ( threaded-server -- )
init-server
dup secure-config>> [
dup threaded-server [
dup name>> [
[ listen-on [ start-accept-loop ] parallel-each ]
[ ready>> raise-flag ]
bi
] with-logging
] with-variable
] with-secure-context ;
#! Only create a secure-context if we want to listen on
#! a secure port, otherwise start-server won't work at
#! all if SSL is not available.
dup secure>> [
dup secure-config>> [
(start-server)
] with-secure-context
] [
(start-server)
] if ;
: wait-for-server ( threaded-server -- )
ready>> wait-for-flag ;

View File

@ -1,157 +1,157 @@
USING: io.launcher tools.test calendar accessors environment
namespaces kernel system arrays io io.files io.encodings.ascii
sequences parser assocs hashtables math continuations eval ;
IN: io.windows.launcher.nt.tests
[ ] [
<process>
"notepad" >>command
1/2 seconds >>timeout
"notepad" set
] unit-test
[ f ] [ "notepad" get process-running? ] unit-test
[ f ] [ "notepad" get process-started? ] unit-test
[ ] [ "notepad" [ run-detached ] change ] unit-test
[ "notepad" get wait-for-process ] must-fail
[ t ] [ "notepad" get killed>> ] unit-test
[ f ] [ "notepad" get process-running? ] unit-test
[ ] [
<process>
vm "-quiet" "-run=hello-world" 3array >>command
"out.txt" temp-file >>stdout
try-process
] unit-test
[ "Hello world" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ ] [
<process>
vm "-run=listener" 2array >>command
+closed+ >>stdin
try-process
] unit-test
[ ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout
"err.txt" temp-file >>stderr
try-process
] with-directory
] unit-test
[ "output" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ "error" ] [
"err.txt" temp-file ascii file-lines first
] unit-test
[ ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout
+stdout+ >>stderr
try-process
] with-directory
] unit-test
[ "outputerror" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ "output" ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr
ascii <process-reader> lines first
] with-directory
] unit-test
[ "error" ] [
"err2.txt" temp-file ascii file-lines first
] unit-test
[ t ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
] with-directory eval
os-envs =
] unit-test
[ t ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> contents
] with-directory eval
os-envs =
] unit-test
[ "B" ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> contents
] with-directory eval
"A" swap at
] unit-test
[ f ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
{ { "HOME" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> contents
] with-directory eval
"HOME" swap at "XXX" =
] unit-test
2 [
[ ] [
<process>
"cmd.exe /c dir" >>command
"dir.txt" temp-file >>stdout
try-process
] unit-test
[ ] [ "dir.txt" temp-file delete-file ] unit-test
] times
[ "append-test" temp-file delete-file ] ignore-errors
[ "Hello appender\r\nHello appender\r\n" ] [
2 [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "append.factor" 3array >>command
"append-test" temp-file <appender> >>stdout
try-process
] with-directory
] times
"append-test" temp-file ascii file-contents
] unit-test
USING: io.launcher tools.test calendar accessors environment
namespaces kernel system arrays io io.files io.encodings.ascii
sequences parser assocs hashtables math continuations eval ;
IN: io.windows.launcher.nt.tests
[ ] [
<process>
"notepad" >>command
1/2 seconds >>timeout
"notepad" set
] unit-test
[ f ] [ "notepad" get process-running? ] unit-test
[ f ] [ "notepad" get process-started? ] unit-test
[ ] [ "notepad" [ run-detached ] change ] unit-test
[ "notepad" get wait-for-process ] must-fail
[ t ] [ "notepad" get killed>> ] unit-test
[ f ] [ "notepad" get process-running? ] unit-test
[ ] [
<process>
vm "-quiet" "-run=hello-world" 3array >>command
"out.txt" temp-file >>stdout
try-process
] unit-test
[ "Hello world" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ ] [
<process>
vm "-run=listener" 2array >>command
+closed+ >>stdin
try-process
] unit-test
[ ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout
"err.txt" temp-file >>stderr
try-process
] with-directory
] unit-test
[ "output" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ "error" ] [
"err.txt" temp-file ascii file-lines first
] unit-test
[ ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "stderr.factor" 3array >>command
"out.txt" temp-file >>stdout
+stdout+ >>stderr
try-process
] with-directory
] unit-test
[ "outputerror" ] [
"out.txt" temp-file ascii file-lines first
] unit-test
[ "output" ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "stderr.factor" 3array >>command
"err2.txt" temp-file >>stderr
ascii <process-reader> lines first
] with-directory
] unit-test
[ "error" ] [
"err2.txt" temp-file ascii file-lines first
] unit-test
[ t ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
ascii <process-reader> contents
] with-directory eval
os-envs =
] unit-test
[ t ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
+replace-environment+ >>environment-mode
os-envs >>environment
ascii <process-reader> contents
] with-directory eval
os-envs =
] unit-test
[ "B" ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
{ { "A" "B" } } >>environment
ascii <process-reader> contents
] with-directory eval
"A" swap at
] unit-test
[ f ] [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "env.factor" 3array >>command
{ { "USERPROFILE" "XXX" } } >>environment
+prepend-environment+ >>environment-mode
ascii <process-reader> contents
] with-directory eval
"USERPROFILE" swap at "XXX" =
] unit-test
2 [
[ ] [
<process>
"cmd.exe /c dir" >>command
"dir.txt" temp-file >>stdout
try-process
] unit-test
[ ] [ "dir.txt" temp-file delete-file ] unit-test
] times
[ "append-test" temp-file delete-file ] ignore-errors
[ "Hello appender\r\nHello appender\r\n" ] [
2 [
"resource:basis/io/windows/nt/launcher/test" [
<process>
vm "-script" "append.factor" 3array >>command
"append-test" temp-file <appender> >>stdout
try-process
] with-directory
] times
"append-test" temp-file ascii file-contents
] unit-test

1
basis/io/windows/tags.txt Normal file → Executable file
View File

@ -1,2 +1 @@
unportable
windows

View File

@ -346,7 +346,6 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
{ 3 1 } [| from to seq | T{ slice f from to seq } ] must-infer-as
:: literal-identity-test ( -- a b )
{ } V{ } ;
@ -356,6 +355,10 @@ M:: sequence method-with-locals ( a -- y ) a reverse ;
swapd [ eq? ] [ eq? ] 2bi*
] unit-test
:: mutable-local-in-literal-test ( a! -- b ) a 1 + a! { a } ;
[ { 4 } ] [ 3 mutable-local-in-literal-test ] unit-test
:: compare-case ( obj1 obj2 lt-quot eq-quot gt-quot -- )
obj1 obj2 <=> {
{ +lt+ [ lt-quot call ] }

View File

@ -229,6 +229,8 @@ M: tuple rewrite-element
M: local rewrite-element , ;
M: local-reader rewrite-element , ;
M: word rewrite-element literalize , ;
M: object rewrite-element , ;

View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions sequences
sequences.private words namespaces macros hints
combinators fry ;
combinators fry io.binary ;
IN: math.bitwise
! utilities
@ -93,3 +93,11 @@ PRIVATE>
: bit-count ( x -- n )
dup 0 < [ bitnot ] when (bit-count) ; inline
! Signed byte array to integer conversion
: signed-le> ( bytes -- x )
[ le> ] [ length 8 * 1- on-bits ] bi
2dup > [ bitnot bitor ] [ drop ] if ;
: signed-be> ( bytes -- x )
<reversed> signed-le> ;

View File

@ -15,7 +15,7 @@ IN: math.functions
PRIVATE>
: rect> ( x y -- z )
over real? over real? and [
2dup [ real? ] both? [
(rect>)
] [
"Complex number must have real components" throw
@ -27,10 +27,10 @@ M: real sqrt
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
: each-bit ( n quot: ( ? -- ) -- )
over 0 = pick -1 = or [
over [ 0 = ] [ -1 = ] bi or [
2drop
] [
2dup >r >r >r odd? r> call r> 2/ r> each-bit
2dup { [ odd? ] [ call ] [ 2/ ] [ each-bit ] } spread
] if ; inline recursive
: map-bits ( n quot: ( ? -- obj ) -- seq )
@ -69,8 +69,7 @@ PRIVATE>
>rect [ >float ] bi@ ; inline
: >polar ( z -- abs arg )
>float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ;
inline
>float-rect [ [ sq ] bi@ + fsqrt ] [ swap fatan2 ] 2bi ; inline
: cis ( arg -- z ) dup fcos swap fsin rect> ; inline
@ -79,11 +78,10 @@ PRIVATE>
<PRIVATE
: ^mag ( w abs arg -- magnitude )
>r >r >float-rect swap r> swap fpow r> rot * fexp /f ;
inline
[ >float-rect swap ] [ swap fpow ] [ rot * fexp /f ] tri* ; inline
: ^theta ( w abs arg -- theta )
>r >r >float-rect r> flog * swap r> * + ; inline
[ >float-rect ] [ flog * swap ] [ * + ] tri* ; inline
: ^complex ( x y -- z )
swap >polar [ ^mag ] [ ^theta ] 3bi polar> ; inline
@ -106,18 +104,18 @@ PRIVATE>
: (^mod) ( n x y -- z )
1 swap [
[ dupd * pick mod ] when >r sq over mod r>
[ dupd * pick mod ] when [ sq over mod ] dip
] each-bit 2nip ; inline
: (gcd) ( b a x y -- a d )
over zero? [
2nip
] [
swap [ /mod >r over * swapd - r> ] keep (gcd)
swap [ /mod [ over * swapd - ] dip ] keep (gcd)
] if ;
: gcd ( x y -- a d )
0 -rot 1 -rot (gcd) dup 0 < [ neg ] when ; foldable
[ 0 1 ] 2dip (gcd) dup 0 < [ neg ] when ; foldable
: lcm ( a b -- c )
[ * ] 2keep gcd nip /i ; foldable
@ -131,7 +129,7 @@ PRIVATE>
: ^mod ( x y n -- z )
over 0 < [
[ >r neg r> ^mod ] keep mod-inv
[ [ neg ] dip ^mod ] keep mod-inv
] [
-rot (^mod)
] if ; foldable
@ -141,14 +139,14 @@ GENERIC: absq ( x -- y ) foldable
M: real absq sq ;
: ~abs ( x y epsilon -- ? )
>r - abs r> < ;
[ - abs ] dip < ;
: ~rel ( x y epsilon -- ? )
>r [ - abs ] 2keep [ abs ] bi@ + r> * < ;
[ [ - abs ] 2keep [ abs ] bi@ + ] dip * < ;
: ~ ( x y epsilon -- ? )
{
{ [ pick fp-nan? pick fp-nan? or ] [ 3drop f ] }
{ [ 2over [ fp-nan? ] either? ] [ 3drop f ] }
{ [ dup zero? ] [ drop number= ] }
{ [ dup 0 < ] [ ~rel ] }
[ ~abs ]

View File

@ -12,10 +12,10 @@ SYMBOL: full-interval
TUPLE: interval { from read-only } { to read-only } ;
: <interval> ( from to -- int )
over first over first {
2dup [ first ] bi@ {
{ [ 2dup > ] [ 2drop 2drop empty-interval ] }
{ [ 2dup = ] [
2drop over second over second and
2drop 2dup [ second ] both?
[ interval boa ] [ 2drop empty-interval ] if
] }
[ 2drop interval boa ]
@ -26,16 +26,16 @@ TUPLE: interval { from read-only } { to read-only } ;
: closed-point ( n -- endpoint ) t 2array ;
: [a,b] ( a b -- interval )
>r closed-point r> closed-point <interval> ; foldable
[ closed-point ] dip closed-point <interval> ; foldable
: (a,b) ( a b -- interval )
>r open-point r> open-point <interval> ; foldable
[ open-point ] dip open-point <interval> ; foldable
: [a,b) ( a b -- interval )
>r closed-point r> open-point <interval> ; foldable
[ closed-point ] dip open-point <interval> ; foldable
: (a,b] ( a b -- interval )
>r open-point r> closed-point <interval> ; foldable
[ open-point ] dip closed-point <interval> ; foldable
: [a,a] ( a -- interval )
closed-point dup <interval> ; foldable
@ -51,11 +51,11 @@ TUPLE: interval { from read-only } { to read-only } ;
: [-inf,inf] ( -- interval ) full-interval ; inline
: compare-endpoints ( p1 p2 quot -- ? )
>r over first over first r> call [
[ 2dup [ first ] bi@ ] dip call [
2drop t
] [
over first over first = [
swap second swap second not or
2dup [ first ] bi@ = [
[ second ] bi@ not or
] [
2drop f
] if
@ -86,7 +86,7 @@ TUPLE: interval { from read-only } { to read-only } ;
] if ;
: (interval-op) ( p1 p2 quot -- p3 )
[ [ first ] [ first ] [ ] tri* call ]
[ [ first ] [ first ] [ call ] tri* ]
[ drop [ second ] both? ]
3bi 2array ; inline
@ -177,7 +177,7 @@ TUPLE: interval { from read-only } { to read-only } ;
drop f
] [
interval>points
2dup [ second ] bi@ and
2dup [ second ] both?
[ [ first ] bi@ = ]
[ 2drop f ] if
] if ;
@ -193,9 +193,9 @@ TUPLE: interval { from read-only } { to read-only } ;
dup [ interval>points [ first ] bi@ [a,b] ] when ;
: interval-integer-op ( i1 i2 quot -- i3 )
>r 2dup
[ interval>points [ first integer? ] both? ] both?
r> [ 2drop [-inf,inf] ] if ; inline
[
2dup [ interval>points [ first integer? ] both? ] both?
] dip [ 2drop [-inf,inf] ] if ; inline
: interval-shift ( i1 i2 -- i3 )
#! Inaccurate; could be tighter
@ -302,7 +302,7 @@ SYMBOL: incomparable
2tri and and ;
: (interval<) ( i1 i2 -- i1 i2 ? )
over from>> over from>> endpoint< ;
2dup [ from>> ] bi@ endpoint< ;
: interval< ( i1 i2 -- ? )
{
@ -314,10 +314,10 @@ SYMBOL: incomparable
} cond 2nip ;
: left-endpoint-<= ( i1 i2 -- ? )
>r from>> r> to>> = ;
[ from>> ] dip to>> = ;
: right-endpoint-<= ( i1 i2 -- ? )
>r to>> r> from>> = ;
[ to>> ] dip from>> = ;
: interval<= ( i1 i2 -- ? )
{

View File

@ -126,7 +126,7 @@ SYMBOL: fast-math-ops
: math-method* ( word left right -- quot )
3dup math-op
[ >r 3drop r> 1quotation ] [ drop math-method ] if ;
[ [ 3drop ] dip 1quotation ] [ drop math-method ] if ;
: math-both-known? ( word left right -- ? )
3dup math-op
@ -157,13 +157,13 @@ SYMBOL: fast-math-ops
] bi@ append ;
: each-derived-op ( word quot -- )
>r derived-ops r> each ; inline
[ derived-ops ] dip each ; inline
: each-fast-derived-op ( word quot -- )
>r fast-derived-ops r> each ; inline
[ fast-derived-ops ] dip each ; inline
: each-integer-derived-op ( word quot -- )
>r integer-derived-ops r> each ; inline
[ integer-derived-ops ] dip each ; inline
[
[

View File

@ -8,7 +8,7 @@ TUPLE: range
{ step read-only } ;
: <range> ( a b step -- range )
>r over - r>
[ over - ] dip
[ / 1+ 0 max >integer ] keep
range boa ; inline

View File

@ -12,10 +12,10 @@ IN: math.ratios
dup 1 number= [ drop ] [ <ratio> ] if ; inline
: scale ( a/b c/d -- a*d b*c )
2>fraction >r * swap r> * swap ; inline
2>fraction [ * swap ] dip * swap ; inline
: ratio+d ( a/b c/d -- b*d )
denominator swap denominator * ; inline
[ denominator ] bi@ * ; inline
PRIVATE>
@ -24,7 +24,7 @@ M: integer /
"Division by zero" throw
] [
dup 0 < [ [ neg ] bi@ ] when
2dup gcd nip tuck /i >r /i r> fraction>
2dup gcd nip tuck /i [ /i ] dip fraction>
] if ;
M: ratio hashcode*
@ -52,7 +52,7 @@ M: ratio >= scale >= ;
M: ratio + 2dup scale + -rot ratio+d / ;
M: ratio - 2dup scale - -rot ratio+d / ;
M: ratio * 2>fraction * >r * r> / ;
M: ratio * 2>fraction * [ * ] dip / ;
M: ratio / scale / ;
M: ratio /i scale /i ;
M: ratio /f scale /f ;

View File

@ -34,7 +34,7 @@ HELP: n*v
{ $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ;
HELP: v*n
{ $values { "n" "a number" } { "u" "a sequence of numbers" } { "v" "a sequence of numbers" } }
{ $values { "u" "a sequence of numbers" } { "n" "a number" } { "v" "a sequence of numbers" } }
{ $description "Multiplies each element of " { $snippet "u" } " by " { $snippet "n" } "." } ;
HELP: n/v

View File

@ -25,7 +25,7 @@ IN: math.vectors
: normalize ( u -- v ) dup norm v/n ;
: set-axis ( u v axis -- w )
[ >r zero? 2over ? r> swap nth ] map-index 2nip ;
[ [ zero? 2over ? ] dip swap nth ] map-index 2nip ;
HINTS: vneg { array } ;
HINTS: norm-sq { array } ;

1
basis/opengl/gl/windows/tags.txt Normal file → Executable file
View File

@ -1,2 +1 @@
unportable
windows

View File

@ -31,7 +31,7 @@ IN: opengl
over glEnableClientState dip glDisableClientState ; inline
: words>values ( word/value-seq -- value-seq )
[ dup word? [ execute ] [ ] if ] map ;
[ dup word? [ execute ] when ] map ;
: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
@ -64,17 +64,18 @@ MACRO: all-enabled-client-state ( seq quot -- )
[ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
: line-vertices ( a b -- )
append >c-float-array gl-vertex-pointer ;
[ first2 [ 0.5 + ] bi@ ] bi@ 4 narray
>c-float-array gl-vertex-pointer ;
: gl-line ( a b -- )
line-vertices GL_LINES 0 2 glDrawArrays ;
: (rect-vertices) ( dim -- vertices )
{
[ drop 0 1 ]
[ first 1- 1 ]
[ [ first 1- ] [ second ] bi ]
[ second 0 swap ]
[ drop 0.5 0.5 ]
[ first 0.3 - 0.5 ]
[ [ first 0.3 - ] [ second 0.3 - ] bi ]
[ second 0.3 - 0.5 swap ]
} cleave 8 narray >c-float-array ;
: rect-vertices ( dim -- )

View File

@ -355,3 +355,13 @@ INTERSECTION: intersection-see-test sequence number ;
[ ] [ \ curry see ] unit-test
[ "POSTPONE: [" ] [ \ [ unparse ] unit-test
TUPLE: started-out-hustlin' ;
GENERIC: ended-up-ballin'
M: started-out-hustlin' ended-up-ballin' ; inline
[ "USING: prettyprint.tests ;\nM: started-out-hustlin' ended-up-ballin' ; inline\n" ] [
[ { started-out-hustlin' ended-up-ballin' } see ] with-string-writer
] unit-test

View File

@ -253,6 +253,9 @@ M: object see
block>
] with-use nl ;
M: method-spec see
first2 method see ;
GENERIC: see-class* ( word -- )
M: union-class see-class*

1
basis/random/windows/tags.txt Normal file → Executable file
View File

@ -1,2 +1 @@
unportable
windows

View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors hashtables kernel math state-tables vars vectors ;
USING: accessors hashtables kernel math state-tables vectors ;
IN: regexp.backend
TUPLE: regexp

View File

@ -30,6 +30,10 @@ M: ascii-class class-member? ( obj class -- ? )
M: digit-class class-member? ( obj class -- ? )
drop digit? ;
M: c-identifier-class class-member? ( obj class -- ? )
drop
{ [ digit? ] [ Letter? ] [ CHAR: _ = ] } 1|| ;
M: alpha-class class-member? ( obj class -- ? )
drop alpha? ;

View File

@ -137,7 +137,7 @@ ERROR: bad-special-group string ;
DEFER: (parse-regexp)
: nested-parse-regexp ( token ? -- )
[ push-stack (parse-regexp) pop-stack ] dip
[ <negation> ] when pop-stack boa push-stack ;
[ <negation> ] when pop-stack new swap >>term push-stack ;
! non-capturing groups
: (parse-special-group) ( -- )
@ -294,6 +294,7 @@ ERROR: unrecognized-escape char ;
read1
{
{ CHAR: \ [ CHAR: \ <constant> ] }
{ CHAR: / [ CHAR: / <constant> ] }
{ CHAR: ^ [ CHAR: ^ <constant> ] }
{ CHAR: $ [ CHAR: $ <constant> ] }
{ CHAR: - [ CHAR: - <constant> ] }

View File

@ -2,6 +2,9 @@ USING: regexp tools.test kernel sequences regexp.parser
regexp.traversal eval ;
IN: regexp-tests
\ <regexp> must-infer
\ matches? must-infer
[ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test
[ t ] [ "a" "a*" <regexp> matches? ] unit-test
@ -43,6 +46,18 @@ IN: regexp-tests
[ t ] [ "a" ".+" <regexp> matches? ] unit-test
[ t ] [ "ab" ".+" <regexp> matches? ] unit-test
[ t ] [ " " "[\\s]" <regexp> matches? ] unit-test
[ f ] [ "a" "[\\s]" <regexp> matches? ] unit-test
[ f ] [ " " "[\\S]" <regexp> matches? ] unit-test
[ t ] [ "a" "[\\S]" <regexp> matches? ] unit-test
[ f ] [ " " "[\\w]" <regexp> matches? ] unit-test
[ t ] [ "a" "[\\w]" <regexp> matches? ] unit-test
[ t ] [ " " "[\\W]" <regexp> matches? ] unit-test
[ f ] [ "a" "[\\W]" <regexp> matches? ] unit-test
[ t ] [ "/" "\\/" <regexp> matches? ] unit-test
[ t ] [ "a" R' a'i matches? ] unit-test
[ t ] [ "" "a|b*|c+|d?" <regexp> matches? ] unit-test
[ t ] [ "a" "a|b*|c+|d?" <regexp> matches? ] unit-test
@ -331,3 +346,7 @@ IN: regexp-tests
[ { 0 3 } ] [ "abc" "(ab|a)(bc)?" <regexp> first-match ] unit-test
[ { 23 24 } ] [ "aaaaaaaaaaaaaaaaaaaaaaab" "((a*)*b)*b" <regexp> first-match ] unit-test
[ t ] [ "a:b" ".+:?" <regexp> matches? ] unit-test
[ 1 ] [ "hello" ".+?" <regexp> match length ] unit-test

View File

@ -28,7 +28,7 @@ IN: regexp
: match ( string regexp -- pair )
<dfa-traverser> do-match return-match ;
: match* ( string regexp -- pair )
: match* ( string regexp -- pair captured-groups )
<dfa-traverser> do-match [ return-match ] [ captured-groups>> ] bi ;
: matches? ( string regexp -- ? )
@ -129,8 +129,6 @@ IN: regexp
: option? ( option regexp -- ? )
options>> key? ;
USE: multiline
/*
M: regexp pprint*
[
[
@ -139,4 +137,3 @@ M: regexp pprint*
case-insensitive swap option? [ "i" % ] when
] "" make
] keep present-text ;
*/

View File

@ -107,7 +107,8 @@ M: capture-group-off flag-action ( dfa-traverser flag -- )
: increment-state ( dfa-traverser state -- dfa-traverser )
[
dup traverse-forward>>
[ 1+ ] [ 1- ] ? change-current-index
[ [ 1+ ] change-current-index ]
[ [ 1- ] change-current-index ] if
dup current-state>> >>last-state
] dip
first >>current-state ;

View File

@ -0,0 +1,4 @@
USING: regexp.utils tools.test ;
IN: regexp.utils.tests
[ [ ] [ ] while-changes ] must-infer

View File

@ -5,9 +5,7 @@ namespaces regexp.backend sequences unicode.categories
math.ranges fry combinators.short-circuit vectors ;
IN: regexp.utils
: (while-changes) ( obj quot pred pred-ret -- obj )
! quot: ( obj -- obj' )
! pred: ( obj -- <=> )
: (while-changes) ( obj quot: ( obj -- obj' ) pred: ( obj -- <=> ) pred-ret -- obj )
[ [ dup slip ] dip pick over call ] dip dupd =
[ 3drop ] [ (while-changes) ] if ; inline recursive

View File

@ -24,7 +24,7 @@ M: inference-error error-help error>> error-help ;
+warning+ (inference-error) ; inline
M: inference-error error.
[ "In word: " write word>> . ] [ error>> error. ] bi ;
[ word>> [ "In word: " write . ] when* ] [ error>> error. ] bi ;
TUPLE: literal-expected ;
@ -108,3 +108,9 @@ M: inconsistent-recursive-call-error error.
"The recursive word " write
word>> pprint
" calls itself with a different set of quotation parameters than were input" print ;
TUPLE: unknown-primitive-error ;
M: unknown-primitive-error error.
drop
"Cannot determine stack effect statically" print ;

View File

@ -162,7 +162,7 @@ M: object infer-call*
{ \ load-locals [ infer-load-locals ] }
{ \ get-local [ infer-get-local ] }
{ \ drop-locals [ infer-drop-locals ] }
{ \ do-primitive [ \ do-primitive cannot-infer-effect ] }
{ \ do-primitive [ unknown-primitive-error inference-warning ] }
{ \ alien-invoke [ infer-alien-invoke ] }
{ \ alien-indirect [ infer-alien-indirect ] }
{ \ alien-callback [ infer-alien-callback ] }

View File

@ -4,9 +4,7 @@ USING: accessors arrays sequences kernel sequences assocs
namespaces stack-checker.recursive-state.tree ;
IN: stack-checker.recursive-state
TUPLE: recursive-state words word quotations inline-words ;
C: <recursive-state> recursive-state
TUPLE: recursive-state word words quotations inline-words ;
: prepare-recursive-state ( word rstate -- rstate )
swap >>word

View File

@ -580,3 +580,5 @@ DEFER: eee'
dup "A" throw [ bogus-error ] [ drop ] if ; inline recursive
[ bogus-error ] must-infer
[ [ clear ] infer. ] [ inference-error? ] must-fail-with

View File

@ -9,7 +9,7 @@ sorting compiler.units definitions ;
QUALIFIED: bootstrap.stage2
QUALIFIED: classes
QUALIFIED: command-line
QUALIFIED: compiler.errors.private
QUALIFIED: compiler.errors
QUALIFIED: continuations
QUALIFIED: definitions
QUALIFIED: init
@ -291,7 +291,7 @@ IN: tools.deploy.shaker
strip-debugger? [
{
compiler.errors.private:compiler-errors
compiler.errors:compiler-errors
continuations:thread-error-hook
} %
] when

1
basis/tools/deploy/windows/tags.txt Normal file → Executable file
View File

@ -1,3 +1,2 @@
unportable
windows
tools

View File

@ -196,7 +196,6 @@ M: freetype-renderer string-height ( open-font string -- h )
:: (draw-string) ( open-font sprites string loc -- )
GL_TEXTURE_2D [
loc [
-0.5 0.5 0.0 glTranslated
string open-font string char-widths scan-sums [
[ open-font sprites ] 2dip draw-char
] 2each

View File

@ -111,8 +111,8 @@ TUPLE: checkmark-paint < caching-pen color last-vertices ;
: checkmark-points ( dim -- points )
{
[ { 0 0 } v* { 0 1 } v+ ]
[ { 1 1 } v* { 0 1 } v+ ]
[ { 0 0 } v* ]
[ { 1 1 } v* ]
[ { 0 1 } v* ]
[ { 1 0 } v* ]
} cleave 4array ;

View File

@ -120,7 +120,7 @@ M: editor ungraft*
: scroll>caret ( editor -- )
dup graft-state>> second [
dup caret-loc over caret-dim { 1 0 } v+ <rect>
dup caret-loc over caret-dim <rect>
over scroll>rect
] when drop ;

11
basis/ui/gadgets/grid-lines/grid-lines.factor Normal file → Executable file
View File

@ -18,15 +18,16 @@ SYMBOL: grid-dim
grid-dim get spin set-axis ;
: draw-grid-lines ( gaps orientation -- )
grid get rot grid-positions grid get rect-dim suffix [
grid-line-from/to gl-line
] with each ;
[ grid get swap grid-positions grid get rect-dim suffix ] dip
[ [ v- ] curry map ] keep
[ swap grid-line-from/to gl-line ] curry each ;
M: grid-lines draw-boundary
color>> gl-color [
dup grid set
dup rect-dim half-gap v- grid-dim set
compute-grid
{ 0 1 } draw-grid-lines
{ 1 0 } draw-grid-lines
[ { 1 0 } draw-grid-lines ]
[ { 0 1 } draw-grid-lines ]
bi*
] with-scope ;

2
basis/ui/render/render.factor Normal file → Executable file
View File

@ -23,7 +23,7 @@ SYMBOL: viewport-translation
[ rect-intersect ] keep
dim>> dup { 0 1 } v* viewport-translation set
{ 0 0 } over gl-viewport
-0.5 swap first2 [ 0.5 - ] [ 0.5 + ] bi* 0.5 gluOrtho2D
0 swap first2 0 gluOrtho2D
clip set
do-clip ;

View File

@ -181,8 +181,8 @@ M: stack-display tool-scroller
listener-gadget "toolbar" f {
{ f restart-listener }
{ T{ key-down f f "CLEAR" } clear-output }
{ T{ key-down f { C+ } "CLEAR" } clear-stack }
{ T{ key-down f { A+ } "c" } clear-output }
{ T{ key-down f { A+ } "C" } clear-stack }
{ T{ key-down f { C+ } "d" } com-end }
{ T{ key-down f f "F1" } listener-help }
} define-command-map

View File

@ -76,9 +76,11 @@ M: integer user-groups ( id -- seq )
: all-groups ( -- seq )
[ getgrent dup ] [ group-struct>group ] [ drop ] produce ;
: <group-cache> ( -- assoc )
all-groups [ [ id>> ] keep ] H{ } map>assoc ;
: with-group-cache ( quot -- )
all-groups [ [ id>> ] keep ] H{ } map>assoc
group-cache rot with-variable ; inline
[ <group-cache> group-cache ] dip with-variable ; inline
: real-group-id ( -- id )
getgid ; inline

View File

@ -41,9 +41,11 @@ PRIVATE>
SYMBOL: user-cache
: <user-cache> ( -- assoc )
all-users [ [ uid>> ] keep ] H{ } map>assoc ;
: with-user-cache ( quot -- )
all-users [ [ uid>> ] keep ] H{ } map>assoc
user-cache rot with-variable ; inline
[ <user-cache> user-cache ] dip with-variable ; inline
GENERIC: user-passwd ( obj -- passwd )

View File

@ -52,3 +52,5 @@ namespaces assocs ;
[ "4561_2612_1234_5467" v-credit-card ] must-fail
[ "4561-2621-1234-5467" v-credit-card ] must-fail
[ t ] [ "http://double.co.nz/w?v=foo" dup v-url = ] unit-test

View File

@ -62,9 +62,7 @@ IN: validators
v-regexp ;
: v-url ( str -- str )
"URL"
R' (ftp|http|https)://(\w+:?\w*@)?(\S+)(:[0-9]+)?(/|/([\w#!:.?+=&%@!\-/]))?'
v-regexp ;
"URL" R' (ftp|http|https)://\S+' v-regexp ;
: v-captcha ( str -- str )
dup empty? [ "must remain blank" throw ] unless ;

2
basis/windows/com/syntax/tags.txt Normal file → Executable file
View File

@ -1,4 +1,2 @@
unportable
windows
com
bindings

2
basis/windows/com/tags.txt Normal file → Executable file
View File

@ -1,4 +1,2 @@
unportable
windows
com
bindings

2
basis/windows/com/wrapper/tags.txt Normal file → Executable file
View File

@ -1,4 +1,2 @@
unportable
windows
com
bindings

View File

@ -1,3 +1,2 @@
unportable
windows
bindings

View File

@ -199,11 +199,11 @@ TYPEDEF: FILE_NOTIFY_INFORMATION* PFILE_NOTIFY_INFORMATION
: THREAD_PRIORITY_TIME_CRITICAL 15 ; inline
C-STRUCT: OVERLAPPED
{ "int" "internal" }
{ "int" "internal-high" }
{ "int" "offset" }
{ "int" "offset-high" }
{ "void*" "event" } ;
{ "UINT_PTR" "internal" }
{ "UINT_PTR" "internal-high" }
{ "DWORD" "offset" }
{ "DWORD" "offset-high" }
{ "HANDLE" "event" } ;
C-STRUCT: SYSTEMTIME
{ "WORD" "wYear" }

1
basis/windows/tags.txt Normal file → Executable file
View File

@ -1,3 +1,2 @@
unportable
windows
bindings

View File

@ -40,10 +40,11 @@ TYPEDEF: void* LPVOID
TYPEDEF: void* LPCVOID
TYPEDEF: float FLOAT
TYPEDEF: short HALF_PTR
TYPEDEF: ushort UHALF_PTR
TYPEDEF: int INT_PTR
TYPEDEF: uint UINT_PTR
TYPEDEF: intptr_t HALF_PTR
TYPEDEF: intptr_t UHALF_PTR
TYPEDEF: intptr_t INT_PTR
TYPEDEF: intptr_t UINT_PTR
TYPEDEF: int LONG_PTR
TYPEDEF: ulong ULONG_PTR

View File

@ -1,6 +1,6 @@
IN: compiler.errors
USING: help.markup help.syntax vocabs.loader words io
quotations compiler.errors.private ;
quotations ;
ARTICLE: "compiler-errors" "Compiler warnings and errors"
"The compiler saves various notifications in a global variable:"

View File

@ -14,8 +14,6 @@ M: object compiler-error-type drop +error+ ;
GENERIC# compiler-error. 1 ( error word -- )
<PRIVATE
SYMBOL: compiler-errors
SYMBOL: with-compiler-errors?
@ -47,8 +45,6 @@ SYMBOL: with-compiler-errors?
"semantic warnings" +warning+ "warnings" (compiler-report)
"linkage errors" +linkage+ "linkage" (compiler-report) ;
PRIVATE>
: :errors ( -- ) +error+ compiler-errors. ;
: :warnings ( -- ) +warning+ compiler-errors. ;

View File

@ -25,6 +25,11 @@ IN: io.tests
! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test
[ ] [
"It seems Jobs has lost his grasp on reality again.\n"
"separator-test.txt" temp-file latin1 set-file-contents
] unit-test
[
{
{ "It seems " CHAR: J }
@ -33,7 +38,7 @@ IN: io.tests
}
] [
[
"resource:core/io/test/separator-test.txt"
"separator-test.txt" temp-file
latin1 <file-reader> [
"J" read-until 2array ,
"i" read-until 2array ,

View File

@ -26,12 +26,12 @@ M: null-encoding decode-char drop stream-read1 ;
: map-last ( seq quot -- seq )
>r dup length <reversed> [ zero? ] r> compose 2map ; inline
PRIVATE>
: format-table ( table -- seq )
flip [ format-column ] map-last
flip [ " " join ] map ;
PRIVATE>
M: growable dispose drop ;
M: growable stream-write1 push ;

View File

@ -1 +0,0 @@
It seems Jobs has lost his grasp on reality again.

View File

@ -11,7 +11,7 @@ ARTICLE: "vocabs.roots" "Vocabulary roots"
{ { $snippet "extra" } " - additional contributed libraries." }
{ { $snippet "work" } " - a root for vocabularies which are not intended to be contributed back to Factor." }
}
"Your own vocabularies should go into " { $snippet "extra" } " or " { $snippet "work" } ", depending on whether or not you intend to contribute them back to the Factor project. If you wish to work on vocabularies outside of the Factor source directory, create a " { $snippet "~/.factor-rc" } " file like the following,"
"Your own vocabularies should go into " { $snippet "extra" } " or " { $snippet "work" } ", depending on whether or not you intend to contribute them back to the Factor project. If you wish to work on vocabularies outside of the Factor source directory, create a " { $link "factor-boot-rc" } " file like the following:"
{ $code
"USING: namespaces sequences vocabs.loader ;"
"\"/home/jane/sources/\" vocab-roots get push"

View File

@ -1,9 +1,9 @@
! Unit tests for vocabs.loader vocabulary
IN: vocabs.loader.tests
USING: vocabs.loader tools.test continuations vocabs math
kernel arrays sequences namespaces io.streams.string
parser source-files words assocs classes.tuple definitions
debugger compiler.units tools.vocabs accessors eval ;
debugger compiler.units tools.vocabs accessors eval
combinators ;
! This vocab should not exist, but just in case...
[ ] [
@ -151,3 +151,8 @@ forget-junk
[ "xabbabbja" forget-vocab ] with-compilation-unit
forget-junk
[ ] [ [ "vocabs.loader.test.e" forget-vocab ] with-compilation-unit ] unit-test
[ "vocabs.loader.test.e" require ]
[ relative-overflow? ] must-fail-with

View File

@ -55,7 +55,7 @@ SYMBOL: load-help?
f over set-vocab-source-loaded?
[ vocab-source-path [ parse-file ] [ [ ] ] if* ] keep
t swap set-vocab-source-loaded?
[ % ] [ call ] if-bootstrapping ;
[ % ] [ assert-depth ] if-bootstrapping ;
: load-docs ( vocab -- vocab )
load-help? get [

View File

@ -0,0 +1 @@
1 2 3

View File

@ -0,0 +1 @@
unportable

View File

@ -13,19 +13,19 @@ VAR: rule VAR: rule-number
: init-rule ( -- ) 8 <hashtable> >rule ;
: rule-keys ( -- array )
{ { 1 1 1 }
{ 1 1 0 }
{ 1 0 1 }
{ 1 0 0 }
{ 0 1 1 }
{ 0 1 0 }
{ 0 0 1 }
{ 0 0 0 } } ;
{ { 1 1 1 }
{ 1 1 0 }
{ 1 0 1 }
{ 1 0 0 }
{ 0 1 1 }
{ 0 1 0 }
{ 0 0 1 }
{ 0 0 0 } } ;
: rule-values ( n -- seq ) >bin 8 CHAR: 0 pad-left string>digits ;
: set-rule ( n -- )
dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! step-capped-line
@ -37,7 +37,7 @@ dup >rule-number rule-values rule-keys [ rule> set-at ] 2each ;
: cap-line ( line -- 0-line-0 ) { 0 } prepend { 0 } append ;
: wrap-line ( a-line-z -- za-line-za )
dup peek 1array swap dup first 1array append append ;
dup peek 1array swap dup first 1array append append ;
: step-line ( line -- new-line ) 3 <clumps> [ pattern>state ] map ;
@ -61,8 +61,8 @@ VARS: width height ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: interesting ( -- seq )
{ 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
{ 18 22 26 30 41 45 54 60 73 75 82 86 89 90 97 101 102 105 106 107 109
110 120 121 122 124 126 129 137 146 147 149 150 151 153 154 161 165 } ;
: mild ( -- seq ) { 6 9 11 57 62 74 118 } ;
@ -75,7 +75,7 @@ VAR: bitmap
VAR: last-line
: run-rule ( -- )
last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -39,10 +39,10 @@ VAR: slate
! Call a 'model' quotation with the current 'view'.
: with-view ( quot -- )
slate> rect-dim first >width
slate> rect-dim second >height
call
slate> relayout-1 ;
slate> rect-dim first >width
slate> rect-dim second >height
call
slate> relayout-1 ;
! Create a quotation that is appropriate for buttons and gesture handler.

View File

@ -1,10 +1,10 @@
USING: benchmark.regex-dna io io.files io.encodings.ascii
io.streams.string kernel tools.test ;
io.streams.string kernel tools.test splitting ;
IN: benchmark.regex-dna.tests
[ t ] [
"resource:extra/benchmark/regex-dna/regex-dna-test-in.txt"
[ regex-dna ] with-string-writer
[ regex-dna ] with-string-writer <string-reader> lines
"resource:extra/benchmark/regex-dna/regex-dna-test-out.txt"
ascii file-contents =
ascii file-lines =
] unit-test

View File

@ -43,19 +43,19 @@ VAR: separation-radius
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init-variables ( -- )
1.0 >cohesion-weight
1.0 >alignment-weight
1.0 >separation-weight
1.0 >cohesion-weight
1.0 >alignment-weight
1.0 >separation-weight
75 >cohesion-radius
50 >alignment-radius
25 >separation-radius
75 >cohesion-radius
50 >alignment-radius
25 >separation-radius
180 >cohesion-view-angle
180 >alignment-view-angle
180 >separation-view-angle
180 >cohesion-view-angle
180 >alignment-view-angle
180 >separation-view-angle
10 >time-slice ;
10 >time-slice ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! random-boid and random-boids
@ -76,14 +76,14 @@ VAR: separation-radius
: constrain ( n a b -- n ) rot min max ;
: angle-between ( vec vec -- angle )
2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
2dup v. -rot norm swap norm * / -1 1 constrain acos rad>deg ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
: relative-angle ( self other -- angle )
over vel>> -rot relative-position angle-between ;
over vel>> -rot relative-position angle-between ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -189,13 +189,12 @@ boids> [ within-alignment-neighborhood? ] with filter ;
: above? ( n a b -- ? ) nip > ;
: wrap ( n a b -- n )
{ { [ 3dup below? ]
[ 2nip ] }
{ [ 3dup above? ]
[ drop nip ] }
{ [ t ]
[ 2drop ] } }
cond ;
{
{ [ 3dup below? ] [ 2nip ] }
{ [ 3dup above? ] [ drop nip ] }
{ [ t ] [ 2drop ] }
}
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

View File

@ -1,6 +1,6 @@
USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
mortar random-weighted cfdg ;
random-weighted cfdg ;
IN: cfdg.models.game1-turn6

View File

@ -1,6 +1,6 @@
USING: kernel namespaces math opengl.gl opengl.glu ui ui.gadgets.slate
mortar random-weighted cfdg ;
random-weighted cfdg ;
IN: cfdg.models.sierpinski

View File

@ -7,7 +7,7 @@ IN: contributors
: changelog ( -- authors )
image parent-directory [
"git-log --pretty=format:%an" ascii <process-reader> lines
"git log --pretty=format:%an" ascii <process-reader> lines
] with-directory ;
: patch-counts ( authors -- assoc )

View File

@ -7,10 +7,11 @@ namespaces make sequences ftp io.unix.launcher.parser
unicode.case splitting assocs classes io.servers.connection
destructors calendar io.timeouts io.streams.duplex threads
continuations math concurrency.promises byte-arrays
io.backend sequences.lib tools.hexdump io.files.listing ;
io.backend sequences.lib tools.hexdump io.files.listing
io.streams.string ;
IN: ftp.server
TUPLE: ftp-client url mode state command-promise ;
TUPLE: ftp-client url mode state command-promise user password ;
: <ftp-client> ( url -- ftp-client )
ftp-client new
@ -140,16 +141,16 @@ ERROR: type-error type ;
150 "Here comes the directory listing." server-response ;
: finish-directory ( -- )
226 "Opening " server-response ;
226 "Directory send OK." server-response ;
GENERIC: service-command ( stream obj -- )
M: ftp-list service-command ( stream obj -- )
drop
start-directory
[
start-directory [
utf8 encode-output
directory. [ ftp-send ] each
[ current-directory get directory. ] with-string-writer string-lines
harvest [ ftp-send ] each
] with-output-stream
finish-directory ;

View File

@ -0,0 +1 @@
Slava Pestov

View File

@ -0,0 +1 @@
Slides from a talk at Galois by Slava Pestov, October 2008

View File

@ -0,0 +1 @@
demos

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