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

extra/builder/builder.factor

@@ -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
-      [ "Bootstrap error" print "../boot-log" cat "bootstrap error" throw ]
+!       <process-stream> dup dispose process-stream-process wait-for-process
-    when
+!     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

extra/builder/test/test.factor

@@ -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

extra/db/db.factor

@@ -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 ;

extra/db/postgresql/ffi/ffi.factor

@@ -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 

extra/db/postgresql/lib/lib.factor

@@ -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 ;

extra/db/postgresql/postgresql.factor

@@ -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
+kernel math math.parser namespaces prettyprint quotations
-sequences debugger db db.postgresql.lib db.postgresql.ffi ;
+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 -- )
+M: postgresql-statement execute-statement* ( statement -- obj )
-    query-results dispose ;
+    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 ;

extra/db/sqlite/ffi/ffi.factor

@@ -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 ) ;

extra/db/sqlite/lib/lib.factor

@@ -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 )

extra/db/sqlite/sqlite.factor

@@ -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 -- )
+M: sqlite-statement execute-statement* ( statement -- obj )
-    statement-handle sqlite-next drop ;
+    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 )
+M: sqlite-db last-id ( result-set -- id )
-    db get db-handle sqlite3_last_insert_rowid ;
+    maybe-advance-row drop
-
+    db get db-handle sqlite3_last_insert_rowid
+    dup zero? [ "last-id failed" throw ] when ;
 
 : sqlite-db-modifiers ( -- hashtable )
     H{

extra/db/tuples/tuples-tests.factor

@@ -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 ( -- )
+: test-postgresql ( -- )
-    ! resource-path <postgresql-db> [
+    "localhost" "postgres" "" "factor-test" <postgresql-db> [
-        ! test-tuples
+        test-tuples
-    ! ] with-db ;
+    ] 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

extra/db/tuples/tuples.factor

@@ -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
+        [ maybe-remove-id ] [ insert-sql ]
-        last-id
+        make-tuple-statement execute-statement-last-id
     ] keep set-primary-key ;
 
 : update-tuple ( tuple -- )

misc/factor.sh

@@ -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..."
+	installed=0;
-        result=`type -p $1`
+	for i in $* ;
-        if ! [[ -n $result ]] ; then
+	do
-                echo "not found!"
+	    echo -n "Checking for $i..."
-                echo "Install $1 and try again."
+		test_program_installed $i
-                exit 1
+		if [[ $? -eq 0 ]]; then
-        fi
+			echo -n "not "
-        echo "found!"
+		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
+	echo "Downloading boot image $BOOT_IMAGE."
-        check_ret wget
+	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
+                get_url http://factorcode.org/dlls/freetype6.dll
-                check_ret wget
+                get_url http://factorcode.org/dlls/zlib1.dll
-                wget http://factorcode.org/dlls/zlib1.dll
+                get_url http://factorcode.org/dlls/OpenAL32.dll
-                check_ret wget
+                get_url http://factorcode.org/dlls/alut.dll
-                wget http://factorcode.org/dlls/OpenAL32.dll
+                get_url http://factorcode.org/dlls/ogg.dll
-                check_ret wget
+                get_url http://factorcode.org/dlls/theora.dll
-                wget http://factorcode.org/dlls/alut.dll
+                get_url http://factorcode.org/dlls/vorbis.dll
-                check_ret wget
+                get_url http://factorcode.org/dlls/sqlite3.dll
-                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
                 chmod 777 *.dll
                 check_ret chmod
         fi
@@ -299,8 +356,7 @@ update() {
 }
 
 update_bootstrap() {
-        delete_boot_images
+        update_boot_images
-        get_boot_image
         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