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-04-07 15:45:19 -05:00
parent 3164cda6fb ef6edbe15b
commit 4dab4ed329
9 changed files with 106 additions and 112 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
build-support/factor.sh
View File

@ -89,11 +89,6 @@ set_md5sum() {
set_gcc() { set_gcc() {
case $OS in case $OS in
openbsd) ensure_program_installed egcc; CC=egcc;; 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;; *) CC=gcc;;
esac esac
} }

50
extra/db/db.factor
View File

@ -11,14 +11,19 @@ TUPLE: db
update-statements update-statements
delete-statements ; delete-statements ;
: <db> ( handle -- obj ) : construct-db ( class -- obj )
H{ } clone H{ } clone H{ } clone construct-empty
db construct-boa ; H{ } clone >>insert-statements
H{ } clone >>update-statements
H{ } clone >>delete-statements ;
GENERIC: make-db* ( seq class -- db ) 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 -- ) HOOK: db-close db ( handle -- )
: make-db ( seq class -- db ) construct-empty make-db* ;
: dispose-statements ( seq -- ) [ dispose drop ] assoc-each ; : dispose-statements ( seq -- ) [ dispose drop ] assoc-each ;
@ -30,10 +35,13 @@ HOOK: db-close db ( handle -- )
handle>> db-close handle>> db-close
] with-variable ; ] with-variable ;
! TUPLE: sql sql in-params out-params ;
TUPLE: statement handle sql in-params out-params bind-params bound? ; TUPLE: statement handle sql in-params out-params bind-params bound? ;
TUPLE: simple-statement ; TUPLE: simple-statement < statement ;
TUPLE: prepared-statement ; TUPLE: prepared-statement < statement ;
TUPLE: nonthrowable-statement ; TUPLE: nonthrowable-statement < statement ;
TUPLE: throwable-statement < statement ;
: make-nonthrowable ( obj -- obj' ) : make-nonthrowable ( obj -- obj' )
dup sequence? [ dup sequence? [
[ make-nonthrowable ] map [ make-nonthrowable ] map
@ -41,14 +49,13 @@ TUPLE: nonthrowable-statement ;
nonthrowable-statement construct-delegate nonthrowable-statement construct-delegate
] if ; ] 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 ; TUPLE: result-set sql in-params out-params handle n max ;
: <statement> ( 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: <simple-statement> db ( str in out -- statement ) HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement ) HOOK: <prepared-statement> db ( str in out -- statement )
@ -88,10 +95,13 @@ M: nonthrowable-statement execute-statement ( statement -- )
dup #rows >>max dup #rows >>max
0 >>n drop ; 0 >>n drop ;
: <result-set> ( query handle tuple -- result-set ) : construct-result-set ( query handle class -- result-set )
>r >r { sql>> in-params>> out-params>> } get-slots r> construct-empty
{ (>>sql) (>>in-params) (>>out-params) (>>handle) } result-set swap >>handle
construct r> construct-delegate ; >r [ sql>> ] [ in-params>> ] [ out-params>> ] tri r>
swap >>out-params
swap >>in-params
swap >>sql ;
: sql-row ( result-set -- seq ) : sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ; dup #columns [ row-column ] with map ;
@ -110,7 +120,7 @@ M: nonthrowable-statement execute-statement ( statement -- )
accumulator >r query-each r> { } like ; inline accumulator >r query-each r> { } like ; inline
: with-db ( db seq quot -- ) : 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 ; [ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
: default-query ( query -- result-set ) : default-query ( query -- result-set )

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

@ -6,7 +6,8 @@ IN: db.postgresql.ffi
<< "postgresql" { << "postgresql" {
{ [ os winnt? ] [ "libpq.dll" ] } { [ 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" ] } { [ os unix? ] [ "libpq.so" ] }
} cond "cdecl" add-library >> } cond "cdecl" add-library >>

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

@ -5,40 +5,39 @@ 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 tools.annotations math.ranges db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker combinators sequences.lib classes locals words tools.walker
namespaces.lib ; namespaces.lib accessors ;
IN: db.postgresql IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ; TUPLE: postgresql-db < db
TUPLE: postgresql-statement ; host port pgopts pgtty db user pass ;
INSTANCE: postgresql-statement throwable-statement
TUPLE: postgresql-result-set ; TUPLE: postgresql-statement < throwable-statement ;
TUPLE: postgresql-result-set < result-set ;
: <postgresql-statement> ( statement in out -- postgresql-statement ) : <postgresql-statement> ( statement in out -- postgresql-statement )
<statement> postgresql-statement construct-statement ;
postgresql-statement construct-delegate ;
M: postgresql-db make-db* ( seq tuple -- db ) M: postgresql-db make-db* ( seq tuple -- db )
>r first4 r> [ >r first4 r>
{ swap >>db
set-postgresql-db-host swap >>pass
set-postgresql-db-user swap >>user
set-postgresql-db-pass swap >>host ;
set-postgresql-db-db
} set-slots
] keep ;
M: postgresql-db db-open ( db -- ) M: postgresql-db db-open ( db -- db )
dup { dup {
postgresql-db-host [ host>> ]
postgresql-db-port [ port>> ]
postgresql-db-pgopts [ pgopts>> ]
postgresql-db-pgtty [ pgtty>> ]
postgresql-db-db [ db>> ]
postgresql-db-user [ user>> ]
postgresql-db-pass [ pass>> ]
} get-slots connect-postgres <db> swap set-delegate ; } cleave connect-postgres >>handle ;
M: postgresql-db dispose ( db -- ) M: postgresql-db dispose ( db -- )
db-handle PQfinish ; handle>> PQfinish ;
M: postgresql-statement bind-statement* ( statement -- ) M: postgresql-statement bind-statement* ( statement -- )
drop ; drop ;
@ -50,10 +49,10 @@ M: postgresql-statement bind-tuple ( tuple statement -- )
] keep set-statement-bind-params ; ] keep set-statement-bind-params ;
M: postgresql-result-set #rows ( result-set -- n ) M: postgresql-result-set #rows ( result-set -- n )
result-set-handle PQntuples ; handle>> PQntuples ;
M: postgresql-result-set #columns ( result-set -- n ) M: postgresql-result-set #columns ( result-set -- n )
result-set-handle PQnfields ; handle>> PQnfields ;
M: postgresql-result-set row-column ( result-set column -- obj ) M: postgresql-result-set row-column ( result-set column -- obj )
>r dup result-set-handle swap result-set-n r> pq-get-string ; >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 dup do-postgresql-statement
] if* ] if*
postgresql-result-set <result-set> postgresql-result-set construct-result-set
dup init-result-set ; dup init-result-set ;
M: postgresql-result-set advance-row ( 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 -- ) M: postgresql-statement prepare-statement ( statement -- )
[ [
>r db get db-handle "" r> >r db get handle>> "" r>
dup statement-sql swap statement-in-params dup statement-sql swap statement-in-params
length f PQprepare postgresql-error length f PQprepare postgresql-error
] keep set-statement-handle ; ] keep set-statement-handle ;

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

