Merge branch 'master' of git://factorcode.org/git/factor
commit
ce0f86167e
|
@ -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
|
||||||
}
|
}
|
||||||
|
|
|
@ -737,6 +737,7 @@ define-builtin
|
||||||
{ "resize-bit-array" "bit-arrays" }
|
{ "resize-bit-array" "bit-arrays" }
|
||||||
{ "resize-float-array" "float-arrays" }
|
{ "resize-float-array" "float-arrays" }
|
||||||
{ "dll-valid?" "alien" }
|
{ "dll-valid?" "alien" }
|
||||||
|
{ "unimplemented" "kernel.private" }
|
||||||
}
|
}
|
||||||
dup length [ >r first2 r> make-primitive ] 2each
|
dup length [ >r first2 r> make-primitive ] 2each
|
||||||
|
|
||||||
|
|
|
@ -594,3 +594,5 @@ set-primitive-effect
|
||||||
\ dll-valid? { object } { object } <effect> set-primitive-effect
|
\ dll-valid? { object } { object } <effect> set-primitive-effect
|
||||||
|
|
||||||
\ modify-code-heap { array object } { } <effect> set-primitive-effect
|
\ modify-code-heap { array object } { } <effect> set-primitive-effect
|
||||||
|
|
||||||
|
\ unimplemented { } { } <effect> set-primitive-effect
|
||||||
|
|
|
@ -108,3 +108,12 @@ IN: kernel.tests
|
||||||
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
|
H{ } values swap >r dup length swap r> 0 -roll (loop) ;
|
||||||
|
|
||||||
[ loop ] must-fail
|
[ loop ] must-fail
|
||||||
|
|
||||||
|
! Discovered on Windows
|
||||||
|
: total-failure-1 "" [ ] map unimplemented ;
|
||||||
|
|
||||||
|
[ total-failure-1 ] must-fail
|
||||||
|
|
||||||
|
: total-failure-2 [ ] (call) unimplemented ;
|
||||||
|
|
||||||
|
[ total-failure-2 ] must-fail
|
||||||
|
|
|
@ -284,10 +284,6 @@ HELP: use
|
||||||
HELP: in
|
HELP: in
|
||||||
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
|
{ $var-description "A variable holding the name of the current vocabulary for new definitions." } ;
|
||||||
|
|
||||||
HELP: shadow-warnings
|
|
||||||
{ $values { "vocab" "an assoc mapping strings to words" } { "vocabs" "a sequence of assocs" } }
|
|
||||||
{ $description "Tests if any keys in " { $snippet "vocab" } " shadow keys in the elements of " { $snippet "vocabs" } ", and if so, prints a warning message. These warning messages can be disabled by setting " { $link parser-notes } " to " { $link f } "." } ;
|
|
||||||
|
|
||||||
HELP: (use+)
|
HELP: (use+)
|
||||||
{ $values { "vocab" "an assoc mapping strings to words" } }
|
{ $values { "vocab" "an assoc mapping strings to words" } }
|
||||||
{ $description "Adds an assoc at the front of the search path." }
|
{ $description "Adds an assoc at the front of the search path." }
|
||||||
|
|
|
@ -191,22 +191,8 @@ SYMBOL: in
|
||||||
: word/vocab% ( word -- )
|
: word/vocab% ( word -- )
|
||||||
"(" % dup word-vocabulary % " " % word-name % ")" % ;
|
"(" % dup word-vocabulary % " " % word-name % ")" % ;
|
||||||
|
|
||||||
: shadow-warning ( new old -- )
|
|
||||||
2dup eq? [
|
|
||||||
2drop
|
|
||||||
] [
|
|
||||||
[ word/vocab% " shadowed by " % word/vocab% ] "" make
|
|
||||||
note.
|
|
||||||
] if ;
|
|
||||||
|
|
||||||
: shadow-warnings ( vocab vocabs -- )
|
|
||||||
[
|
|
||||||
swapd assoc-stack dup
|
|
||||||
[ shadow-warning ] [ 2drop ] if
|
|
||||||
] curry assoc-each ;
|
|
||||||
|
|
||||||
: (use+) ( vocab -- )
|
: (use+) ( vocab -- )
|
||||||
vocab-words use get 2dup shadow-warnings push ;
|
vocab-words use get push ;
|
||||||
|
|
||||||
: use+ ( vocab -- )
|
: use+ ( vocab -- )
|
||||||
load-vocab (use+) ;
|
load-vocab (use+) ;
|
||||||
|
|
|
@ -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,11 +95,14 @@ 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 )
|
||||||
|
|
|
@ -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 >>
|
||||||
|
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -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 )
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -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 ;
|
||||||
|
|
|
@ -1,7 +1,7 @@
|
||||||
IN: io.windows.launcher.nt.tests
|
IN: io.windows.launcher.nt.tests
|
||||||
USING: io.launcher tools.test calendar accessors
|
USING: io.launcher tools.test calendar accessors
|
||||||
namespaces kernel system arrays io io.files io.encodings.ascii
|
namespaces kernel system arrays io io.files io.encodings.ascii
|
||||||
sequences parser assocs hashtables ;
|
sequences parser assocs hashtables math ;
|
||||||
|
|
||||||
[ ] [
|
[ ] [
|
||||||
<process>
|
<process>
|
||||||
|
@ -129,3 +129,14 @@ sequences parser assocs hashtables ;
|
||||||
|
|
||||||
"HOME" swap at "XXX" =
|
"HOME" swap at "XXX" =
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
|
2 [
|
||||||
|
[ ] [
|
||||||
|
<process>
|
||||||
|
"cmd.exe /c dir" >>command
|
||||||
|
"dir.txt" temp-file >>stdout
|
||||||
|
try-process
|
||||||
|
] unit-test
|
||||||
|
|
||||||
|
[ ] [ "dir.txt" temp-file delete-file ] unit-test
|
||||||
|
] times
|
||||||
|
|
|
@ -39,7 +39,7 @@ IN: io.windows.nt.launcher
|
||||||
create-mode
|
create-mode
|
||||||
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
FILE_ATTRIBUTE_NORMAL ! flags and attributes
|
||||||
f ! template file
|
f ! template file
|
||||||
CreateFile dup invalid-handle? dup close-later ;
|
CreateFile dup invalid-handle? dup close-always ;
|
||||||
|
|
||||||
: set-inherit ( handle ? -- )
|
: set-inherit ( handle ? -- )
|
||||||
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
|
>r HANDLE_FLAG_INHERIT r> >BOOLEAN SetHandleInformation win32-error=0/f ;
|
||||||
|
|
|
@ -2,7 +2,7 @@ USING: continuations documents ui.tools.interactor
|
||||||
ui.tools.listener hashtables kernel namespaces parser sequences
|
ui.tools.listener hashtables kernel namespaces parser sequences
|
||||||
tools.test ui.commands ui.gadgets ui.gadgets.editors
|
tools.test ui.commands ui.gadgets ui.gadgets.editors
|
||||||
ui.gadgets.panes vocabs words tools.test.ui slots.private
|
ui.gadgets.panes vocabs words tools.test.ui slots.private
|
||||||
threads ;
|
threads arrays generic ;
|
||||||
IN: ui.tools.listener.tests
|
IN: ui.tools.listener.tests
|
||||||
|
|
||||||
[ f ] [ "word" source-editor command-map empty? ] unit-test
|
[ f ] [ "word" source-editor command-map empty? ] unit-test
|
||||||
|
@ -13,11 +13,11 @@ IN: ui.tools.listener.tests
|
||||||
|
|
||||||
"listener" get [
|
"listener" get [
|
||||||
[ "dup" ] [
|
[ "dup" ] [
|
||||||
\ dup "listener" get word-completion-string
|
\ dup word-completion-string
|
||||||
] unit-test
|
] unit-test
|
||||||
|
|
||||||
[ "USE: slots.private slot" ]
|
[ "equal?" ]
|
||||||
[ \ slot "listener" get word-completion-string ] unit-test
|
[ \ array \ equal? method word-completion-string ] unit-test
|
||||||
|
|
||||||
<pane> <interactor> "i" set
|
<pane> <interactor> "i" set
|
||||||
|
|
||||||
|
|
|
@ -7,7 +7,7 @@ ui.gadgets ui.gadgets.editors ui.gadgets.labelled
|
||||||
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
|
ui.gadgets.panes ui.gadgets.buttons ui.gadgets.scrollers
|
||||||
ui.gadgets.tracks ui.gestures ui.operations vocabs words
|
ui.gadgets.tracks ui.gestures ui.operations vocabs words
|
||||||
prettyprint listener debugger threads boxes concurrency.flags
|
prettyprint listener debugger threads boxes concurrency.flags
|
||||||
math arrays generic accessors ;
|
math arrays generic accessors combinators ;
|
||||||
IN: ui.tools.listener
|
IN: ui.tools.listener
|
||||||
|
|
||||||
TUPLE: listener-gadget input output stack ;
|
TUPLE: listener-gadget input output stack ;
|
||||||
|
@ -101,26 +101,32 @@ M: listener-operation invoke-command ( target command -- )
|
||||||
: clear-stack ( listener -- )
|
: clear-stack ( listener -- )
|
||||||
[ clear ] swap (call-listener) ;
|
[ clear ] swap (call-listener) ;
|
||||||
|
|
||||||
GENERIC# word-completion-string 1 ( word listener -- string )
|
GENERIC: word-completion-string ( word -- string )
|
||||||
|
|
||||||
|
M: word word-completion-string
|
||||||
|
word-name ;
|
||||||
|
|
||||||
M: method-body word-completion-string
|
M: method-body word-completion-string
|
||||||
>r "method-generic" word-prop r> word-completion-string ;
|
"method-generic" word-prop word-completion-string ;
|
||||||
|
|
||||||
USE: generic.standard.engines.tuple
|
USE: generic.standard.engines.tuple
|
||||||
|
|
||||||
M: tuple-dispatch-engine-word word-completion-string
|
M: tuple-dispatch-engine-word word-completion-string
|
||||||
>r "engine-generic" word-prop r> word-completion-string ;
|
"engine-generic" word-prop word-completion-string ;
|
||||||
|
|
||||||
M: word word-completion-string ( word listener -- string )
|
: use-if-necessary ( word seq -- )
|
||||||
>r [ word-name ] [ word-vocabulary ] bi dup vocab-words r>
|
>r word-vocabulary vocab-words r>
|
||||||
input>> interactor-use memq?
|
{
|
||||||
[ drop ] [ [ "USE: " % % " " % % ] "" make ] if ;
|
{ [ dup not ] [ 2drop ] }
|
||||||
|
{ [ 2dup memq? ] [ 2drop ] }
|
||||||
|
{ [ t ] [ push ] }
|
||||||
|
} cond ;
|
||||||
|
|
||||||
: insert-word ( word -- )
|
: insert-word ( word -- )
|
||||||
get-workspace
|
get-workspace workspace-listener input>>
|
||||||
workspace-listener
|
[ >r word-completion-string r> user-input ]
|
||||||
[ word-completion-string ] keep
|
[ interactor-use use-if-necessary ]
|
||||||
input>> user-input ;
|
2bi ;
|
||||||
|
|
||||||
: quot-action ( interactor -- lines )
|
: quot-action ( interactor -- lines )
|
||||||
dup control-value
|
dup control-value
|
||||||
|
|
|
@ -315,8 +315,6 @@ INLINE void* allot_object(CELL type, CELL a)
|
||||||
{
|
{
|
||||||
CELL *object;
|
CELL *object;
|
||||||
|
|
||||||
/* If the object is bigger than the nursery, allocate it in
|
|
||||||
tenured space */
|
|
||||||
if(nursery->size - ALLOT_BUFFER_ZONE > a)
|
if(nursery->size - ALLOT_BUFFER_ZONE > a)
|
||||||
{
|
{
|
||||||
/* If there is insufficient room, collect the nursery */
|
/* If there is insufficient room, collect the nursery */
|
||||||
|
@ -325,6 +323,8 @@ INLINE void* allot_object(CELL type, CELL a)
|
||||||
|
|
||||||
object = allot_zone(nursery,a);
|
object = allot_zone(nursery,a);
|
||||||
}
|
}
|
||||||
|
/* If the object is bigger than the nursery, allocate it in
|
||||||
|
tenured space */
|
||||||
else
|
else
|
||||||
{
|
{
|
||||||
F_ZONE *tenured = &data_heap->generations[TENURED];
|
F_ZONE *tenured = &data_heap->generations[TENURED];
|
||||||
|
|
|
@ -145,3 +145,9 @@ DEFINE_PRIMITIVE(call_clear)
|
||||||
{
|
{
|
||||||
throw_impl(dpop(),stack_chain->callstack_bottom);
|
throw_impl(dpop(),stack_chain->callstack_bottom);
|
||||||
}
|
}
|
||||||
|
|
||||||
|
/* For testing purposes */
|
||||||
|
DEFINE_PRIMITIVE(unimplemented)
|
||||||
|
{
|
||||||
|
not_implemented_error();
|
||||||
|
}
|
||||||
|
|
|
@ -55,3 +55,5 @@ void *signal_callstack_top;
|
||||||
void memory_signal_handler_impl(void);
|
void memory_signal_handler_impl(void);
|
||||||
void divide_by_zero_signal_handler_impl(void);
|
void divide_by_zero_signal_handler_impl(void);
|
||||||
void misc_signal_handler_impl(void);
|
void misc_signal_handler_impl(void);
|
||||||
|
|
||||||
|
DECLARE_PRIMITIVE(unimplemented);
|
||||||
|
|
|
@ -215,7 +215,7 @@ void sleep_millis(DWORD msec)
|
||||||
Sleep(msec);
|
Sleep(msec);
|
||||||
}
|
}
|
||||||
|
|
||||||
DECLARE_PRIMITIVE(set_os_envs)
|
DEFINE_PRIMITIVE(set_os_envs)
|
||||||
{
|
{
|
||||||
not_implemented_error();
|
not_implemented_error();
|
||||||
}
|
}
|
||||||
|
|
|
@ -187,4 +187,5 @@ void *primitives[] = {
|
||||||
primitive_resize_bit_array,
|
primitive_resize_bit_array,
|
||||||
primitive_resize_float_array,
|
primitive_resize_float_array,
|
||||||
primitive_dll_validp,
|
primitive_dll_validp,
|
||||||
|
primitive_unimplemented,
|
||||||
};
|
};
|
||||||
|
|
Loading…
Reference in New Issue