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

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

db4
Slava Pestov 2008-02-13 18:43:47 -06:00
parent bcc7511676 35b5f222e3
commit c3b5b7cc61
12 changed files with 272 additions and 72 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

28
extra/builder/builder.factor
View File

@ -3,7 +3,7 @@ USING: kernel parser io io.files io.launcher io.sockets hashtables math threads
arrays system continuations namespaces sequences splitting math.parser
prettyprint tools.time calendar bake vars http.client
combinators bootstrap.image bootstrap.image.download
combinators.cleave ;
combinators.cleave benchmark ;
IN: builder
@ -11,6 +11,8 @@ IN: builder
: runtime ( quot -- time ) benchmark nip ;
: minutes>ms ( min -- ms ) 60 * 1000 * ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: builder-recipients
@ -97,6 +99,7 @@ VAR: stamp
} }
{ +stdout+ "../boot-log" }
{ +stderr+ +stdout+ }
{ +timeout+ ,[ 20 minutes>ms ] }
} ;
: builder-test ( -- desc ) `{ ,[ factor-binary ] "-run=builder.test" } ;
@ -145,10 +148,22 @@ SYMBOL: build-status
! bootstrap [ "Bootstrap error" print "../boot-log" cat ] run-or-bail
bootstrap <process-stream> dup dispose process-stream-process wait-for-process zero? not
[ "Bootstrap error" print "../boot-log" cat "bootstrap error" throw ]
when
! bootstrap
! <process-stream> dup dispose process-stream-process wait-for-process
! zero? not
! [ "Bootstrap error" print "../boot-log" cat "bootstrap error" throw ]
! when
[
bootstrap
<process-stream> dup dispose process-stream-process wait-for-process
zero? not
[ "bootstrap non-zero" throw ]
when
]
[ "Bootstrap error" print "../boot-log" cat "bootstrap" throw ]
recover
[ builder-test try-process ]
[ "Builder test error" print throw ]
recover
@ -160,6 +175,9 @@ SYMBOL: build-status
"Did not pass load-everything: " print "../load-everything-vocabs" cat
"Did not pass test-all: " print "../test-all-vocabs" cat
"Benchmarks: " print
"../benchmarks" [ stdio get contents eval ] with-file-in benchmarks.
] with-file-out ;
: build ( -- )
@ -168,8 +186,6 @@ SYMBOL: build-status
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: minutes>ms ( min -- ms ) 60 * 1000 * ;
: updates-available? ( -- ? )
git-id
git-pull run-process drop

7
extra/builder/test/test.factor
View File

@ -6,7 +6,7 @@ USING: kernel namespaces sequences assocs builder continuations
prettyprint
tools.browser
tools.test
bootstrap.stage2 ;
bootstrap.stage2 benchmark ;
IN: builder.test
@ -16,9 +16,12 @@ IN: builder.test
: do-tests ( -- )
run-all-tests keys "../test-all-vocabs" [ . ] with-file-out ;
: do-benchmarks ( -- ) run-benchmarks "../benchmarks" [ . ] with-file-out ;
: do-all ( -- )
bootstrap-time get "../boot-time" [ . ] with-file-out
[ do-load ] runtime "../load-time" [ . ] with-file-out
[ do-tests ] runtime "../test-time" [ . ] with-file-out ;
[ do-tests ] runtime "../test-time" [ . ] with-file-out
do-benchmarks ;
MAIN: do-all

13
extra/db/db.factor
View File

@ -15,7 +15,8 @@ TUPLE: db handle insert-statements update-statements delete-statements select-st
GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- )
: dispose-statements [ dispose drop ] assoc-each ;
: dispose-statements ( seq -- )
[ dispose drop ] assoc-each ;
: dispose-db ( db -- )
dup db [
@ -35,7 +36,13 @@ HOOK: <prepared-statement> db ( str -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- )
GENERIC: execute-statement ( statement -- )
GENERIC: execute-statement* ( statement -- result-set )
HOOK: last-id db ( res -- id )
: execute-statement ( statement -- )
execute-statement* dispose ;
: execute-statement-last-id ( statement -- id )
execute-statement* [ last-id ] with-disposal ;
: bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
@ -51,8 +58,6 @@ GENERIC: #columns ( result-set -- n )
GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- ? )
HOOK: last-id db ( -- id )
: init-result-set ( result-set -- )
dup #rows over set-result-set-max
-1 swap set-result-set-n ;

2
extra/db/postgresql/ffi/ffi.factor
View File

@ -50,6 +50,8 @@ IN: db.postgresql.ffi
: PQERRORS_DEFAULT HEX: 1 ; inline
: PQERRORS_VERBOSE HEX: 2 ; inline
: InvalidOid 0 ; inline
TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType

7
extra/db/postgresql/lib/lib.factor
View File

@ -37,8 +37,13 @@ IN: db.postgresql.lib
>r db get db-handle r>
[ statement-sql ] keep
[ statement-params length f ] keep
statement-params [ malloc-char-string ] map >c-void*-array
statement-params [ second malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw
] unless ;
: pq-oid-value ( res -- n )
PQoidValue dup InvalidOid = [
"postgresql returned an InvalidOid" throw
] when ;

109
extra/db/postgresql/postgresql.factor
View File

@ -1,8 +1,9 @@
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs alien alien.syntax continuations io
kernel math namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi ;
kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
@ -51,8 +52,8 @@ M: postgresql-result-set #columns ( result-set -- n )
M: postgresql-result-set row-column ( result-set n -- obj )
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
M: postgresql-statement execute-statement ( statement -- )
query-results dispose ;
M: postgresql-statement execute-statement* ( statement -- obj )
query-results ;
: increment-n ( result-set -- n )
dup result-set-n 1+ dup rot set-result-set-n ;
@ -103,3 +104,103 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
M: postgresql-db create-sql ( columns table -- sql )
[
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type % " " %
sql-modifiers " " join %
] interleave ")" %
] "" make ;
M: postgresql-db drop-sql ( table -- sql )
[
"drop table " % %
] "" make ;
SYMBOL: postgresql-counter
M: postgresql-db insert-sql* ( columns table -- sql )
[
postgresql-counter off
"insert into " %
%
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
[ ", " % ] [
drop "$" % postgresql-counter [ inc ] keep get #
] interleave
")" %
] "" make ;
M: postgresql-db update-sql* ( columns table -- sql )
[
"update " %
%
" set " %
dup remove-id
[ ", " % ] [ second dup % " = :" % % ] interleave
" where " %
[ primary-key? ] find nip second dup % " = :" % %
] "" make ;
M: postgresql-db delete-sql* ( columns table -- sql )
[
"delete from " %
%
" where " %
first second dup % " = :" % %
] "" make ;
M: postgresql-db select-sql* ( columns table -- sql )
drop ;
M: postgresql-db tuple>params ( columns tuple -- obj )
[
>r dup first r> get-slot-named swap third
] curry { } map>assoc ;
M: postgresql-db last-id ( res -- id )
pq-oid-value ;
: postgresql-db-modifiers ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
{ +null+ "null" }
{ +not-null+ "not null" }
} ;
M: postgresql-db sql-modifiers* ( modifiers -- str )
postgresql-db-modifiers swap [
dup array? [
first2
>r swap at r> number>string*
" " swap 3append
] [
swap at
] if
] with map [ ] subset ;
: postgresql-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ DOUBLE "real" }
} ;
M: postgresql-db >sql-type ( obj -- str )
dup pair? [
first >sql-type
] [
postgresql-type-hash at* [ T{ no-sql-type } throw ] unless
] if ;

2
extra/db/sqlite/ffi/ffi.factor
View File

@ -108,7 +108,7 @@ LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: char* sqlite3_errmsg ( sqlite3* pDb ) ;
FUNCTION: int sqlite3_prepare_v2 ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;

2
extra/db/sqlite/lib/lib.factor
View File

@ -30,7 +30,7 @@ IN: db.sqlite.lib
: sqlite-prepare ( db sql -- handle )
dup length "void*" <c-object> "void*" <c-object>
[ sqlite3_prepare_v2 sqlite-check-result ] 2keep
[ sqlite3_prepare sqlite-check-result ] 2keep
drop *void* ;
: sqlite-bind-parameter-index ( handle name -- index )

22
extra/db/sqlite/sqlite.factor
View File

@ -25,7 +25,7 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set ;
TUPLE: sqlite-result-set advanced? ;
: <sqlite-result-set> ( query -- sqlite-result-set )
dup statement-handle sqlite-result-set <result-set> ;
@ -40,7 +40,13 @@ M: sqlite-db <prepared-statement> ( str -- obj )
M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ;
: maybe-advance-row ( result-set -- result-set )
dup sqlite-result-set-advanced? [
dup advance-row drop
] unless ;
M: sqlite-result-set dispose ( result-set -- )
maybe-advance-row
f swap set-result-set-handle ;
: sqlite-bind ( triples handle -- )
@ -52,8 +58,8 @@ M: sqlite-statement bind-statement* ( triples statement -- )
M: sqlite-statement reset-statement ( statement -- )
statement-handle sqlite-reset ;
M: sqlite-statement execute-statement ( statement -- )
statement-handle sqlite-next drop ;
M: sqlite-statement execute-statement* ( statement -- obj )
query-results ;
M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ;
@ -62,7 +68,8 @@ M: sqlite-result-set row-column ( result-set n -- obj )
>r result-set-handle r> sqlite-column ;
M: sqlite-result-set advance-row ( result-set -- handle ? )
result-set-handle sqlite-next ;
[ result-set-handle sqlite-next ] keep
t swap set-sqlite-result-set-advanced? ;
M: sqlite-statement query-results ( query -- result-set )
dup statement-handle sqlite-result-set <result-set> ;
@ -138,9 +145,10 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
third 3array
] curry map ;
M: sqlite-db last-id ( -- id )
db get db-handle sqlite3_last_insert_rowid ;
M: sqlite-db last-id ( result-set -- id )
maybe-advance-row drop
db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
: sqlite-db-modifiers ( -- hashtable )
H{

17
extra/db/tuples/tuples-tests.factor
View File

@ -1,11 +1,12 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.sqlite db.tuples
db.types continuations namespaces ;
db.types continuations namespaces db.postgresql math
tools.time ;
IN: temporary
TUPLE: person the-id the-name the-number real ;
: <person> ( name age -- person )
: <person> ( name age real -- person )
{
set-person-the-name
set-person-the-number
@ -36,10 +37,10 @@ SYMBOL: the-person
test-tuples
] with-db ;
! : test-postgres ( -- )
! resource-path <postgresql-db> [
! test-tuples
! ] with-db ;
: test-postgresql ( -- )
"localhost" "postgres" "" "factor-test" <postgresql-db> [
test-tuples
] with-db ;
person "PERSON"
{
@ -52,7 +53,7 @@ person "PERSON"
"billy" 10 3.14 <person> the-person set
test-sqlite
! test-postgres
! test-postgresql
person "PERSON"
{
@ -65,4 +66,4 @@ person "PERSON"
1 "billy" 20 6.28 <assigned-person> the-person set
test-sqlite
! test-postgres
! test-postgresql

11
extra/db/tuples/tuples.factor
View File

@ -64,9 +64,12 @@ HOOK: tuple>params db ( columns tuple -- obj )
2dup . .
[ bind-statement ] keep ;
: do-tuple-statement ( tuple columns-quot statement-quot -- )
: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
>r [ class db-columns ] swap compose keep
r> tuple-statement execute-statement ;
r> tuple-statement ;
: do-tuple-statement ( tuple columns-quot statement-quot -- )
make-tuple-statement execute-statement ;
: create-table ( class -- )
dup db-columns swap db-table create-sql sql-command ;
@ -76,8 +79,8 @@ HOOK: tuple>params db ( columns tuple -- obj )
: insert-tuple ( tuple -- )
[
[ maybe-remove-id ] [ insert-sql ] do-tuple-statement
last-id
[ maybe-remove-id ] [ insert-sql ]
make-tuple-statement execute-statement-last-id
] keep set-primary-key ;
: update-tuple ( tuple -- )

124
misc/factor.sh
View File

@ -14,16 +14,36 @@ NO_UI=
GIT_PROTOCOL=${GIT_PROTOCOL:="git"}
GIT_URL=${GIT_URL:=$GIT_PROTOCOL"://factorcode.org/git/factor.git"}
test_program_installed() {
if ! [[ -n `type -p $1` ]] ; then
return 0;
fi
return 1;
}
ensure_program_installed() {
echo -n "Checking for $1..."
result=`type -p $1`
if ! [[ -n $result ]] ; then
echo "not found!"
echo "Install $1 and try again."
exit 1
fi
echo "found!"
installed=0;
for i in $* ;
do
echo -n "Checking for $i..."
test_program_installed $i
if [[ $? -eq 0 ]]; then
echo -n "not "
else
installed=$(( $installed + 1 ))
fi
echo "found!"
done
if [[ $installed -eq 0 ]] ; then
echo -n "Install "
if [[ $# -eq 1 ]] ; then
echo -n $1
else
echo -n "any of [ $* ]"
fi
echo " and try again."
exit 1
fi
}
check_ret() {
@ -47,13 +67,33 @@ check_gcc_version() {
echo "ok."
}
set_downloader() {
test_program_installed wget
if [[ $? -ne 0 ]] ; then
DOWNLOAD=wget
else
DOWNLOAD="curl -O"
fi
}
set_md5sum() {
test_program_installed md5sum
if [[ $? -ne 0 ]] ; then
MD5SUM=md5sum
else
MD5SUM="md5 -r"
fi
}
check_installed_programs() {
ensure_program_installed chmod
ensure_program_installed uname
ensure_program_installed git
ensure_program_installed wget
ensure_program_installed wget curl
ensure_program_installed gcc
ensure_program_installed make
ensure_program_installed md5sum md5
ensure_program_installed cut
case $OS in
netbsd) ensure_program_installed gmake;;
esac
@ -234,36 +274,53 @@ make_factor() {
invoke_make NO_UI=$NO_UI $MAKE_TARGET -j5
}
delete_boot_images() {
update_boot_images() {
echo "Deleting old images..."
rm $BOOT_IMAGE > /dev/null 2>&1
rm checksums.txt* > /dev/null 2>&1
rm $BOOT_IMAGE.* > /dev/null 2>&1
rm staging.*.image > /dev/null 2>&1
rm staging.*.image > /dev/null 2>&1
if [[ -f $BOOT_IMAGE ]] ; then
get_url http://factorcode.org/images/latest/checksums.txt
factorcode_md5=`cat checksums.txt|grep $BOOT_IMAGE|cut -f2 -d' '`;
set_md5sum
disk_md5=`$MD5SUM $BOOT_IMAGE|cut -f1 -d' '`;
echo "Factorcode md5: $factorcode_md5";
echo "Disk md5: $disk_md5";
if [[ "$factorcode_md5" == "$disk_md5" ]] ; then
echo "Your disk boot image matches the one on factorcode.org."
else
rm $BOOT_IMAGE > /dev/null 2>&1
get_boot_image;
fi
else
get_boot_image
fi
}
get_boot_image() {
wget http://factorcode.org/images/latest/$BOOT_IMAGE
check_ret wget
echo "Downloading boot image $BOOT_IMAGE."
get_url http://factorcode.org/images/latest/$BOOT_IMAGE
}
get_url() {
if [[ $DOWNLOAD -eq "" ]] ; then
set_downloader;
fi
echo $DOWNLOAD $1 ;
$DOWNLOAD $1
check_ret $DOWNLOAD
}
maybe_download_dlls() {
if [[ $OS == winnt ]] ; then
wget http://factorcode.org/dlls/freetype6.dll
check_ret wget
wget http://factorcode.org/dlls/zlib1.dll
check_ret wget
wget http://factorcode.org/dlls/OpenAL32.dll
check_ret wget
wget http://factorcode.org/dlls/alut.dll
check_ret wget
wget http://factorcode.org/dlls/ogg.dll
check_ret wget
wget http://factorcode.org/dlls/theora.dll
check_ret wget
wget http://factorcode.org/dlls/vorbis.dll
check_ret wget
wget http://factorcode.org/dlls/sqlite3.dll
check_ret wget
get_url http://factorcode.org/dlls/freetype6.dll
get_url http://factorcode.org/dlls/zlib1.dll
get_url http://factorcode.org/dlls/OpenAL32.dll
get_url http://factorcode.org/dlls/alut.dll
get_url http://factorcode.org/dlls/ogg.dll
get_url http://factorcode.org/dlls/theora.dll
get_url http://factorcode.org/dlls/vorbis.dll
get_url http://factorcode.org/dlls/sqlite3.dll
chmod 777 *.dll
check_ret chmod
fi
@ -299,8 +356,7 @@ update() {
}
update_bootstrap() {
delete_boot_images
get_boot_image
update_boot_images
bootstrap
}
@ -321,7 +377,7 @@ install_libraries() {
}
usage() {
echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap"
echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|net-bootstrap"
echo "If you are behind a firewall, invoke as:"
echo "env GIT_PROTOCOL=http $0 <command>"
}
@ -333,6 +389,6 @@ case "$1" in
quick-update) update; refresh_image ;;
update) update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;;
wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;;
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
*) usage ;;
esac