@ -5,61 +5,48 @@ hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings classes.tuple alien.c-types prettyprint sequences strings classes.tuple alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types combinators words combinators.lib db.types combinators
io namespaces.lib ; io namespaces.lib accessors ;
USE: tools.walker
IN: db.sqlite IN: db.sqlite
TUPLE: sqlite-db path ; TUPLE: sqlite-db < db path ;
M: sqlite-db make-db* ( path db -- db ) M: sqlite-db make-db* ( path db -- db )
[ set-sqlite-db-path ] keep ; swap >>path ;
M: sqlite-db db-open ( db -- ) M: sqlite-db db-open ( db -- db )
dup sqlite-db-path sqlite-open <db> [ path>> sqlite-open ] [ swap >>handle ] bi ;
swap set-delegate ;
M: sqlite-db db-close ( handle -- ) sqlite-close ; M: sqlite-db db-close ( handle -- ) sqlite-close ;
M: sqlite-db dispose ( db -- ) dispose-db ; M: sqlite-db dispose ( db -- ) dispose-db ;
: with-sqlite ( path quot -- ) sqlite-db swap with-db ; inline
TUPLE: sqlite-statement ; TUPLE: sqlite-statement < throwable-statement ;
INSTANCE: sqlite-statement throwable-statement
TUPLE: sqlite-result-set has-more? ; TUPLE: sqlite-result-set < result-set has-more? ;
M: sqlite-db <simple-statement> ( str in out -- obj ) M: sqlite-db <simple-statement> ( str in out -- obj )
<prepared-statement> ; <prepared-statement> ;
M: sqlite-db <prepared-statement> ( str in out -- obj ) M: sqlite-db <prepared-statement> ( str in out -- obj )
{ sqlite-statement construct-statement ;
set-statement-sql
set-statement-in-params
set-statement-out-params
} statement construct
sqlite-statement construct-delegate ;
: sqlite-maybe-prepare ( statement -- statement ) : sqlite-maybe-prepare ( statement -- statement )
dup statement-handle [ dup handle>> [
[ db get handle>> over sql>> sqlite-prepare
delegate >>handle
db get db-handle over statement-sql sqlite-prepare
swap set-statement-handle
] keep
] unless ; ] unless ;
M: sqlite-statement dispose ( statement -- ) M: sqlite-statement dispose ( statement -- )
statement-handle handle>>
[ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ; [ [ sqlite3_reset drop ] keep sqlite-finalize ] when* ;
M: sqlite-result-set dispose ( result-set -- ) M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ; f >>handle drop ;
: sqlite-bind ( triples handle -- ) : sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ; swap [ first3 sqlite-bind-type ] with each ;
: reset-statement ( statement -- ) : reset-statement ( statement -- )
sqlite-maybe-prepare sqlite-maybe-prepare handle>> sqlite-reset ;
statement-handle sqlite-reset ;
M: sqlite-statement bind-statement* ( statement -- ) M: sqlite-statement bind-statement* ( statement -- )
sqlite-maybe-prepare sqlite-maybe-prepare
@ -69,11 +56,11 @@ M: sqlite-statement bind-statement* ( statement -- )
M: sqlite-statement bind-tuple ( tuple statement -- ) M: sqlite-statement bind-tuple ( tuple statement -- )
[ [
statement-in-params in-params>>
[ [
[ sql-spec-column-name ":" prepend ] [ column-name>> ":" prepend ]
[ sql-spec-slot-name rot get-slot-named ] [ slot-name>> rot get-slot-named ]
[ sql-spec-type ] tri 3array [ type>> ] tri 3array
] with map ] with map
] keep ] keep
bind-statement ; bind-statement ;
@ -86,25 +73,24 @@ M: sqlite-db insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ; execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n ) 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 ) 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 ) M: sqlite-result-set row-column-typed ( result-set n -- obj )
dup pick result-set-out-params nth sql-spec-type dup pick out-params>> nth type>>
>r >r result-set-handle r> r> sqlite-column-typed ; >r >r handle>> r> r> sqlite-column-typed ;
M: sqlite-result-set advance-row ( result-set -- ) M: sqlite-result-set advance-row ( result-set -- )
[ result-set-handle sqlite-next ] keep dup handle>> sqlite-next >>has-more? drop ;
set-sqlite-result-set-has-more? ;
M: sqlite-result-set more-rows? ( result-set -- ? ) M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ; has-more?>> ;
M: sqlite-statement query-results ( query -- result-set ) M: sqlite-statement query-results ( query -- result-set )
sqlite-maybe-prepare sqlite-maybe-prepare
dup statement-handle sqlite-result-set <result-set> dup handle>> sqlite-result-set construct-result-set
dup advance-row ; dup advance-row ;
M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ; M: sqlite-db begin-transaction ( -- ) "BEGIN" sql-command ;
@ -119,9 +105,9 @@ M: sqlite-db create-sql-statement ( class -- statement )
[ [
"create table " 0% 0% "create table " 0% 0%
"(" 0% [ ", " 0% ] [ "(" 0% [ ", " 0% ] [
dup sql-spec-column-name 0% dup column-name>> 0%
" " 0% " " 0%
dup sql-spec-type t lookup-type 0% dup type>> t lookup-type 0%
modifiers 0% modifiers 0%
] interleave ");" 0% ] interleave ");" 0%
] sqlite-make ; ] sqlite-make ;
@ -134,7 +120,7 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
"insert into " 0% 0% "insert into " 0% 0%
"(" 0% "(" 0%
maybe-remove-id maybe-remove-id
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0% ") values(" 0%
[ ", " 0% ] [ bind% ] interleave [ ", " 0% ] [ bind% ] interleave
");" 0% ");" 0%
@ -145,11 +131,11 @@ M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
: where-primary-key% ( specs -- ) : where-primary-key% ( specs -- )
" where " 0% " 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-clause ( specs -- )
" where " 0% " 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 <update-tuple-statement> ( class -- statement ) M: sqlite-db <update-tuple-statement> ( class -- statement )
[ [
@ -157,7 +143,7 @@ M: sqlite-db <update-tuple-statement> ( class -- statement )
0% 0%
" set " 0% " set " 0%
dup remove-id dup remove-id
[ ", " 0% ] [ dup sql-spec-column-name 0% " = " 0% bind% ] interleave [ ", " 0% ] [ dup column-name>> 0% " = " 0% bind% ] interleave
where-primary-key% where-primary-key%
] sqlite-make ; ] sqlite-make ;
@ -166,23 +152,23 @@ M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
"delete from " 0% 0% "delete from " 0% 0%
" where " 0% " where " 0%
find-primary-key find-primary-key
dup sql-spec-column-name 0% " = " 0% bind% dup column-name>> 0% " = " 0% bind%
] sqlite-make ; ] sqlite-make ;
! : select-interval ( interval name -- ) ; ! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ; ! : select-sequence ( seq name -- ) ;
M: sqlite-db bind% ( spec -- ) M: sqlite-db bind% ( spec -- )
dup 1, sql-spec-column-name ":" prepend 0% ; dup 1, column-name>> ":" prepend 0% ;
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement ) M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[ [
"select " 0% "select " 0%
over [ ", " 0% ] over [ ", " 0% ]
[ dup sql-spec-column-name 0% 2, ] interleave [ dup column-name>> 0% 2, ] interleave
" from " 0% 0% " 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% dup empty? [ drop ] [ where-clause ] if ";" 0%
] sqlite-make ; ] sqlite-make ;

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

