diff --git a/build-support/factor.sh b/build-support/factor.sh index 476e885257..ea0c35aa83 100755 --- a/build-support/factor.sh +++ b/build-support/factor.sh @@ -89,11 +89,6 @@ set_md5sum() { set_gcc() { case $OS in openbsd) ensure_program_installed egcc; CC=egcc;; - netbsd) if [[ $WORD -eq 64 ]] ; then - CC=/usr/pkg/gcc34/bin/gcc - else - CC=gcc - fi ;; *) CC=gcc;; esac } diff --git a/extra/db/db.factor b/extra/db/db.factor index 55e672ec80..1a1a18c942 100755 --- a/extra/db/db.factor +++ b/extra/db/db.factor @@ -11,14 +11,19 @@ TUPLE: db update-statements delete-statements ; -: ( handle -- obj ) - H{ } clone H{ } clone H{ } clone - db construct-boa ; +: construct-db ( class -- obj ) + construct-empty + H{ } clone >>insert-statements + H{ } clone >>update-statements + H{ } clone >>delete-statements ; GENERIC: make-db* ( seq class -- db ) -GENERIC: db-open ( db -- ) + +: make-db ( seq class -- db ) + construct-db make-db* ; + +GENERIC: db-open ( db -- db ) HOOK: db-close db ( handle -- ) -: make-db ( seq class -- db ) construct-empty make-db* ; : dispose-statements ( seq -- ) [ dispose drop ] assoc-each ; @@ -30,10 +35,13 @@ HOOK: db-close db ( handle -- ) handle>> db-close ] with-variable ; +! TUPLE: sql sql in-params out-params ; TUPLE: statement handle sql in-params out-params bind-params bound? ; -TUPLE: simple-statement ; -TUPLE: prepared-statement ; -TUPLE: nonthrowable-statement ; +TUPLE: simple-statement < statement ; +TUPLE: prepared-statement < statement ; +TUPLE: nonthrowable-statement < statement ; +TUPLE: throwable-statement < statement ; + : make-nonthrowable ( obj -- obj' ) dup sequence? [ [ make-nonthrowable ] map @@ -41,14 +49,13 @@ TUPLE: nonthrowable-statement ; nonthrowable-statement construct-delegate ] if ; -MIXIN: throwable-statement -INSTANCE: statement throwable-statement -INSTANCE: simple-statement throwable-statement -INSTANCE: prepared-statement throwable-statement - TUPLE: result-set sql in-params out-params handle n max ; -: ( sql in out -- statement ) - { (>>sql) (>>in-params) (>>out-params) } statement construct ; + +: construct-statement ( sql in out class -- statement ) + construct-empty + swap >>out-params + swap >>in-params + swap >>sql ; HOOK: db ( str in out -- statement ) HOOK: db ( str in out -- statement ) @@ -88,11 +95,14 @@ M: nonthrowable-statement execute-statement ( statement -- ) dup #rows >>max 0 >>n drop ; -: ( query handle tuple -- result-set ) - >r >r { sql>> in-params>> out-params>> } get-slots r> - { (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set - construct r> construct-delegate ; - +: construct-result-set ( query handle class -- result-set ) + construct-empty + swap >>handle + >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r> + swap >>out-params + swap >>in-params + swap >>sql ; + : sql-row ( result-set -- seq ) dup #columns [ row-column ] with map ; @@ -110,7 +120,7 @@ M: nonthrowable-statement execute-statement ( statement -- ) accumulator >r query-each r> { } like ; inline : with-db ( db seq quot -- ) - >r make-db dup db-open db r> + >r make-db db-open db r> [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ; : default-query ( query -- result-set ) diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor index 7925989bf5..7f428bb6b6 100755 --- a/extra/db/postgresql/ffi/ffi.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -6,7 +6,8 @@ IN: db.postgresql.ffi << "postgresql" { { [ os winnt? ] [ "libpq.dll" ] } - { [ os macosx? ] [ "/opt/local/lib/postgresql82/libpq.dylib" ] } + { [ os macosx? ] [ "/opt/local/lib/postgresql83/libpq.dylib" ] } + ! { [ os macosx? ] [ "libpq.dylib" ] } { [ os unix? ] [ "libpq.so" ] } } cond "cdecl" add-library >> diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor index f9805560ad..322143e7a2 100755 --- a/extra/db/postgresql/postgresql.factor +++ b/extra/db/postgresql/postgresql.factor @@ -5,40 +5,39 @@ kernel math math.parser namespaces prettyprint quotations sequences debugger db db.postgresql.lib db.postgresql.ffi db.tuples db.types tools.annotations math.ranges combinators sequences.lib classes locals words tools.walker -namespaces.lib ; +namespaces.lib accessors ; IN: db.postgresql -TUPLE: postgresql-db host port pgopts pgtty db user pass ; -TUPLE: postgresql-statement ; -INSTANCE: postgresql-statement throwable-statement -TUPLE: postgresql-result-set ; +TUPLE: postgresql-db < db + host port pgopts pgtty db user pass ; + +TUPLE: postgresql-statement < throwable-statement ; + +TUPLE: postgresql-result-set < result-set ; + : ( statement in out -- postgresql-statement ) - - postgresql-statement construct-delegate ; + postgresql-statement construct-statement ; M: postgresql-db make-db* ( seq tuple -- db ) - >r first4 r> [ - { - set-postgresql-db-host - set-postgresql-db-user - set-postgresql-db-pass - set-postgresql-db-db - } set-slots - ] keep ; + >r first4 r> + swap >>db + swap >>pass + swap >>user + swap >>host ; -M: postgresql-db db-open ( db -- ) - dup { - postgresql-db-host - postgresql-db-port - postgresql-db-pgopts - postgresql-db-pgtty - postgresql-db-db - postgresql-db-user - postgresql-db-pass - } get-slots connect-postgres swap set-delegate ; +M: postgresql-db db-open ( db -- db ) + dup { + [ host>> ] + [ port>> ] + [ pgopts>> ] + [ pgtty>> ] + [ db>> ] + [ user>> ] + [ pass>> ] + } cleave connect-postgres >>handle ; M: postgresql-db dispose ( db -- ) - db-handle PQfinish ; + handle>> PQfinish ; M: postgresql-statement bind-statement* ( statement -- ) drop ; @@ -50,10 +49,10 @@ M: postgresql-statement bind-tuple ( tuple statement -- ) ] keep set-statement-bind-params ; M: postgresql-result-set #rows ( result-set -- n ) - result-set-handle PQntuples ; + handle>> PQntuples ; M: postgresql-result-set #columns ( result-set -- n ) - result-set-handle PQnfields ; + handle>> PQnfields ; M: postgresql-result-set row-column ( result-set column -- obj ) >r dup result-set-handle swap result-set-n r> pq-get-string ; @@ -69,7 +68,7 @@ M: postgresql-statement query-results ( query -- result-set ) ] [ dup do-postgresql-statement ] if* - postgresql-result-set + postgresql-result-set construct-result-set dup init-result-set ; M: postgresql-result-set advance-row ( result-set -- ) @@ -90,7 +89,7 @@ M: postgresql-result-set dispose ( result-set -- ) M: postgresql-statement prepare-statement ( statement -- ) [ - >r db get db-handle "" r> + >r db get handle>> "" r> dup statement-sql swap statement-in-params length f PQprepare postgresql-error ] keep set-statement-handle ; diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor index 9b3185bcf2..11c0150cd2 100755 --- a/extra/db/sqlite/sqlite.factor +++ b/extra/db/sqlite/sqlite.factor @@ -5,61 +5,48 @@ hashtables io.files kernel math math.parser namespaces prettyprint sequences strings classes.tuple alien.c-types continuations db.sqlite.lib db.sqlite.ffi db.tuples words combinators.lib db.types combinators -io namespaces.lib ; -USE: tools.walker +io namespaces.lib accessors ; IN: db.sqlite -TUPLE: sqlite-db path ; +TUPLE: sqlite-db < db path ; M: sqlite-db make-db* ( path db -- db ) - [ set-sqlite-db-path ] keep ; + swap >>path ; -M: sqlite-db db-open ( db -- ) - dup sqlite-db-path sqlite-open - swap set-delegate ; +M: sqlite-db db-open ( db -- db ) + [ path>> sqlite-open ] [ swap >>handle ] bi ; M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db dispose ( db -- ) dispose-db ; -: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline -TUPLE: sqlite-statement ; -INSTANCE: sqlite-statement throwable-statement +TUPLE: sqlite-statement < throwable-statement ; -TUPLE: sqlite-result-set has-more? ; +TUPLE: sqlite-result-set < result-set has-more? ; M: sqlite-db ( str in out -- obj ) ; M: sqlite-db ( str in out -- obj ) - { - set-statement-sql - set-statement-in-params - set-statement-out-params - } statement construct - sqlite-statement construct-delegate ; + sqlite-statement construct-statement ; : sqlite-maybe-prepare ( statement -- statement ) - dup statement-handle [ - [ - delegate - db get db-handle over statement-sql sqlite-prepare - swap set-statement-handle - ] keep + dup handle>> [ + db get handle>> over sql>> sqlite-prepare + >>handle ] unless ; M: sqlite-statement dispose ( statement -- ) - statement-handle + handle>> [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ; M: sqlite-result-set dispose ( result-set -- ) - f swap set-result-set-handle ; + f >>handle drop ; : sqlite-bind ( triples handle -- ) swap [ first3 sqlite-bind-type ] with each ; : reset-statement ( statement -- ) - sqlite-maybe-prepare - statement-handle sqlite-reset ; + sqlite-maybe-prepare handle>> sqlite-reset ; M: sqlite-statement bind-statement* ( statement -- ) sqlite-maybe-prepare @@ -69,11 +56,11 @@ M: sqlite-statement bind-statement* ( statement -- ) M: sqlite-statement bind-tuple ( tuple statement -- ) [ - statement-in-params + in-params>> [ - [ sql-spec-column-name ":" prepend ] - [ sql-spec-slot-name rot get-slot-named ] - [ sql-spec-type ] tri 3array + [ column-name>> ":" prepend ] + [ slot-name>> rot get-slot-named ] + [ type>> ] tri 3array ] with map ] keep bind-statement ; @@ -86,25 +73,24 @@ M: sqlite-db insert-tuple* ( tuple statement -- ) execute-statement last-insert-id swap set-primary-key ; M: sqlite-result-set #columns ( result-set -- n ) - result-set-handle sqlite-#columns ; + handle>> sqlite-#columns ; M: sqlite-result-set row-column ( result-set n -- obj ) - >r result-set-handle r> sqlite-column ; + [ handle>> ] [ sqlite-column ] bi* ; M: sqlite-result-set row-column-typed ( result-set n -- obj ) - dup pick result-set-out-params nth sql-spec-type - >r >r result-set-handle r> r> sqlite-column-typed ; + dup pick out-params>> nth type>> + >r >r handle>> r> r> sqlite-column-typed ; M: sqlite-result-set advance-row ( result-set -- ) - [ result-set-handle sqlite-next ] keep - set-sqlite-result-set-has-more? ; + dup handle>> sqlite-next >>has-more? drop ; M: sqlite-result-set more-rows? ( result-set -- ? ) - sqlite-result-set-has-more? ; + has-more?>> ; M: sqlite-statement query-results ( query -- result-set ) sqlite-maybe-prepare - dup statement-handle sqlite-result-set + dup handle>> sqlite-result-set construct-result-set dup advance-row ; M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; @@ -119,9 +105,9 @@ M: sqlite-db create-sql-statement ( class -- statement ) [ "create table " 0% 0% "(" 0% [ ", " 0% ] [ - dup sql-spec-column-name 0% + dup column-name>> 0% " " 0% - dup sql-spec-type t lookup-type 0% + dup type>> t lookup-type 0% modifiers 0% ] interleave ");" 0% ] sqlite-make ; @@ -134,7 +120,7 @@ M: sqlite-db ( tuple -- statement ) "insert into " 0% 0% "(" 0% maybe-remove-id - dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave + dup [ ", " 0% ] [ column-name>> 0% ] interleave ") values(" 0% [ ", " 0% ] [ bind% ] interleave ");" 0% @@ -145,11 +131,11 @@ M: sqlite-db ( tuple -- statement ) : where-primary-key% ( specs -- ) " where " 0% - find-primary-key dup sql-spec-column-name 0% " = " 0% bind% ; + find-primary-key dup column-name>> 0% " = " 0% bind% ; : where-clause ( specs -- ) " where " 0% - [ " and " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave ; + [ " and " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave ; M: sqlite-db ( class -- statement ) [ @@ -157,7 +143,7 @@ M: sqlite-db ( class -- statement ) 0% " set " 0% dup remove-id - [ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave + [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave where-primary-key% ] sqlite-make ; @@ -166,23 +152,23 @@ M: sqlite-db ( specs table -- sql ) "delete from " 0% 0% " where " 0% find-primary-key - dup sql-spec-column-name 0% " = " 0% bind% + dup column-name>> 0% " = " 0% bind% ] sqlite-make ; ! : select-interval ( interval name -- ) ; ! : select-sequence ( seq name -- ) ; M: sqlite-db bind% ( spec -- ) - dup 1, sql-spec-column-name ":" prepend 0% ; + dup 1, column-name>> ":" prepend 0% ; M: sqlite-db ( tuple class -- statement ) [ "select " 0% over [ ", " 0% ] - [ dup sql-spec-column-name 0% 2, ] interleave + [ dup column-name>> 0% 2, ] interleave " from " 0% 0% - [ sql-spec-slot-name swap get-slot-named ] with subset + [ slot-name>> swap get-slot-named ] with subset dup empty? [ drop ] [ where-clause ] if ";" 0% ] sqlite-make ; diff --git a/extra/db/tuples/tuples-tests.factor b/extra/db/tuples/tuples-tests.factor index 6b61981119..951ded32ea 100755 --- a/extra/db/tuples/tuples-tests.factor +++ b/extra/db/tuples/tuples-tests.factor @@ -260,10 +260,10 @@ C: secret ! [ test-random-id ] test-sqlite [ native-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite -! [ assigned-person-schema test-repeated-insert ] test-sqlite -! [ native-person-schema test-tuples ] test-postgresql -! [ assigned-person-schema test-tuples ] test-postgresql -! [ assigned-person-schema test-repeated-insert ] test-postgresql + [ assigned-person-schema test-repeated-insert ] test-sqlite + [ native-person-schema test-tuples ] test-postgresql + [ assigned-person-schema test-tuples ] test-postgresql + [ assigned-person-schema test-repeated-insert ] test-postgresql ! \ insert-tuple must-infer ! \ update-tuple must-infer diff --git a/extra/hardware-info/backend/backend.factor b/extra/hardware-info/backend/backend.factor index 95a56da2d2..283fea6fcc 100644 --- a/extra/hardware-info/backend/backend.factor +++ b/extra/hardware-info/backend/backend.factor @@ -2,6 +2,7 @@ USING: system ; IN: hardware-info.backend HOOK: cpus os ( -- n ) +HOOK: cpu-mhz os ( -- n ) HOOK: memory-load os ( -- n ) HOOK: physical-mem os ( -- n ) HOOK: available-mem os ( -- n ) diff --git a/extra/hardware-info/hardware-info.factor b/extra/hardware-info/hardware-info.factor index 6d27cf5252..53aab483a1 100755 --- a/extra/hardware-info/hardware-info.factor +++ b/extra/hardware-info/hardware-info.factor @@ -3,11 +3,12 @@ combinators vocabs.loader hardware-info.backend system ; IN: hardware-info : write-unit ( x n str -- ) - [ 2^ /i number>string write bl ] [ write ] bi* ; + [ 2^ /f number>string write bl ] [ write ] bi* ; : kb ( x -- ) 10 "kB" write-unit ; : megs ( x -- ) 20 "MB" write-unit ; : gigs ( x -- ) 30 "GB" write-unit ; +: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ; << { { [ os windows? ] [ "hardware-info.windows" ] } @@ -18,4 +19,5 @@ IN: hardware-info : hardware-report. ( -- ) "CPUs: " write cpus number>string write nl + "CPU Speed: " write cpu-mhz ghz nl "Physical RAM: " write physical-mem megs nl ; diff --git a/extra/hardware-info/macosx/macosx.factor b/extra/hardware-info/macosx/macosx.factor index dac052a1de..91838d2a53 100644 --- a/extra/hardware-info/macosx/macosx.factor +++ b/extra/hardware-info/macosx/macosx.factor @@ -41,7 +41,7 @@ M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ; : machine-arch ( -- n ) { 6 12 } sysctl-query-string ; : vector-unit ( -- n ) { 6 13 } sysctl-query-uint ; : bus-frequency ( -- n ) { 6 14 } sysctl-query-uint ; -: cpu-frequency ( -- n ) { 6 15 } sysctl-query-uint ; +M: macosx cpu-mhz ( -- n ) { 6 15 } sysctl-query-uint ; : cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ; : l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ; : l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;