steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

db4
Aaron Schaefer 2008-11-18 16:05:54 -05:00
parent 197bb70893 5d2ee2f4a3
commit a1a79aac16
57 changed files with 474 additions and 303 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
basis/alien/c-types/c-types.factor
View File

@ -436,6 +436,6 @@ M: long-long-type box-return ( type -- )
"double" define-primitive-type "double" define-primitive-type
"long" "ptrdiff_t" typedef "long" "ptrdiff_t" typedef
"long" "intptr_t" typedef
"ulong" "size_t" typedef "ulong" "size_t" typedef
] with-compilation-unit ] with-compilation-unit

4
basis/bootstrap/image/download/download.factor
View File

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

2
basis/compiler/compiler-docs.factor
View File

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

3
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 ; compiler.cfg.registers cpu.architecture cpu.x86.assembler cpu.x86 ;
IN: cpu.x86.64.winnt IN: cpu.x86.64.winnt
@ -22,6 +22,7 @@ M: x86.64 dummy-fp-params? t ;
<< <<
"longlong" "ptrdiff_t" typedef "longlong" "ptrdiff_t" typedef
"longlong" "intptr_t" typedef
"int" "long" typedef "int" "long" typedef
"uint" "ulong" typedef "uint" "ulong" typedef
>> >>

2
basis/freetype/freetype.factor
View File

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

2
basis/furnace/furnace-docs.factor
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." } ; { $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" 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 $nl
"Responders can implement methods on the following generic words:" "Responders can implement methods on the following generic words:"
{ $subsection modify-query } { $subsection modify-query }

6
basis/help/html/html.factor
View File

@ -115,10 +115,10 @@ M: result link-href href>> ;
[ [ title>> ] compare ] sort ; [ [ title>> ] compare ] sort ;
: article-apropos ( string -- results ) : article-apropos ( string -- results )
"articles.idx" temp-file offline-apropos ; "articles.idx" offline-apropos ;
: word-apropos ( string -- results ) : word-apropos ( string -- results )
"words.idx" temp-file offline-apropos ; "words.idx" offline-apropos ;
: vocab-apropos ( string -- results ) : vocab-apropos ( string -- results )
"vocabs.idx" temp-file offline-apropos ; "vocabs.idx" offline-apropos ;

6
basis/html/templates/fhtml/fhtml-tests.factor
View File

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

2
basis/io/files/listing/listing-tests.factor
View File

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

30
basis/io/servers/connection/connection.factor
View File

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

314
basis/io/windows/nt/launcher/launcher-tests.factor
View File

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

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

2
basis/locals/locals.factor
View File

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

10
basis/math/bitwise/bitwise.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math math.functions sequences USING: arrays kernel math math.functions sequences
sequences.private words namespaces macros hints sequences.private words namespaces macros hints
combinators fry ; combinators fry io.binary ;
IN: math.bitwise IN: math.bitwise
! utilities ! utilities
@ -93,3 +93,11 @@ PRIVATE>
: bit-count ( x -- n ) : bit-count ( x -- n )
dup 0 < [ bitnot ] when (bit-count) ; inline 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> ;

13
basis/math/polynomials/polynomials-docs.factor
View File