@ -260,10 +260,10 @@ C: <secret> secret
! [ test-random-id ] test-sqlite ! [ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-sqlite [ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite [ assigned-person-schema test-tuples ] test-sqlite
! [ assigned-person-schema test-repeated-insert ] test-sqlite [ assigned-person-schema test-repeated-insert ] test-sqlite
! [ native-person-schema test-tuples ] test-postgresql [ native-person-schema test-tuples ] test-postgresql
! [ assigned-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-postgresql
! \ insert-tuple must-infer ! \ insert-tuple must-infer
! \ update-tuple must-infer ! \ update-tuple must-infer

1
extra/hardware-info/backend/backend.factor
View File

@ -2,6 +2,7 @@ USING: system ;
IN: hardware-info.backend IN: hardware-info.backend
HOOK: cpus os ( -- n ) HOOK: cpus os ( -- n )
HOOK: cpu-mhz os ( -- n )
HOOK: memory-load os ( -- n ) HOOK: memory-load os ( -- n )
HOOK: physical-mem os ( -- n ) HOOK: physical-mem os ( -- n )
HOOK: available-mem os ( -- n ) HOOK: available-mem os ( -- n )

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

@ -3,11 +3,12 @@ combinators vocabs.loader hardware-info.backend system ;
IN: hardware-info IN: hardware-info
: write-unit ( x n str -- ) : 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 ; : kb ( x -- ) 10 "kB" write-unit ;
: megs ( x -- ) 20 "MB" write-unit ; : megs ( x -- ) 20 "MB" write-unit ;
: gigs ( x -- ) 30 "GB" write-unit ; : gigs ( x -- ) 30 "GB" write-unit ;
: ghz ( x -- ) 1000000000 /f number>string write bl "GHz" write ;
<< { << {
{ [ os windows? ] [ "hardware-info.windows" ] } { [ os windows? ] [ "hardware-info.windows" ] }
@ -18,4 +19,5 @@ IN: hardware-info
: hardware-report. ( -- ) : hardware-report. ( -- )
"CPUs: " write cpus number>string write nl "CPUs: " write cpus number>string write nl
"CPU Speed: " write cpu-mhz ghz nl
"Physical RAM: " write physical-mem megs nl ; "Physical RAM: " write physical-mem megs nl ;

2
extra/hardware-info/macosx/macosx.factor
View File

@ -41,7 +41,7 @@ M: macosx physical-mem ( -- n ) { 6 5 } sysctl-query-uint ;
: machine-arch ( -- n ) { 6 12 } sysctl-query-string ; : machine-arch ( -- n ) { 6 12 } sysctl-query-string ;
: vector-unit ( -- n ) { 6 13 } sysctl-query-uint ; : vector-unit ( -- n ) { 6 13 } sysctl-query-uint ;
: bus-frequency ( -- n ) { 6 14 } 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 ; : cacheline-size ( -- n ) { 6 16 } sysctl-query-uint ;
: l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ; : l1-icache-size ( -- n ) { 6 17 } sysctl-query-uint ;
: l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ; : l1-dcache-size ( -- n ) { 6 18 } sysctl-query-uint ;