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

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

db4
Joe Groff 2009-05-23 08:39:17 -05:00
parent 3061cea61f 6061b68b0d
commit 8e06eab2f2
13 changed files with 102 additions and 33 deletions
core
extra
webapps/mason
websites/concatenative

24
basis/checksums/md5/md5.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io io.binary io.files io.streams.byte-array math
USING: alien.c-types kernel io io.binary io.files io.streams.byte-array math
math.functions math.parser namespaces splitting grouping strings
sequences byte-arrays locals sequences.private macros fry
io.encodings.binary math.bitwise checksums accessors
@ -173,9 +173,27 @@ HINTS: (process-md5-block-G) { uint-array md5-state } ;
HINTS: (process-md5-block-H) { uint-array md5-state } ;
HINTS: (process-md5-block-I) { uint-array md5-state } ;
: byte-array>le ( byte-array -- byte-array )
little-endian? [
dup 4 <sliced-groups> [
[ [ 1 2 ] dip exchange-unsafe ]
[ [ 0 3 ] dip exchange-unsafe ] bi
] each
] unless ;
: byte-array>uint-array-le ( byte-array -- uint-array )
byte-array>le byte-array>uint-array ;
HINTS: byte-array>uint-array-le byte-array ;
: uint-array>byte-array-le ( uint-array -- byte-array )
underlying>> byte-array>le ;
HINTS: uint-array>byte-array-le uint-array ;
M: md5-state checksum-block ( block state -- )
[
[ byte-array>uint-array ] [ state>> ] bi* {
[ byte-array>uint-array-le ] [ state>> ] bi* {
[ (process-md5-block-F) ]
[ (process-md5-block-G) ]
[ (process-md5-block-H) ]
@ -185,7 +203,7 @@ M: md5-state checksum-block ( block state -- )
nip update-md5
] 2bi ;
: md5>checksum ( md5 -- bytes ) state>> underlying>> ;
: md5>checksum ( md5 -- bytes ) state>> uint-array>byte-array-le ;
M: md5-state clone ( md5 -- new-md5 )
call-next-method

4
basis/io/monitors/monitors-docs.factor
View File

@ -112,10 +112,10 @@ $nl
{ $code
"USE: io.monitors"
": watch-loop ( monitor -- )"
" dup next-change . nl nl flush watch-loop ;"
" dup next-change path>> print nl nl flush watch-loop ;"
""
": watch-directory ( path -- )"
" [ t [ watch-loop ] with-monitor ] with-monitors"
" [ t [ watch-loop ] with-monitor ] with-monitors ;"
} ;
ABOUT: "io.monitors"

3
basis/io/monitors/monitors.factor
View File

@ -60,9 +60,6 @@ SYMBOL: +rename-file+
: run-monitor ( path recursive? quot -- )
'[ [ @ t ] loop ] with-monitor ; inline
: spawn-monitor ( path recursive? quot -- )
[ '[ _ _ _ run-monitor ] ] [ 2drop "Monitoring " prepend ] 3bi
spawn drop ;
{
{ [ os macosx? ] [ "io.monitors.macosx" require ] }
{ [ os linux? ] [ "io.monitors.linux" require ] }

8
basis/random/windows/windows.factor
View File

@ -1,7 +1,7 @@
USING: accessors alien.c-types byte-arrays
combinators.short-circuit continuations destructors init kernel
locals namespaces random windows.advapi32 windows.errors
windows.kernel32 ;
windows.kernel32 math.bitwise ;
IN: random.windows
TUPLE: windows-rng provider type ;
@ -25,7 +25,8 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer"
CryptAcquireContextW handle swap ;
: acquire-crypto-context ( provider type -- handle )
0 (acquire-crypto-context)
CRYPT_MACHINE_KEYSET
(acquire-crypto-context)
0 = [
GetLastError NTE_BAD_KEYSET =
[ drop f ] [ win32-error-string throw ] if
@ -34,7 +35,8 @@ CONSTANT: factor-crypto-container "FactorCryptoContainer"
] if ;
: create-crypto-context ( provider type -- handle )
CRYPT_NEWKEYSET (acquire-crypto-context) win32-error=0/f *void* ;
{ CRYPT_MACHINE_KEYSET CRYPT_NEWKEYSET } flags
(acquire-crypto-context) win32-error=0/f *void* ;
ERROR: acquire-crypto-context-failed provider type ;

25
basis/tuple-arrays/tuple-arrays-docs.factor Normal file
View File

@ -0,0 +1,25 @@
IN: tuple-arrays
USING: help.markup help.syntax sequences ;
HELP: TUPLE-ARRAY:
{ $syntax "TUPLE-ARRAY: class" }
{ $description "Generates a new data type in the current vocabulary named " { $snippet { $emphasis "class" } "-array" } " for holding instances of " { $snippet "class" } ", which must be a tuple class word. Together with the class itself, this also generates words named " { $snippet "<" { $emphasis "class" } "-array>" } " and " { $snippet ">" { $emphasis "class" } "-array" } ", for creating new instances of this tuple array type." } ;
ARTICLE: "tuple-arrays" "Tuple arrays"
"The " { $vocab-link "tuple-arrays" } " vocabulary implements space-efficient unboxed tuple arrays. Whereas an ordinary array of tuples would consist of pointers to heap-allocated objects, a tuple array stores its elements inline. Calling " { $link nth } " copies an element into a new tuple, and calling " { $link set-nth } " copies an existing tuple's slots into an array."
$nl
"Since value semantics differ from reference semantics, it is best to use tuple arrays with tuples where all slots are declared " { $link read-only } "."
$nl
"Tuple arrays should not be used with inheritance; storing an instance of a subclass in a tuple array will slice off the subclass slots, and getting the same value out again will yield an instance of the superclass. Also, tuple arrays do not get updated if tuples are redefined to add or remove slots, so caution should be exercised when doing interactive development on code that uses tuple arrays."
{ $subsection POSTPONE: TUPLE-ARRAY: }
"An example:"
{ $example
"USE: tuple-arrays"
"IN: scratchpad"
"TUPLE: point x y ;"
"TUPLE-ARRAY: point"
"{ T{ point f 1 2 } T{ point f 1 3 } T{ point f 2 3 } } >point-array first short."
"T{ point f 1 2 }"
} ;
ABOUT: "tuple-arrays"

2
basis/tuple-arrays/tuple-arrays.factor
View File

@ -21,7 +21,7 @@ MACRO: infer-in ( class -- quot ) infer in>> '[ _ ] ;
[ new ] [ smart-tuple>array ] bi ; inline
: tuple-slice ( n seq -- slice )
[ n>> [ * dup ] keep + ] [ seq>> ] bi { array } declare slice boa ; inline
[ n>> [ * dup ] keep + ] [ seq>> ] bi slice boa ; inline
: read-tuple ( slice class -- tuple )
'[ _ boa-unsafe ] input<sequence-unsafe ; inline

11
core/parser/parser-tests.factor
View File

@ -618,4 +618,13 @@ EXCLUDE: qualified.tests.bar => x ;
[
"USE: kernel UNUSE: kernel dup" <string-reader> "unuse-test" parse-stream
] [ error>> error>> error>> no-word-error? ] must-fail-with
] [ error>> error>> error>> no-word-error? ] must-fail-with
[ ] [ [ "vocabs.loader.test.l" forget-vocab ] with-compilation-unit ] unit-test
[
[ "vocabs.loader.test.l" use-vocab ] must-fail
[ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> key? ] unit-test
[ ] [ "vocabs.loader.test.l" unuse-vocab ] unit-test
[ f ] [ "vocabs.loader.test.l" manifest get search-vocab-names>> key? ] unit-test
] with-file-vocabs

4
core/vocabs/loader/test/l/l.factor Normal file
View File

@ -0,0 +1,4 @@
IN: vocabs.loader.test.l
USE: kernel
"Oops" throw

1
core/vocabs/loader/test/l/tags.txt Normal file
View File

@ -0,0 +1 @@
unportable

4
core/vocabs/parser/parser.factor
View File

@ -108,8 +108,8 @@ TUPLE: no-current-vocab ;
dup using-vocab?
[ vocab-name "Already using ``" "'' vocabulary" surround note. ] [
manifest get
[ [ vocab-name ] dip search-vocab-names>> conjoin ]
[ [ load-vocab ] dip search-vocabs>> push ]
[ [ vocab-name ] dip search-vocab-names>> conjoin ]
2bi
] if ;
@ -121,8 +121,8 @@ TUPLE: no-current-vocab ;
: unuse-vocab ( vocab -- )
dup using-vocab? [
manifest get
[ [ vocab-name ] dip search-vocab-names>> delete-at ]
[ [ load-vocab ] dip search-vocabs>> delq ]
[ [ vocab-name ] dip search-vocab-names>> delete-at ]
2bi
] [ drop ] if ;

8
extra/webapps/mason/download.xml
View File

@ -1,12 +1,18 @@
<?xml version='1.0' ?>
<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">
<t:chloe xmlns:t="http://factorcode.org/chloe/1.0">
<html>
<html xmlns="http://www.w3.org/1999/xhtml">
<head>
<link rel="stylesheet" href="http://factorcode.org/css/master.css" type="text/css" media="screen" title="no title" charset="utf-8" />
<title>Factor binary package for <t:label t:name="platform" /></title>
</head>
<body>
<div><img src="http://factorcode.org/graphics/logo.png" alt="Logo" /></div>
<h1>Factor binary package for <t:label t:name="platform" /></h1>
<p>Requirements:</p>

37
extra/webapps/mason/mason.factor
View File

@ -15,18 +15,19 @@ TUPLE: mason-app < dispatcher ;
: download-link ( builder label -- xml )
[
[ URL" download" ] dip
[ URL" http://builds.factorcode.org/download" ] dip
[ os>> "os" set-query-param ]
[ cpu>> "cpu" set-query-param ] bi
] dip link ;
: download-grid-cell ( cpu os -- xml )
builder new swap >>os swap >>cpu select-tuple dup
[
builder new swap >>os swap >>cpu select-tuple [
dup last-release>> dup
[ "." split1 drop 16 tail* 6 head* download-link ] [ 2drop f ] if
] when
[XML <td><-></td> XML] ;
[XML <td class="supported"><div class="bigdiv"><-></div></td> XML]
] [
[XML <td class="doesnotexist" /> XML]
] if* ;
CONSTANT: oses
{
@ -47,22 +48,26 @@ CONSTANT: cpus
: download-grid ( -- xml )
oses
[ values [ [XML <th><-></th> XML] ] map ]
[ values [ [XML <th align='center' scope='col'><-></th> XML] ] map ]
[
keys
cpus [
[ nip second ] [ first ] 2bi [
swap download-grid-cell
] curry map [XML <tr><th><-></th><-></tr> XML]
] curry map
[XML <tr><th align='center' scope='row'><-></th><-></tr> XML]
] with map
] bi [XML <table><tr><th/><-></tr><-></table> XML] ;
] bi
[XML
<table id="downloads" cellspacing="0">
<tr><th class="nobg">OS/CPU</th><-></tr>
<->
</table>
XML] ;
: <download-grid-action> ( -- action )
<action>
[
download-grid
xml>string "text/html" <content>
] >>display ;
[ download-grid xml>string "text/html" <content> ] >>display ;
: validate-os/cpu ( -- )
{
@ -132,16 +137,16 @@ CONSTANT: cpus
os>> {
{ "winnt" "Windows XP (also tested on Vista)" }
{ "macosx" "Mac OS X 10.5 Leopard" }
{ "linux" "Linux 2.6.16 with GLIBC 2.4" }
{ "linux" "Ubuntu Linux 9.04 (other distributions may also work)" }
{ "freebsd" "FreeBSD 7.0" }
{ "netbsd" "NetBSD 4.0" }
{ "openbsd" "OpenBSD 4.2" }
{ "openbsd" "OpenBSD 4.4" }
} at
] [
dup cpu>> "x86.32" = [
os>> {
{ [ dup { "winnt" "linux" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
{ [ dup { "freebsd" "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
{ [ dup { "winnt" "linux" "freebsd" } member? ] [ drop "Intel Pentium 4, Core Duo, or other x86 chip with SSE2 support. Note that 32-bit Athlon XP processors do not support SSE2." ] }
{ [ dup { "netbsd" "openbsd" } member? ] [ drop "Intel Pentium Pro or better" ] }
{ [ t ] [ drop f ] }
} cond
] [ drop f ] if

4
extra/websites/concatenative/concatenative.factor
View File

@ -23,7 +23,8 @@ webapps.pastebin
webapps.planet
webapps.wiki
webapps.user-admin
webapps.help ;
webapps.help
webapps.mason ;
IN: websites.concatenative
: test-db ( -- db ) "resource:test.db" <sqlite-db> ;
@ -95,6 +96,7 @@ SYMBOL: dh-file
<planet> <login-config> <factor-boilerplate> test-db <alloy> "planet.factorcode.org" add-responder
home "docs" append-path <help-webapp> test-db <alloy> "docs.factorcode.org" add-responder
home "cgi" append-path <gitweb> "gitweb.factorcode.org" add-responder
<mason-app> "builds.factorcode.org" add-responder
main-responder set-global ;
: <factor-secure-config> ( -- config )