@ -40,7 +40,7 @@ HELP: ptrim
HELP: 2ptrim HELP: 2ptrim
{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } } { $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
{ $description "Trims excess zeros from two polynomials." } { $description "Trims excess zeros from two polynomials." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim swap . ." "{ 0 1 }\n{ 1 }" } } ; { $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 0 1 0 0 } { 1 0 0 } 2ptrim [ . ] bi@" "{ 0 1 }\n{ 1 }" } } ;
HELP: p+ HELP: p+
{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } } { $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
@ -60,7 +60,7 @@ HELP: n*p
HELP: pextend-conv HELP: pextend-conv
{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } } { $values { "p" "a polynomial" } { "q" "a polynomial" } { "p" "a polynomial" } { "q" "a polynomial" } }
{ $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." } { $description "Convulution, extending to " { $snippet "p_m + q_n - 1" } "." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv swap . ." "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ; { $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 0 1 } { 0 1 } pextend-conv [ . ] bi@" "V{ 1 0 1 0 }\nV{ 0 1 0 0 }" } } ;
HELP: p* HELP: p*
{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } } { $values { "p" "a polynomial" } { "q" "a polynomial" } { "r" "a polynomial" } }
@ -75,13 +75,18 @@ HELP: p-sq
HELP: p/mod HELP: p/mod
{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } } { $values { "p" "a polynomial" } { "q" "a polynomial" } { "z" "a polynomial" } { "w" "a polynomial" } }
{ $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." } { $description "Computes to quotient " { $snippet "z" } " and remainder " { $snippet "w" } " of dividing " { $snippet "p" } " by " { $snippet "q" } "." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 1 } { 3 1 } p/mod swap . ." "V{ 7 -2 1 }\nV{ -20 0 0 }" } } ; { $examples { $example "USING: kernel math.polynomials prettyprint ;" "{ 1 1 1 1 } { 3 1 } p/mod [ . ] bi@" "V{ 7 -2 1 }\nV{ -20 0 0 }" } } ;
HELP: pgcd HELP: pgcd
{ $values { "p" "a polynomial" } { "q" "a polynomial" } { "a" "a polynomial" } { "d" "a polynomial" } } { $values { "p" "a polynomial" } { "q" "a polynomial" } { "a" "a polynomial" } { "d" "a polynomial" } }
{ $description "Computes the greatest common divisor " { $snippet "d" } " of " { $snippet "p" } " and " { $snippet "q" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*q = d mod p" } } { $description "Computes the greatest common divisor " { $snippet "d" } " of " { $snippet "p" } " and " { $snippet "q" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*q = d mod p" } }
{ $notes "GCD in the case of polynomials is a monic polynomial of the highest possible degree that divides into both " { $snippet "p" } " and " { $snippet "q" } "." } { $notes "GCD in the case of polynomials is a monic polynomial of the highest possible degree that divides into both " { $snippet "p" } " and " { $snippet "q" } "." }
{ $examples { $example "USING: math.polynomials prettyprint ;" "{ 1 1 1 1} { 1 1 } pgcd swap . ." "{ 0 0 }\n{ 1 1 }" } } ; { $examples
{ $example "USING: kernel math.polynomials prettyprint ;"
"{ 1 1 1 1 } { 1 1 } pgcd [ . ] bi@"
"{ 0 0 }\n{ 1 1 }"
}
} ;
HELP: pdiff HELP: pdiff
{ $values { "p" "a polynomial" } { "p'" "a polynomial" } } { $values { "p" "a polynomial" } { "p'" "a polynomial" } }

9
basis/opengl/opengl.factor
View File

@ -64,7 +64,8 @@ MACRO: all-enabled-client-state ( seq quot -- )
[ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline [ 2 GL_FLOAT 0 ] dip glTexCoordPointer ; inline
: line-vertices ( a b -- ) : 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 -- ) : gl-line ( a b -- )
line-vertices GL_LINES 0 2 glDrawArrays ; line-vertices GL_LINES 0 2 glDrawArrays ;
@ -72,9 +73,9 @@ MACRO: all-enabled-client-state ( seq quot -- )
: (rect-vertices) ( dim -- vertices ) : (rect-vertices) ( dim -- vertices )
{ {
[ drop 0.5 0.5 ] [ drop 0.5 0.5 ]
[ first 0.5 - 0.5 ] [ first 0.3 - 0.5 ]
[ [ first 0.5 - ] [ second 0.5 - ] bi ] [ [ first 0.3 - ] [ second 0.3 - ] bi ]
[ second 0.5 - 0.5 swap ] [ second 0.3 - 0.5 swap ]
} cleave 8 narray >c-float-array ; } cleave 8 narray >c-float-array ;
: rect-vertices ( dim -- ) : rect-vertices ( dim -- )

2
basis/regexp/parser/parser.factor
View File

@ -137,7 +137,7 @@ ERROR: bad-special-group string ;
DEFER: (parse-regexp) DEFER: (parse-regexp)
: nested-parse-regexp ( token ? -- ) : nested-parse-regexp ( token ? -- )
[ push-stack (parse-regexp) pop-stack ] dip [ 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 ! non-capturing groups
: (parse-special-group) ( -- ) : (parse-special-group) ( -- )

3
basis/regexp/regexp-tests.factor
View File

@ -2,6 +2,9 @@ USING: regexp tools.test kernel sequences regexp.parser
regexp.traversal eval ; regexp.traversal eval ;
IN: regexp-tests IN: regexp-tests
\ <regexp> must-infer
\ matches? must-infer
[ f ] [ "b" "a*" <regexp> matches? ] unit-test [ f ] [ "b" "a*" <regexp> matches? ] unit-test
[ t ] [ "" "a*" <regexp> matches? ] unit-test [ t ] [ "" "a*" <regexp> matches? ] unit-test
[ t ] [ "a" "a*" <regexp> matches? ] unit-test [ t ] [ "a" "a*" <regexp> matches? ] unit-test

3
basis/regexp/traversal/traversal.factor
View File

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

4
basis/regexp/utils/utils-tests.factor Normal file
View File

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

4
basis/regexp/utils/utils.factor
View File

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

4
basis/ui/gadgets/buttons/buttons.factor
View File

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

2
basis/ui/gadgets/editors/editors.factor
View File

@ -112,7 +112,7 @@ M: editor ungraft*
line-height * ; line-height * ;
: caret-loc ( editor -- loc ) : caret-loc ( editor -- loc )
[ editor-caret* ] keep 2dup loc>x 1+ [ editor-caret* ] keep 2dup loc>x
rot first rot line>y 2array ; rot first rot line>y 2array ;
: caret-dim ( editor -- dim ) : caret-dim ( editor -- dim )

2
basis/ui/gadgets/grid-lines/grid-lines.factor
View File

@ -27,7 +27,7 @@ M: grid-lines draw-boundary
dup grid set dup grid set
dup rect-dim half-gap v- grid-dim set dup rect-dim half-gap v- grid-dim set
compute-grid compute-grid
[ { 1 0 } draw-grid-lines ] [ { -0.5 -0.5 } gl-translate { 1 0 } draw-grid-lines ]
[ [
{ 0.5 -0.5 } gl-translate { 0.5 -0.5 } gl-translate
{ 0 1 } draw-grid-lines { 0 1 } draw-grid-lines

4
basis/ui/tools/listener/listener.factor
View File

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

6
basis/unix/groups/groups.factor
View File

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

6
basis/unix/users/users.factor
View File

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

10
basis/windows/kernel32/kernel32.factor
View File

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

9
basis/windows/types/types.factor
View File

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

7
core/io/io-tests.factor
View File

@ -25,6 +25,11 @@ IN: io.tests
! Make sure we use correct to_c_string form when writing ! Make sure we use correct to_c_string form when writing
[ ] [ "\0" write ] unit-test [ ] [ "\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 } { "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> [ latin1 <file-reader> [
"J" read-until 2array , "J" read-until 2array ,
"i" read-until 2array , "i" read-until 2array ,

1
core/io/test/separator-test.txt
View File

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

6
extra/benchmark/regex-dna/regex-dna-tests.factor
View File

@ -1,10 +1,10 @@
USING: benchmark.regex-dna io io.files io.encodings.ascii 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 IN: benchmark.regex-dna.tests
[ t ] [ [ t ] [
"resource:extra/benchmark/regex-dna/regex-dna-test-in.txt" "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" "resource:extra/benchmark/regex-dna/regex-dna-test-out.txt"
ascii file-contents = ascii file-lines =
] unit-test ] unit-test

15
extra/boids/boids.factor
View File

@ -83,7 +83,7 @@ VAR: separation-radius
: relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ; : relative-position ( self other -- v ) swap [ pos>> ] bi@ v- ;
: relative-angle ( self other -- angle ) : 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 > ; : above? ( n a b -- ? ) nip > ;
: wrap ( n a b -- n ) : wrap ( n a b -- n )
{ { [ 3dup below? ] {
[ 2nip ] } { [ 3dup below? ] [ 2nip ] }
{ [ 3dup above? ] { [ 3dup above? ] [ drop nip ] }
[ drop nip ] } { [ t ] [ 2drop ] }
{ [ t ] }
[ 2drop ] } } cond ;
cond ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

2
extra/contributors/contributors.factor
View File

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

13
extra/ftp/server/server.factor
View File

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

1
extra/galois-talk/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
extra/galois-talk/summary.txt Normal file
View File

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

1
extra/galois-talk/tags.txt Normal file
View File

@ -0,0 +1 @@
demos

1
extra/google-tech-talk/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
extra/google-tech-talk/summary.txt Normal file
View File

@ -0,0 +1 @@
Slides from Google Tech Talk by Slava Pestov, October 2008

1
extra/google-tech-talk/tags.txt Normal file
View File

@ -0,0 +1 @@
demos

14
extra/graphics/bitmap/bitmap.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2007 Doug Coleman. ! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays byte-arrays combinators summary USING: alien arrays byte-arrays combinators summary io.backend
io.backend graphics.viewer io io.binary io.files kernel libc graphics.viewer io io.binary io.files kernel libc math
math math.functions namespaces opengl opengl.gl prettyprint math.functions math.bitwise namespaces opengl opengl.gl
sequences strings ui ui.gadgets.panes io.encodings.binary prettyprint sequences strings ui ui.gadgets.panes
accessors grouping ; io.encodings.binary accessors grouping ;
IN: graphics.bitmap IN: graphics.bitmap
! Currently can only handle 24bit bitmaps. ! Currently can only handle 24bit bitmaps.
@ -56,8 +56,8 @@ M: bitmap-magic summary
: parse-bitmap-header ( bitmap -- ) : parse-bitmap-header ( bitmap -- )
4 read le> >>header-length 4 read le> >>header-length
4 read le> >>width 4 read signed-le> >>width
4 read le> >>height 4 read signed-le> >>height
2 read le> >>planes 2 read le> >>planes
2 read le> >>bit-count 2 read le> >>bit-count
4 read le> >>compression 4 read le> >>compression

4
extra/hardware-info/windows/windows.factor
View File

@ -18,7 +18,7 @@ IN: hardware-info.windows
: processor-architecture ( -- n ) : processor-architecture ( -- n )
system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ; system-info SYSTEM_INFO-dwOemId HEX: ffff0000 bitand ;
: os-version : os-version ( -- os-version )
"OSVERSIONINFO" <c-object> "OSVERSIONINFO" <c-object>
"OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize "OSVERSIONINFO" heap-size over set-OSVERSIONINFO-dwOSVersionInfoSize
[ GetVersionEx ] keep swap zero? [ win32-error ] when ; [ GetVersionEx ] keep swap zero? [ win32-error ] when ;
@ -67,4 +67,4 @@ IN: hardware-info.windows
{ {
{ [ os wince? ] [ "hardware-info.windows.ce" ] } { [ os wince? ] [ "hardware-info.windows.ce" ] }
{ [ os winnt? ] [ "hardware-info.windows.nt" ] } { [ os winnt? ] [ "hardware-info.windows.nt" ] }
} cond [ require ] when* >> } cond require >>

6
extra/mason/child/child-tests.factor
View File

@ -1,7 +1,7 @@
IN: mason.child.tests IN: mason.child.tests
USING: mason.child mason.config tools.test namespaces ; USING: mason.child mason.config tools.test namespaces ;
[ { "make" "clean" "winnt-x86-32" } ] [ [ { "make" "winnt-x86-32" } ] [
[ [
"winnt" target-os set "winnt" target-os set
"x86.32" target-cpu set "x86.32" target-cpu set
@ -9,7 +9,7 @@ USING: mason.child mason.config tools.test namespaces ;
] with-scope ] with-scope
] unit-test ] unit-test
[ { "make" "clean" "macosx-x86-32" } ] [ [ { "make" "macosx-x86-32" } ] [
[ [
"macosx" target-os set "macosx" target-os set
"x86.32" target-cpu set "x86.32" target-cpu set
@ -17,7 +17,7 @@ USING: mason.child mason.config tools.test namespaces ;
] with-scope ] with-scope
] unit-test ] unit-test
[ { "gmake" "clean" "netbsd-ppc" } ] [ [ { "gmake" "netbsd-ppc" } ] [
[ [
"netbsd" target-os set "netbsd" target-os set
"ppc" target-cpu set "ppc" target-cpu set

16
extra/mason/child/child.factor
View File

@ -2,14 +2,26 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces make debugger sequences io.files USING: kernel namespaces make debugger sequences io.files
io.launcher arrays accessors calendar continuations io.launcher arrays accessors calendar continuations
combinators.short-circuit mason.common mason.report mason.platform ; combinators.short-circuit mason.common mason.report
mason.platform mason.config http.client ;
IN: mason.child IN: mason.child
: make-cmd ( -- args ) : make-cmd ( -- args )
[ gnu-make , "clean" , platform , ] { } make ; gnu-make platform 2array ;
: download-dlls ( -- )
target-os get "winnt" = [
"http://factorcode.org/dlls/"
target-cpu get "x86.64" = [ "64/" append ] when
[ "freetype6.dll" append ]
[ "zlib1.dll" append ] bi
[ download ] bi@
] when ;
: make-vm ( -- ) : make-vm ( -- )
"factor" [ "factor" [
download-dlls
<process> <process>
make-cmd >>command make-cmd >>command
"../compile-log" >>stdout "../compile-log" >>stdout

12
extra/slides/slides.factor
View File

@ -48,19 +48,17 @@ IN: slides
: $divider ( -- ) : $divider ( -- )
[ [
<gadget> <gadget>
T{ gradient f {
{ T{ rgba f 0.25 0.25 0.25 1.0 }
T{ rgba f 0.25 0.25 0.25 1.0 } T{ rgba f 1.0 1.0 1.0 0.0 }
T{ rgba f 1.0 1.0 1.0 0.0 } } <gradient> >>interior
}
} >>interior
{ 800 10 } >>dim { 800 10 } >>dim
{ 1 0 } >>orientation { 1 0 } >>orientation
gadget. gadget.
] ($block) ; ] ($block) ;
: page-theme ( gadget -- ) : page-theme ( gadget -- )
T{ gradient f { T{ rgba f 0.8 0.8 1.0 1.0 } T{ rgba f 0.8 1.0 1.0 1.0 } } } { T{ rgba f 0.8 0.8 1.0 1.0 } T{ rgba f 0.8 1.0 1.0 1.0 } } <gradient>
>>interior drop ; >>interior drop ;
: <page> ( list -- gadget ) : <page> ( list -- gadget )

BIN
extra/ui/render/test/reference.bmp Normal file
View File

Binary file not shown.
Side by Side

After

Width:  |  Height:  |  Size: 72 KiB

70
extra/ui/render/test/test.factor Normal file
View File

@ -0,0 +1,70 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors colors arrays kernel sequences math byte-arrays
namespaces cap graphics.bitmap
ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids
ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons
ui.render ui opengl opengl.gl ;
IN: ui.render.test
SINGLETON: line-test
M: line-test draw-interior
2drop { 0 0 } { 0 10 } gl-line ;
: <line-gadget> ( -- gadget )
<gadget>
line-test >>interior
{ 1 10 } >>dim ;
TUPLE: ui-render-test < pack { first-time? initial: t } ;
: message-window ( text -- )
<label> "Message" open-window ;
: check-rendering ( gadget -- )
gl-screenshot
"resource:extra/ui/render/test/reference.bmp" load-bitmap array>>
= "perfect" "needs work" ? "Your UI rendering is " prepend
message-window ;
M: ui-render-test draw-gadget*
[ call-next-method ] [
dup first-time?>> [
dup check-rendering
f >>first-time?
] when
drop
] bi ;
: <ui-render-test> ( -- gadget )
\ ui-render-test new-gadget
{ 1 0 } >>orientation
<gadget>
black <solid> >>interior
{ 98 98 } >>dim
1 <border> add-gadget
<gadget>
gray <solid> >>boundary
{ 94 94 } >>dim
3 <border>
red <solid> >>boundary
add-gadget
<line-gadget> <line-gadget> <line-gadget> 3array
<line-gadget> <line-gadget> <line-gadget> 3array
<line-gadget> <line-gadget> <line-gadget> 3array
3array <grid>
{ 5 5 } >>gap
blue <grid-lines> >>boundary
add-gadget
<gadget>
{ 14 14 } >>dim
black <checkmark-paint> >>interior
black <solid> >>boundary
4 <border>
add-gadget ;
: ui-render-test ( -- )
<ui-render-test> "Test" open-window ;
MAIN: ui-render-test

2
extra/update/latest/latest.factor
View File

@ -9,7 +9,7 @@ IN: update.latest
: git-pull-master ( -- ) : git-pull-master ( -- )
image parent-directory image parent-directory
[ [
{ "git" "pull" "git://factorcode.org/git/factor.git" "master" } { "git" "pull" "http://factorcode.org/git/factor.git" "master" }
run-command run-command
] ]
with-directory ; with-directory ;

1
extra/vpri-talk/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

1
extra/vpri-talk/summary.txt Normal file
View File

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

1
extra/vpri-talk/tags.txt Normal file
View File

@ -0,0 +1 @@
demos

10
extra/webapps/help/help.factor
View File

@ -16,11 +16,11 @@ TUPLE: help-webapp < dispatcher ;
{ "search" [ 1 v-min-length 50 v-max-length v-one-line ] } { "search" [ 1 v-min-length 50 v-max-length v-one-line ] }
} validate-params } validate-params
help-dir set-current-directory help-dir [
"search" value article-apropos "articles" set-value
"search" value article-apropos "articles" set-value "search" value word-apropos "words" set-value
"search" value word-apropos "words" set-value "search" value vocab-apropos "vocabs" set-value
"search" value vocab-apropos "vocabs" set-value ] with-directory
{ help-webapp "search" } <chloe-content> { help-webapp "search" } <chloe-content>
] >>submit ; ] >>submit ;

2
extra/webapps/user-admin/new-user.xml
View File

@ -37,7 +37,7 @@
<th class="field-label big-field-label">Capabilities:</th> <th class="field-label big-field-label">Capabilities:</th>
<td> <td>
<t:each t:name="capabilities"> <t:each t:name="capabilities">
<li><t:checkbox t:name="@value" t:label="@value" /><br/> <t:checkbox t:name="@value" t:label="@value" /><br/>
</t:each> </t:each>
</td> </td>
</tr> </tr>

107
misc/factor.el
View File

@ -317,10 +317,9 @@ value from the existing code in the buffer."
;;; Factor mode indentation: ;;; Factor mode indentation:
(defvar factor-indent-width factor-default-indent-width (make-variable-buffer-local
"Indentation width in factor buffers. A local variable.") (defvar factor-indent-width factor-default-indent-width
"Indentation width in factor buffers. A local variable."))
(make-variable-buffer-local 'factor-indent-width)
(defconst factor--regexp-word-start (defconst factor--regexp-word-start
(let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M"))) (let ((sws '("" ":" "TUPLE" "MACRO" "MACRO:" "M")))
@ -340,45 +339,67 @@ value from the existing code in the buffer."
(setq iw (current-indentation)))))) (setq iw (current-indentation))))))
iw)) iw))
(defun factor--brackets-depth () (defsubst factor--ppss-brackets-depth ()
"Returns number of brackets, not closed on previous lines." (nth 0 (syntax-ppss)))
(syntax-ppss-depth
(save-excursion (defsubst factor--ppss-brackets-start ()
(syntax-ppss (line-beginning-position))))) (nth 1 (syntax-ppss)))
(defsubst factor--line-indent (pos)
(save-excursion (goto-char pos) (current-indentation)))
(defconst factor--regex-closing-paren "[])}]")
(defsubst factor--at-closing-paren-p ()
(looking-at factor--regex-closing-paren))
(defsubst factor--at-first-char-p ()
(= (- (point) (line-beginning-position)) (current-indentation)))
(defconst factor--regex-single-liner
(format "^%s" (regexp-opt '("USE:" "IN:" "PRIVATE>" "<PRIVATE"))))
(defun factor--at-end-of-def ()
(or (looking-at ".*;[ \t]*$")
(looking-at factor--regex-single-liner)))
(defun factor--indent-in-brackets ()
(save-excursion
(beginning-of-line)
(when (or (and (re-search-forward factor--regex-closing-paren
(line-end-position) t)
(not (backward-char)))
(> (factor--ppss-brackets-depth) 0))
(let ((op (factor--ppss-brackets-start)))
(when (> (line-number-at-pos) (line-number-at-pos op))
(if (factor--at-closing-paren-p)
(factor--line-indent op)
(+ (factor--line-indent op) factor-indent-width)))))))
(defun factor--indent-definition ()
(save-excursion
(beginning-of-line)
(when (looking-at "\\([^ ]\\|^\\)+:") 0)))
(defun factor--indent-continuation ()
(save-excursion
(forward-line -1)
(beginning-of-line)
(if (bobp) 0
(if (looking-at "^[ \t]*$")
(factor--indent-continuation)
(if (factor--at-end-of-def)
(- (current-indentation) factor-indent-width)
(if (factor--indent-definition)
(+ (current-indentation) factor-indent-width)
(current-indentation)))))))
(defun factor--calculate-indentation () (defun factor--calculate-indentation ()
"Calculate Factor indentation for line at point." "Calculate Factor indentation for line at point."
(let ((not-indented t) (or (and (bobp) 0)
(cur-indent 0)) (factor--indent-definition)
(save-excursion (factor--indent-in-brackets)
(beginning-of-line) (factor--indent-continuation)
(if (bobp) 0))
(setq cur-indent 0)
(save-excursion
(while not-indented
;; Check that we are inside open brackets
(save-excursion
(let ((cur-depth (factor--brackets-depth)))
(forward-line -1)
(setq cur-indent (+ (current-indentation)
(* factor-indent-width
(- cur-depth (factor--brackets-depth)))))
(setq not-indented nil)))
(forward-line -1)
;; Check that we are after the end of previous word
(if (looking-at ".*;[ \t]*$")
(progn
(setq cur-indent (- (current-indentation) factor-indent-width))
(setq not-indented nil))
;; Check that we are after the start of word
(if (looking-at factor--regexp-word-start)
(progn
(message "inword")
(setq cur-indent (+ (current-indentation) factor-indent-width))
(setq not-indented nil))
(if (bobp)
(setq not-indented nil))))))))
cur-indent))
(defun factor-indent-line () (defun factor-indent-line ()
"Indent current line as Factor code" "Indent current line as Factor code"
@ -420,11 +441,15 @@ value from the existing code in the buffer."
;;; Factor listener mode ;;; Factor listener mode
;;;###autoload
(define-derived-mode factor-listener-mode comint-mode "Factor Listener") (define-derived-mode factor-listener-mode comint-mode "Factor Listener")
(define-key factor-listener-mode-map [f8] 'factor-refresh-all) (define-key factor-listener-mode-map [f8] 'factor-refresh-all)
;;;###autoload
(defun run-factor () (defun run-factor ()
"Start a factor listener inside emacs, or switch to it if it
already exists."
(interactive) (interactive)
(switch-to-buffer (switch-to-buffer
(make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil (make-comint-in-buffer "factor" nil (expand-file-name factor-binary) nil
@ -433,6 +458,8 @@ value from the existing code in the buffer."
(factor-listener-mode)) (factor-listener-mode))
(defun factor-refresh-all () (defun factor-refresh-all ()
"Reload source files and documentation for all loaded
vocabularies which have been modified on disk."
(interactive) (interactive)
(comint-send-string "*factor*" "refresh-all\n")) (comint-send-string "*factor*" "refresh-all\n"))

2
vm/math.c
View File

@ -109,7 +109,7 @@ void primitive_fixnum_shift(void)
} }
else if(y < WORD_SIZE - TAG_BITS) else if(y < WORD_SIZE - TAG_BITS)
{ {
F_FIXNUM mask = -(1L << (WORD_SIZE - 1 - TAG_BITS - y)); F_FIXNUM mask = -((F_FIXNUM)1 << (WORD_SIZE - 1 - TAG_BITS - y));
if((x > 0 && (x & mask) == 0) || (x & mask) == mask) if((x > 0 && (x & mask) == 0) || (x & mask) == mask)
{ {
dpush(tag_fixnum(x << y)); dpush(tag_fixnum(x << y));

8
vm/os-windows-nt.c
View File

@ -29,7 +29,13 @@ long exception_handler(PEXCEPTION_POINTERS pe)
signal_number = ERROR_DIVIDE_BY_ZERO; signal_number = ERROR_DIVIDE_BY_ZERO;
c->EIP = (CELL)divide_by_zero_signal_handler_impl; c->EIP = (CELL)divide_by_zero_signal_handler_impl;
} }
else /* If the Widcomm bluetooth stack is installed, the BTTray.exe process
injects code into running programs. For some reason this results in
random SEH exceptions with this (undocumented) exception code being
raised. The workaround seems to be ignoring this altogether, since that
is what happens if SEH is not enabled. Don't really have any idea what
this exception means. */
else if(e->ExceptionCode != 0x40010006)
{ {
signal_number = 11; signal_number = 11;
c->EIP = (CELL)misc_signal_handler_impl; c->EIP = (CELL)misc_signal_handler_impl;