Merge commit 'origin/master' into emacs
Jose A. Ortega Ruiz
commit
c6f2e9365b
|
|
@ -2,17 +2,17 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes continuations destructors kernel math
|
||||
namespaces sequences classes.tuple words strings
|
||||
tools.walker accessors combinators fry ;
|
||||
tools.walker accessors combinators fry db.errors ;
|
||||
IN: db
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: db-connection
|
||||
handle
|
||||
insert-statements
|
||||
update-statements
|
||||
delete-statements ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: new-db-connection ( class -- obj )
|
||||
new
|
||||
H{ } clone >>insert-statements
|
||||
|
|
@ -23,6 +23,7 @@ PRIVATE>
|
|||
|
||||
GENERIC: db-open ( db -- db-connection )
|
||||
HOOK: db-close db-connection ( handle -- )
|
||||
HOOK: parse-db-error db-connection ( error -- error' )
|
||||
|
||||
: dispose-statements ( assoc -- ) values dispose-each ;
|
||||
|
||||
|
|
@ -77,7 +78,11 @@ GENERIC: bind-tuple ( tuple statement -- )
|
|||
GENERIC: execute-statement* ( statement type -- )
|
||||
|
||||
M: object execute-statement* ( statement type -- )
|
||||
drop query-results dispose ;
|
||||
'[
|
||||
_ _ drop query-results dispose
|
||||
] [
|
||||
parse-db-error rethrow
|
||||
] recover ;
|
||||
|
||||
: execute-one-statement ( statement -- )
|
||||
dup type>> execute-statement* ;
|
||||
|
|
|
|||
|
|
@ -1,10 +1,54 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel ;
|
||||
USING: accessors kernel continuations fry words ;
|
||||
IN: db.errors
|
||||
|
||||
ERROR: db-error ;
|
||||
ERROR: sql-error ;
|
||||
ERROR: sql-error location ;
|
||||
|
||||
ERROR: table-exists ;
|
||||
ERROR: bad-schema ;
|
||||
|
||||
ERROR: sql-unknown-error < sql-error message ;
|
||||
: <sql-unknown-error> ( message -- error )
|
||||
\ sql-unknown-error new
|
||||
swap >>message ;
|
||||
|
||||
ERROR: sql-table-exists < sql-error table ;
|
||||
: <sql-table-exists> ( table -- error )
|
||||
\ sql-table-exists new
|
||||
swap >>table ;
|
||||
|
||||
ERROR: sql-table-missing < sql-error table ;
|
||||
: <sql-table-missing> ( table -- error )
|
||||
\ sql-table-missing new
|
||||
swap >>table ;
|
||||
|
||||
ERROR: sql-syntax-error < sql-error message ;
|
||||
: <sql-syntax-error> ( message -- error )
|
||||
\ sql-syntax-error new
|
||||
swap >>message ;
|
||||
|
||||
ERROR: sql-function-exists < sql-error message ;
|
||||
: <sql-function-exists> ( message -- error )
|
||||
\ sql-function-exists new
|
||||
swap >>message ;
|
||||
|
||||
ERROR: sql-function-missing < sql-error message ;
|
||||
: <sql-function-missing> ( message -- error )
|
||||
\ sql-function-missing new
|
||||
swap >>message ;
|
||||
|
||||
: ignore-error ( quot word -- )
|
||||
'[ dup _ execute [ drop ] [ rethrow ] if ] recover ; inline
|
||||
|
||||
: ignore-table-exists ( quot -- )
|
||||
\ sql-table-exists? ignore-error ; inline
|
||||
|
||||
: ignore-table-missing ( quot -- )
|
||||
\ sql-table-missing? ignore-error ; inline
|
||||
|
||||
: ignore-function-exists ( quot -- )
|
||||
\ sql-function-exists? ignore-error ; inline
|
||||
|
||||
: ignore-function-missing ( quot -- )
|
||||
\ sql-function-missing? ignore-error ; inline
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit db db.errors
|
||||
db.errors.postgresql db.postgresql io.files.unique kernel namespaces
|
||||
tools.test db.tester continuations ;
|
||||
IN: db.errors.postgresql.tests
|
||||
|
||||
postgresql-test-db [
|
||||
|
||||
[ "drop table foo;" sql-command ] ignore-errors
|
||||
[ "drop table ship;" sql-command ] ignore-errors
|
||||
|
||||
[
|
||||
"insert into foo (id) values('1');" sql-command
|
||||
] [
|
||||
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
[
|
||||
"create table ship(id integer);" sql-command
|
||||
"create table ship(id integer);" sql-command
|
||||
] [
|
||||
{ [ sql-table-exists? ] [ table>> "ship" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
[
|
||||
"create table foo(id) lol;" sql-command
|
||||
] [
|
||||
sql-syntax-error?
|
||||
] must-fail-with
|
||||
|
||||
] with-db
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel db.errors peg.ebnf strings sequences math
|
||||
combinators.short-circuit accessors math.parser quoting ;
|
||||
IN: db.errors.postgresql
|
||||
|
||||
EBNF: parse-postgresql-sql-error
|
||||
|
||||
Error = "ERROR:" [ ]+
|
||||
|
||||
TableError =
|
||||
Error ("relation "|"table ")(!(" already exists").)+:table " already exists"
|
||||
=> [[ table >string unquote <sql-table-exists> ]]
|
||||
| Error ("relation "|"table ")(!(" does not exist").)+:table " does not exist"
|
||||
=> [[ table >string unquote <sql-table-missing> ]]
|
||||
|
||||
FunctionError =
|
||||
Error "function" (!(" already exists").)+:table " already exists"
|
||||
=> [[ table >string <sql-function-exists> ]]
|
||||
| Error "function" (!(" does not exist").)+:table " does not exist"
|
||||
=> [[ table >string <sql-function-missing> ]]
|
||||
|
||||
SyntaxError =
|
||||
Error "syntax error at end of input":error
|
||||
=> [[ error >string <sql-syntax-error> ]]
|
||||
| Error "syntax error at or near " .+:syntaxerror
|
||||
=> [[ syntaxerror >string unquote <sql-syntax-error> ]]
|
||||
|
||||
UnknownError = .* => [[ >string <sql-unknown-error> ]]
|
||||
|
||||
PostgresqlSqlError = (TableError | FunctionError | SyntaxError | UnknownError)
|
||||
|
||||
;EBNF
|
||||
|
||||
|
||||
ERROR: parse-postgresql-location column line text ;
|
||||
C: <parse-postgresql-location> parse-postgresql-location
|
||||
|
||||
EBNF: parse-postgresql-line-error
|
||||
|
||||
Line = "LINE " [0-9]+:line ": " .+:sql
|
||||
=> [[ f line >string string>number sql >string <parse-postgresql-location> ]]
|
||||
|
||||
;EBNF
|
||||
|
||||
:: set-caret-position ( error caret-line -- error )
|
||||
caret-line length
|
||||
error line>> number>string length "LINE : " length +
|
||||
- [ error ] dip >>column ;
|
||||
|
||||
: postgresql-location ( line column -- obj )
|
||||
[ parse-postgresql-line-error ] dip
|
||||
set-caret-position ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators.short-circuit db db.errors
|
||||
db.errors.sqlite db.sqlite io.files.unique kernel namespaces
|
||||
tools.test ;
|
||||
IN: db.errors.sqlite.tests
|
||||
|
||||
: sqlite-error-test-db-path ( -- path )
|
||||
"sqlite" "error-test" make-unique-file ;
|
||||
|
||||
sqlite-error-test-db-path <sqlite-db> [
|
||||
|
||||
[
|
||||
"insert into foo (id) values('1');" sql-command
|
||||
] [
|
||||
{ [ sql-table-missing? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
[
|
||||
"create table foo(id);" sql-command
|
||||
"create table foo(id);" sql-command
|
||||
] [
|
||||
{ [ sql-table-exists? ] [ table>> "foo" = ] } 1&&
|
||||
] must-fail-with
|
||||
|
||||
] with-db
|
||||
|
|
@ -0,0 +1,25 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors combinators db kernel sequences peg.ebnf
|
||||
strings db.errors ;
|
||||
IN: db.errors.sqlite
|
||||
|
||||
ERROR: unparsed-sqlite-error error ;
|
||||
|
||||
SINGLETONS: table-exists table-missing ;
|
||||
|
||||
: sqlite-table-error ( table message -- error )
|
||||
{
|
||||
{ table-exists [ <sql-table-exists> ] }
|
||||
} case ;
|
||||
|
||||
EBNF: parse-sqlite-sql-error
|
||||
|
||||
TableMessage = " already exists" => [[ table-exists ]]
|
||||
|
||||
SqliteError =
|
||||
"table " (!(TableMessage).)+:table TableMessage:message
|
||||
=> [[ table >string message sqlite-table-error ]]
|
||||
| "no such table: " .+:table
|
||||
=> [[ table >string <sql-table-missing> ]]
|
||||
;EBNF
|
||||
|
|
@ -1,20 +1,13 @@
|
|||
USING: kernel db.postgresql alien continuations io classes
|
||||
prettyprint sequences namespaces tools.test db db.private
|
||||
db.tuples db.types unicode.case accessors system ;
|
||||
db.tuples db.types unicode.case accessors system db.tester ;
|
||||
IN: db.postgresql.tests
|
||||
|
||||
: test-db ( -- postgresql-db )
|
||||
<postgresql-db>
|
||||
"localhost" >>host
|
||||
"postgres" >>username
|
||||
"thepasswordistrust" >>password
|
||||
"factor-test" >>database ;
|
||||
|
||||
os windows? cpu x86.64? and [
|
||||
[ ] [ test-db [ ] with-db ] unit-test
|
||||
[ ] [ postgresql-test-db [ ] with-db ] unit-test
|
||||
|
||||
[ ] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
[ "drop table person;" sql-command ] ignore-errors
|
||||
"create table person (name varchar(30), country varchar(30));"
|
||||
sql-command
|
||||
|
|
@ -30,7 +23,7 @@ os windows? cpu x86.64? and [
|
|||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
"select * from person" sql-query
|
||||
] with-db
|
||||
] unit-test
|
||||
|
|
@ -40,11 +33,11 @@ os windows? cpu x86.64? and [
|
|||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] with-db
|
||||
|
|
@ -56,10 +49,10 @@ os windows? cpu x86.64? and [
|
|||
{ "Jane" "New Zealand" }
|
||||
{ "Jimmy" "Canada" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
] [ postgresql-test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
|
|
@ -69,14 +62,14 @@ os windows? cpu x86.64? and [
|
|||
] must-fail
|
||||
|
||||
[ 3 ] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
|
|
@ -87,7 +80,7 @@ os windows? cpu x86.64? and [
|
|||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
test-db [
|
||||
postgresql-test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -5,8 +5,8 @@ kernel math math.parser namespaces make prettyprint quotations
|
|||
sequences debugger db db.postgresql.lib db.postgresql.ffi
|
||||
db.tuples db.types tools.annotations math.ranges
|
||||
combinators classes locals words tools.walker db.private
|
||||
nmake accessors random db.queries destructors db.tuples.private ;
|
||||
USE: tools.walker
|
||||
nmake accessors random db.queries destructors db.tuples.private
|
||||
db.postgresql db.errors.postgresql splitting ;
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db host port pgopts pgtty database username password ;
|
||||
|
|
@ -280,3 +280,14 @@ M: postgresql-db-connection compound ( string object -- string' )
|
|||
{ "references" [ >reference-string ] }
|
||||
[ drop no-compound-found ]
|
||||
} case ;
|
||||
|
||||
M: postgresql-db-connection parse-db-error
|
||||
"\n" split dup length {
|
||||
{ 1 [ first parse-postgresql-sql-error ] }
|
||||
{ 3 [
|
||||
first3
|
||||
[ parse-postgresql-sql-error ] 2dip
|
||||
postgresql-location >>location
|
||||
] }
|
||||
} case ;
|
||||
|
||||
|
|
|
|||
|
|
@ -5,19 +5,23 @@ namespaces sequences db.sqlite.ffi db combinators
|
|||
continuations db.types calendar.format serialize
|
||||
io.streams.byte-array byte-arrays io.encodings.binary
|
||||
io.backend db.errors present urls io.encodings.utf8
|
||||
io.encodings.string accessors shuffle io prettyprint
|
||||
db.private ;
|
||||
io.encodings.string accessors shuffle io db.private ;
|
||||
IN: db.sqlite.lib
|
||||
|
||||
ERROR: sqlite-error < db-error n string ;
|
||||
ERROR: sqlite-sql-error < sql-error n string ;
|
||||
|
||||
: <sqlite-sql-error> ( n string -- error )
|
||||
\ sqlite-sql-error new
|
||||
swap >>string
|
||||
swap >>n ;
|
||||
|
||||
: throw-sqlite-error ( n -- * )
|
||||
dup sqlite-error-messages nth sqlite-error ;
|
||||
|
||||
: sqlite-statement-error ( -- * )
|
||||
SQLITE_ERROR
|
||||
db-connection get handle>> sqlite3_errmsg sqlite-sql-error ;
|
||||
db-connection get handle>> sqlite3_errmsg <sqlite-sql-error> throw ;
|
||||
|
||||
: sqlite-check-result ( n -- )
|
||||
{
|
||||
|
|
@ -125,8 +129,7 @@ ERROR: sqlite-sql-error < sql-error n string ;
|
|||
] if* (sqlite-bind-type) ;
|
||||
|
||||
: sqlite-finalize ( handle -- ) sqlite3_finalize sqlite-check-result ;
|
||||
: sqlite-reset ( handle -- )
|
||||
"resetting: " write dup . sqlite3_reset sqlite-check-result ;
|
||||
: sqlite-reset ( handle -- ) sqlite3_reset sqlite-check-result ;
|
||||
: sqlite-clear-bindings ( handle -- )
|
||||
sqlite3_clear_bindings sqlite-check-result ;
|
||||
: sqlite-#columns ( query -- int ) sqlite3_column_count ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
USING: io io.files io.files.temp io.directories io.launcher
|
||||
kernel namespaces prettyprint tools.test db.sqlite db sequences
|
||||
continuations db.types db.tuples unicode.case ;
|
||||
continuations db.types db.tuples unicode.case accessors arrays
|
||||
sorting ;
|
||||
IN: db.sqlite.tests
|
||||
|
||||
: db-path ( -- path ) "test.db" temp-file ;
|
||||
|
|
@ -74,8 +75,9 @@ IN: db.sqlite.tests
|
|||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ \ swap ensure-table ] must-fail
|
||||
|
||||
! You don't need a primary key
|
||||
USING: accessors arrays sorting ;
|
||||
TUPLE: things one two ;
|
||||
|
||||
things "THINGS" {
|
||||
|
|
@ -115,18 +117,14 @@ hi "HELLO" {
|
|||
1 <foo> insert-tuple
|
||||
f <foo> select-tuple
|
||||
1 1 <hi> insert-tuple
|
||||
f <hi> select-tuple
|
||||
f f <hi> select-tuple
|
||||
hi drop-table
|
||||
foo drop-table
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ ] [
|
||||
test.db [
|
||||
hi create-table
|
||||
hi drop-table
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
! Test SQLite triggers
|
||||
|
||||
TUPLE: show id ;
|
||||
TUPLE: user username data ;
|
||||
|
|
@ -142,12 +140,12 @@ show "SHOW" {
|
|||
} define-persistent
|
||||
|
||||
watch "WATCH" {
|
||||
{ "user" "USER" TEXT +not-null+
|
||||
{ +foreign-id+ user "USERNAME" } +user-assigned-id+ }
|
||||
{ "show" "SHOW" BIG-INTEGER +not-null+
|
||||
{ +foreign-id+ show "ID" } +user-assigned-id+ }
|
||||
{ "user" "USER" TEXT +not-null+ +user-assigned-id+
|
||||
{ +foreign-id+ user "USERNAME" } }
|
||||
{ "show" "SHOW" BIG-INTEGER +not-null+ +user-assigned-id+
|
||||
{ +foreign-id+ show "ID" } }
|
||||
} define-persistent
|
||||
|
||||
|
||||
[ T{ user { username "littledan" } { data "foo" } } ] [
|
||||
test.db [
|
||||
user create-table
|
||||
|
|
@ -158,10 +156,9 @@ watch "WATCH" {
|
|||
show new insert-tuple
|
||||
show new select-tuple
|
||||
"littledan" f user boa select-tuple
|
||||
[ id>> ] [ username>> ] bi*
|
||||
watch boa insert-tuple
|
||||
watch new select-tuple
|
||||
user>> f user boa select-tuple
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ \ swap ensure-table ] must-fail
|
||||
|
|
|
|||
|
|
@ -1,12 +1,13 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays assocs classes compiler db hashtables
|
||||
io.files kernel math math.parser namespaces prettyprint
|
||||
io.files kernel math math.parser namespaces prettyprint fry
|
||||
sequences strings classes.tuple alien.c-types continuations
|
||||
db.sqlite.lib db.sqlite.ffi db.tuples words db.types combinators
|
||||
math.intervals io nmake accessors vectors math.ranges random
|
||||
math.bitwise db.queries destructors db.tuples.private interpolate
|
||||
io.streams.string multiline make db.private ;
|
||||
io.streams.string multiline make db.private sequences.deep
|
||||
db.errors.sqlite ;
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db path ;
|
||||
|
|
@ -126,30 +127,6 @@ M: sqlite-statement query-results ( query -- result-set )
|
|||
dup handle>> sqlite-result-set new-result-set
|
||||
dup advance-row ;
|
||||
|
||||
M: sqlite-db-connection create-sql-statement ( class -- statement )
|
||||
[
|
||||
dupd
|
||||
"create table " 0% 0%
|
||||
"(" 0% [ ", " 0% ] [
|
||||
dup "sql-spec" set
|
||||
dup column-name>> [ "table-id" set ] [ 0% ] bi
|
||||
" " 0%
|
||||
dup type>> lookup-create-type 0%
|
||||
modifiers 0%
|
||||
] interleave
|
||||
|
||||
find-primary-key [
|
||||
", " 0%
|
||||
"primary key(" 0%
|
||||
[ "," 0% ] [ column-name>> 0% ] interleave
|
||||
")" 0%
|
||||
] unless-empty
|
||||
");" 0%
|
||||
] query-make ;
|
||||
|
||||
M: sqlite-db-connection drop-sql-statement ( class -- statement )
|
||||
[ "drop table " 0% 0% ";" 0% drop ] query-make ;
|
||||
|
||||
M: sqlite-db-connection <insert-db-assigned-statement> ( tuple -- statement )
|
||||
[
|
||||
"insert into " 0% 0%
|
||||
|
|
@ -225,10 +202,10 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: insert-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
|
||||
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE INSERT ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
|
|
@ -237,11 +214,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: insert-trigger-not-null ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
|
||||
CREATE TRIGGER fki_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE INSERT ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE NEW.${foreign-table-id} IS NOT NULL
|
||||
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fki_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
|
||||
WHERE NEW.${table-id} IS NOT NULL
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
|
|
@ -250,11 +227,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: update-trigger ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
|
||||
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE UPDATE ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -262,11 +239,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: update-trigger-not-null ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
|
||||
CREATE TRIGGER fku_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE UPDATE ON ${table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE NEW.${foreign-table-id} IS NOT NULL
|
||||
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fku_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
|
||||
WHERE NEW.${table-id} IS NOT NULL
|
||||
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
|
|
@ -275,11 +252,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: delete-trigger-restrict ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
|
||||
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE DELETE ON ${foreign-table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
|
||||
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fkd_${table-name}_$table-id}_${foreign-table-name}_${foreign-table-id}_id"')
|
||||
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
|
||||
END;
|
||||
"> interpolate
|
||||
] with-string-writer ;
|
||||
|
|
@ -287,7 +264,7 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
: delete-trigger-cascade ( -- string )
|
||||
[
|
||||
<"
|
||||
CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
|
||||
CREATE TRIGGER fkd_${table-name}_${table-id}_${foreign-table-name}_${foreign-table-id}_id
|
||||
BEFORE DELETE ON ${foreign-table-name}
|
||||
FOR EACH ROW BEGIN
|
||||
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
|
||||
|
|
@ -318,14 +295,62 @@ M: sqlite-db-connection persistent-table ( -- assoc )
|
|||
delete-trigger-restrict sqlite-trigger,
|
||||
] if ;
|
||||
|
||||
: create-db-triggers ( sql-specs -- )
|
||||
[ modifiers>> [ +foreign-id+ = ] deep-any? ] filter
|
||||
[
|
||||
[ class>> db-table-name "db-table" set ]
|
||||
[
|
||||
[ "sql-spec" set ]
|
||||
[ column-name>> "table-id" set ]
|
||||
[ ] tri
|
||||
modifiers>> [ [ +foreign-id+ = ] deep-any? ] filter
|
||||
[
|
||||
[ second db-table-name "foreign-table-name" set ]
|
||||
[ third "foreign-table-id" set ] bi
|
||||
create-sqlite-triggers
|
||||
] each
|
||||
] bi
|
||||
] each ;
|
||||
|
||||
: sqlite-create-table ( sql-specs class-name -- )
|
||||
[
|
||||
"create table " 0% 0%
|
||||
"(" 0% [ ", " 0% ] [
|
||||
dup "sql-spec" set
|
||||
dup column-name>> [ "table-id" set ] [ 0% ] bi
|
||||
" " 0%
|
||||
dup type>> lookup-create-type 0%
|
||||
modifiers 0%
|
||||
] interleave
|
||||
] [
|
||||
drop
|
||||
find-primary-key [
|
||||
", " 0%
|
||||
"primary key(" 0%
|
||||
[ "," 0% ] [ column-name>> 0% ] interleave
|
||||
")" 0%
|
||||
] unless-empty
|
||||
");" 0%
|
||||
] 2bi ;
|
||||
|
||||
M: sqlite-db-connection create-sql-statement ( class -- statement )
|
||||
[
|
||||
[ sqlite-create-table ]
|
||||
[ drop create-db-triggers ] 2bi
|
||||
] query-make ;
|
||||
|
||||
M: sqlite-db-connection drop-sql-statement ( class -- statements )
|
||||
[ nip "drop table " 0% 0% ";" 0% ] query-make ;
|
||||
|
||||
M: sqlite-db-connection compound ( string seq -- new-string )
|
||||
over {
|
||||
{ "default" [ first number>string " " glue ] }
|
||||
{ "references" [
|
||||
[ >reference-string ] keep
|
||||
first2 [ db-table-name "foreign-table-name" set ]
|
||||
[ "foreign-table-id" set ] bi*
|
||||
create-sqlite-triggers
|
||||
] }
|
||||
{ "references" [ >reference-string ] }
|
||||
[ 2drop ]
|
||||
} case ;
|
||||
|
||||
M: sqlite-db-connection parse-db-error
|
||||
dup n>> {
|
||||
{ 1 [ string>> parse-sqlite-sql-error ] }
|
||||
[ drop ]
|
||||
} case ;
|
||||
|
|
|
|||
|
|
@ -2,9 +2,42 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: concurrency.combinators db.pools db.sqlite db.tuples
|
||||
db.types kernel math random threads tools.test db sequences
|
||||
io prettyprint ;
|
||||
io prettyprint db.postgresql db.sqlite accessors io.files.temp
|
||||
namespaces fry system ;
|
||||
IN: db.tester
|
||||
|
||||
: postgresql-test-db ( -- postgresql-db )
|
||||
<postgresql-db>
|
||||
"localhost" >>host
|
||||
"postgres" >>username
|
||||
"thepasswordistrust" >>password
|
||||
"factor-test" >>database ;
|
||||
|
||||
: sqlite-test-db ( -- sqlite-db )
|
||||
"tuples-test.db" temp-file <sqlite-db> ;
|
||||
|
||||
|
||||
! These words leak resources, but are useful for interactivel testing
|
||||
: set-sqlite-db ( -- )
|
||||
sqlite-db db-open db-connection set ;
|
||||
|
||||
: set-postgresql-db ( -- )
|
||||
postgresql-db db-open db-connection set ;
|
||||
|
||||
|
||||
: test-sqlite ( quot -- )
|
||||
'[
|
||||
[ ] [ sqlite-test-db _ with-db ] unit-test
|
||||
] call ; inline
|
||||
|
||||
: test-postgresql ( quot -- )
|
||||
'[
|
||||
os windows? cpu x86.64? and [
|
||||
[ ] [ postgresql-test-db _ with-db ] unit-test
|
||||
] unless
|
||||
] call ; inline
|
||||
|
||||
|
||||
TUPLE: test-1 id a b c ;
|
||||
|
||||
test-1 "TEST1" {
|
||||
|
|
@ -23,9 +56,6 @@ test-2 "TEST2" {
|
|||
{ "z" "Z" { VARCHAR 256 } +not-null+ }
|
||||
} define-persistent
|
||||
|
||||
: sqlite-test-db ( -- db ) "test.db" <sqlite-db> ;
|
||||
: test-db ( -- db ) "test.db" <sqlite-db> ;
|
||||
|
||||
: db-tester ( test-db -- )
|
||||
[
|
||||
[
|
||||
|
|
|
|||
|
|
@ -4,40 +4,10 @@ USING: io.files io.files.temp kernel tools.test db db.tuples classes
|
|||
db.types continuations namespaces math math.ranges
|
||||
prettyprint calendar sequences db.sqlite math.intervals
|
||||
db.postgresql accessors random math.bitwise system
|
||||
math.ranges strings urls fry db.tuples.private db.private ;
|
||||
math.ranges strings urls fry db.tuples.private db.private
|
||||
db.tester ;
|
||||
IN: db.tuples.tests
|
||||
|
||||
: sqlite-db ( -- sqlite-db )
|
||||
"tuples-test.db" temp-file <sqlite-db> ;
|
||||
|
||||
: test-sqlite ( quot -- )
|
||||
'[
|
||||
[ ] [
|
||||
"tuples-test.db" temp-file <sqlite-db> _ with-db
|
||||
] unit-test
|
||||
] call ; inline
|
||||
|
||||
: postgresql-db ( -- postgresql-db )
|
||||
<postgresql-db>
|
||||
"localhost" >>host
|
||||
"postgres" >>username
|
||||
"thepasswordistrust" >>password
|
||||
"factor-test" >>database ;
|
||||
|
||||
: test-postgresql ( quot -- )
|
||||
'[
|
||||
os windows? cpu x86.64? and [
|
||||
[ ] [ postgresql-db _ with-db ] unit-test
|
||||
] unless
|
||||
] call ; inline
|
||||
|
||||
! These words leak resources, but are useful for interactivel testing
|
||||
: sqlite-test-db ( -- )
|
||||
sqlite-db db-open db-connection set ;
|
||||
|
||||
: postgresql-test-db ( -- )
|
||||
postgresql-db db-open db-connection set ;
|
||||
|
||||
TUPLE: person the-id the-name the-number the-real
|
||||
ts date time blob factor-blob url ;
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: arrays assocs classes db kernel namespaces
|
||||
classes.tuple words sequences slots math accessors
|
||||
math.parser io prettyprint db.types continuations
|
||||
destructors mirrors sets db.types db.private ;
|
||||
destructors mirrors sets db.types db.private fry
|
||||
combinators.short-circuit db.errors ;
|
||||
IN: db.tuples
|
||||
|
||||
HOOK: create-sql-statement db-connection ( class -- object )
|
||||
|
|
@ -29,7 +30,7 @@ GENERIC: eval-generator ( singleton -- object )
|
|||
|
||||
: resulting-tuple ( exemplar-tuple row out-params -- tuple )
|
||||
rot class new [
|
||||
[ [ slot-name>> ] dip set-slot-named ] curry 2each
|
||||
'[ slot-name>> _ set-slot-named ] 2each
|
||||
] keep ;
|
||||
|
||||
: query-tuples ( exemplar-tuple statement -- seq )
|
||||
|
|
@ -98,33 +99,51 @@ M: query >query clone ;
|
|||
|
||||
M: tuple >query <query> swap >>tuple ;
|
||||
|
||||
ERROR: no-defined-persistent object ;
|
||||
|
||||
: ensure-defined-persistent ( object -- object )
|
||||
dup { [ class? ] [ "db-table" word-prop ] } 1&& [
|
||||
no-defined-persistent
|
||||
] unless ;
|
||||
|
||||
: create-table ( class -- )
|
||||
ensure-defined-persistent
|
||||
create-sql-statement [ execute-statement ] with-disposals ;
|
||||
|
||||
: drop-table ( class -- )
|
||||
ensure-defined-persistent
|
||||
drop-sql-statement [ execute-statement ] with-disposals ;
|
||||
|
||||
: recreate-table ( class -- )
|
||||
ensure-defined-persistent
|
||||
[
|
||||
[ drop-sql-statement [ execute-statement ] with-disposals
|
||||
] curry ignore-errors
|
||||
'[
|
||||
[
|
||||
_ drop-sql-statement [ execute-statement ] with-disposals
|
||||
] ignore-table-missing
|
||||
] ignore-function-missing
|
||||
] [ create-table ] bi ;
|
||||
|
||||
: ensure-table ( class -- ) [ create-table ] curry ignore-errors ;
|
||||
: ensure-table ( class -- )
|
||||
ensure-defined-persistent
|
||||
'[ [ _ create-table ] ignore-table-exists ] ignore-function-exists ;
|
||||
|
||||
: ensure-tables ( classes -- ) [ ensure-table ] each ;
|
||||
|
||||
: insert-tuple ( tuple -- )
|
||||
dup class db-columns find-primary-key db-assigned-id-spec?
|
||||
dup class ensure-defined-persistent
|
||||
db-columns find-primary-key db-assigned-id-spec?
|
||||
[ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
|
||||
|
||||
: update-tuple ( tuple -- )
|
||||
dup class
|
||||
dup class ensure-defined-persistent
|
||||
db-connection get update-statements>> [ <update-tuple-statement> ] cache
|
||||
[ bind-tuple ] keep execute-statement ;
|
||||
|
||||
: delete-tuples ( tuple -- )
|
||||
dup dup class <delete-tuples-statement> [
|
||||
dup
|
||||
dup class ensure-defined-persistent
|
||||
<delete-tuples-statement> [
|
||||
[ bind-tuple ] keep execute-statement
|
||||
] with-disposal ;
|
||||
|
||||
|
|
@ -132,8 +151,8 @@ M: tuple >query <query> swap >>tuple ;
|
|||
>query [ tuple>> ] [ query>statement ] bi do-select ;
|
||||
|
||||
: select-tuple ( query/tuple -- tuple/f )
|
||||
>query 1 >>limit [ tuple>> ] [ query>statement ] bi do-select
|
||||
[ f ] [ first ] if-empty ;
|
||||
>query 1 >>limit [ tuple>> ] [ query>statement ] bi
|
||||
do-select [ f ] [ first ] if-empty ;
|
||||
|
||||
: count-tuples ( query/tuple -- n )
|
||||
>query [ tuple>> ] [ <count-statement> ] bi do-count
|
||||
|
|
|
|||
|
|
@ -1,17 +1,24 @@
|
|||
USING: definitions io.launcher kernel parser words sequences math
|
||||
math.parser namespaces editors make system ;
|
||||
math.parser namespaces editors make system combinators.short-circuit
|
||||
fry threads ;
|
||||
IN: editors.emacs
|
||||
|
||||
SYMBOL: emacsclient-path
|
||||
|
||||
HOOK: default-emacsclient os ( -- path )
|
||||
|
||||
M: object default-emacsclient ( -- path ) "emacsclient" ;
|
||||
|
||||
: emacsclient ( file line -- )
|
||||
[
|
||||
\ emacsclient get "emacsclient" or ,
|
||||
os windows? [ "--no-wait" , ] unless
|
||||
"+" swap number>string append ,
|
||||
{ [ \ emacsclient-path get ] [ default-emacsclient ] } 0|| ,
|
||||
"--no-wait" ,
|
||||
number>string "+" prepend ,
|
||||
,
|
||||
] { } make try-process ;
|
||||
] { } make
|
||||
os windows? [ run-detached drop ] [ try-process ] if ;
|
||||
|
||||
: emacs ( word -- )
|
||||
where first2 emacsclient ;
|
||||
|
||||
[ emacsclient ] edit-hook set-global
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,12 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: editors.emacs io.directories.search.windows kernel sequences
|
||||
system combinators.short-circuit ;
|
||||
IN: editors.emacs.windows
|
||||
|
||||
M: windows default-emacsclient
|
||||
{
|
||||
[ "Emacs" t [ "emacsclientw.exe" tail? ] find-in-program-files ]
|
||||
[ "Emacs" t [ "emacsclient.exe" tail? ] find-in-program-files ]
|
||||
[ "emacsclient.exe" ]
|
||||
} 0|| ;
|
||||
|
|
@ -57,8 +57,14 @@ PRIVATE>
|
|||
pusher [ [ f ] compose iterate-directory drop ] dip
|
||||
] [ drop f ] recover ; inline
|
||||
|
||||
ERROR: file-not-found ;
|
||||
|
||||
: find-in-directories ( directories bfs? quot: ( obj -- ? ) -- path'/f )
|
||||
'[ _ _ find-file ] attempt-all ;
|
||||
[
|
||||
'[ _ _ find-file [ file-not-found ] unless* ] attempt-all
|
||||
] [
|
||||
drop f
|
||||
] recover ;
|
||||
|
||||
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
|
||||
'[ _ _ find-all-files ] map concat ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Daniel Ehrenberg
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.syntax help.markup math ;
|
||||
IN: math.bits
|
||||
|
||||
ABOUT: "math.bits"
|
||||
|
||||
ARTICLE: "math.bits" "Number bits virtual sequence"
|
||||
{ $subsection bits }
|
||||
{ $subsection <bits> }
|
||||
{ $subsection make-bits } ;
|
||||
|
||||
HELP: bits
|
||||
{ $class-description "Virtual sequence class of bits of a number. The first bit is the least significant bit. This can be constructed with " { $link <bits> } " or " { $link make-bits } "." } ;
|
||||
|
||||
HELP: <bits>
|
||||
{ $values { "number" integer } { "length" integer } { "bits" bits } }
|
||||
{ $description "Creates a virtual sequence of bits of a number in little endian order, with the given length." } ;
|
||||
|
||||
HELP: make-bits
|
||||
{ $values { "number" integer } { "bits" bits } }
|
||||
{ $description "Creates a " { $link bits } " object out of the given number, using its log base 2 as the length. This implies that the last element, corresponding to the most significant bit, will be 1." }
|
||||
{ $examples
|
||||
{ $example "USING: math.bits prettyprint arrays ;" "BIN: 1101 make-bits >array ." "{ t f t t }" }
|
||||
{ $example "USING: math.bits prettyprint arrays ;" "-3 make-bits >array ." "{ t f }" }
|
||||
} ;
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test math.bits sequences arrays ;
|
||||
IN: math.bits.tests
|
||||
|
||||
[ t ] [ BIN: 111111 3 <bits> second ] unit-test
|
||||
[ { t t t } ] [ BIN: 111111 3 <bits> >array ] unit-test
|
||||
[ f ] [ BIN: 111101 3 <bits> second ] unit-test
|
||||
[ { f f t } ] [ BIN: 111100 3 <bits> >array ] unit-test
|
||||
[ 3 ] [ BIN: 111111 3 <bits> length ] unit-test
|
||||
[ 6 ] [ BIN: 111111 make-bits length ] unit-test
|
||||
[ 0 ] [ 0 make-bits length ] unit-test
|
||||
[ 2 ] [ 3 make-bits length ] unit-test
|
||||
[ 2 ] [ -3 make-bits length ] unit-test
|
||||
[ 1 ] [ 1 make-bits length ] unit-test
|
||||
[ 1 ] [ -1 make-bits length ] unit-test
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2009 Daniel Ehrenberg
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences kernel math accessors sequences.private ;
|
||||
IN: math.bits
|
||||
|
||||
TUPLE: bits { number read-only } { length read-only } ;
|
||||
C: <bits> bits
|
||||
|
||||
: make-bits ( number -- bits )
|
||||
dup zero? [ drop T{ bits f 0 0 } ] [ dup abs log2 1+ <bits> ] if ; inline
|
||||
|
||||
M: bits length length>> ;
|
||||
|
||||
M: bits nth-unsafe number>> swap bit? ;
|
||||
|
||||
INSTANCE: bits immutable-sequence
|
||||
|
|
@ -0,0 +1 @@
|
|||
Virtual sequence for bits of an integer
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.functions sequences
|
||||
USING: arrays kernel math sequences accessors math.bits
|
||||
sequences.private words namespaces macros hints
|
||||
combinators fry io.binary combinators.smart ;
|
||||
IN: math.bitwise
|
||||
|
|
@ -65,7 +65,7 @@ DEFER: byte-bit-count
|
|||
|
||||
\ byte-bit-count
|
||||
256 [
|
||||
0 swap [ [ 1+ ] when ] each-bit
|
||||
8 <bits> 0 [ [ 1+ ] when ] reduce
|
||||
] B{ } map-as '[ HEX: ff bitand _ nth-unsafe ]
|
||||
(( byte -- table )) define-declared
|
||||
|
||||
|
|
|
|||
|
|
@ -278,14 +278,6 @@ HELP: mod-inv
|
|||
{ $example "USING: math prettyprint ;" "173 815 * 1119 mod ." "1" }
|
||||
} ;
|
||||
|
||||
HELP: each-bit
|
||||
{ $values { "n" integer } { "quot" { $quotation "( ? -- )" } } }
|
||||
{ $description "Applies the quotation to each bit of the integer, starting from the least significant bit, and stopping at the last bit from which point on all bits are either clear (if the integer is positive) or all bits are set (if the integer is negataive)." }
|
||||
{ $examples
|
||||
{ $example "USING: math.functions make prettyprint ;" "[ BIN: 1101 [ , ] each-bit ] { } make ." "{ t f t t }" }
|
||||
{ $example "USING: math.functions make prettyprint ;" "[ -3 [ , ] each-bit ] { } make ." "{ t f }" }
|
||||
} ;
|
||||
|
||||
HELP: ~
|
||||
{ $values { "x" real } { "y" real } { "epsilon" real } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "x" } " and " { $snippet "y" } " are approximately equal to each other. There are three possible comparison tests, chosen based on the sign of " { $snippet "epsilon" } ":"
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math kernel math.constants math.private
|
||||
USING: math kernel math.constants math.private math.bits
|
||||
math.libm combinators math.order sequences ;
|
||||
IN: math.functions
|
||||
|
||||
|
|
@ -26,16 +26,6 @@ GENERIC: sqrt ( x -- y ) foldable
|
|||
M: real sqrt
|
||||
>float dup 0.0 < [ neg fsqrt 0.0 swap rect> ] [ fsqrt ] if ;
|
||||
|
||||
: each-bit ( n quot: ( ? -- ) -- )
|
||||
over [ 0 = ] [ -1 = ] bi or [
|
||||
2drop
|
||||
] [
|
||||
2dup { [ odd? ] [ call ] [ 2/ ] [ each-bit ] } spread
|
||||
] if ; inline recursive
|
||||
|
||||
: map-bits ( n quot: ( ? -- obj ) -- seq )
|
||||
accumulator [ each-bit ] dip ; inline
|
||||
|
||||
: factor-2s ( n -- r s )
|
||||
#! factor an integer into 2^r * s
|
||||
dup 0 = [ 1 ] [
|
||||
|
|
@ -47,7 +37,7 @@ M: real sqrt
|
|||
GENERIC# ^n 1 ( z w -- z^w )
|
||||
|
||||
: (^n) ( z w -- z^w )
|
||||
1 swap [ [ dupd * ] when [ sq ] dip ] each-bit nip ; inline
|
||||
make-bits 1 [ [ dupd * ] when [ sq ] dip ] reduce nip ; inline
|
||||
|
||||
M: integer ^n
|
||||
[ factor-2s ] dip [ (^n) ] keep rot * shift ;
|
||||
|
|
@ -94,9 +84,9 @@ PRIVATE>
|
|||
dup zero? [ drop 0./0. ] [ 0 < 1./0. 0 ? ] if ; inline
|
||||
|
||||
: (^mod) ( n x y -- z )
|
||||
1 swap [
|
||||
make-bits 1 [
|
||||
[ dupd * pick mod ] when [ sq over mod ] dip
|
||||
] each-bit 2nip ; inline
|
||||
] reduce 2nip ; inline
|
||||
|
||||
: (gcd) ( b a x y -- a d )
|
||||
over zero? [
|
||||
|
|
@ -252,14 +242,10 @@ M: real tanh ftanh ;
|
|||
|
||||
: -i* ( x -- y ) >rect swap neg rect> ;
|
||||
|
||||
GENERIC: asin ( x -- y ) foldable
|
||||
|
||||
M: number asin
|
||||
: asin ( x -- y )
|
||||
dup [-1,1]? [ fasin ] [ i* asinh -i* ] if ; inline
|
||||
|
||||
GENERIC: acos ( x -- y ) foldable
|
||||
|
||||
M: number acos
|
||||
: acos ( x -- y )
|
||||
dup [-1,1]? [ facos ] [ asin pi 2 / swap - ] if ;
|
||||
inline
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
USING: multiline kernel sequences io splitting fry namespaces
|
||||
http.parsers hashtables assocs combinators ascii io.files.unique
|
||||
accessors io.encodings.binary io.files byte-arrays math
|
||||
io.streams.string combinators.short-circuit strings math.order ;
|
||||
io.streams.string combinators.short-circuit strings math.order
|
||||
quoting ;
|
||||
IN: mime.multipart
|
||||
|
||||
CONSTANT: buffer-size 65536
|
||||
|
|
@ -75,18 +76,6 @@ ERROR: end-of-stream multipart ;
|
|||
: empty-name? ( string -- ? )
|
||||
{ "''" "\"\"" "" f } member? ;
|
||||
|
||||
: quote? ( ch -- ? ) "'\"" member? ;
|
||||
|
||||
: quoted? ( str -- ? )
|
||||
{
|
||||
[ length 1 > ]
|
||||
[ first quote? ]
|
||||
[ [ first ] [ peek ] bi = ]
|
||||
} 1&& ;
|
||||
|
||||
: unquote ( str -- newstr )
|
||||
dup quoted? [ but-last-slice rest-slice >string ] when ;
|
||||
|
||||
: save-uploaded-file ( multipart -- )
|
||||
dup filename>> empty-name? [
|
||||
drop
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,32 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax strings ;
|
||||
IN: quoting
|
||||
|
||||
HELP: quote?
|
||||
{ $values
|
||||
{ "ch" "a character" }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Returns true if the character is a single or double quote." } ;
|
||||
|
||||
HELP: quoted?
|
||||
{ $values
|
||||
{ "str" string }
|
||||
{ "?" "a boolean" }
|
||||
}
|
||||
{ $description "Returns true if a string is surrounded by matching single or double quotes as the first and last characters." } ;
|
||||
|
||||
HELP: unquote
|
||||
{ $values
|
||||
{ "str" string }
|
||||
{ "newstr" string }
|
||||
}
|
||||
{ $description "Removes a pair of matching single or double quotes from a string." } ;
|
||||
|
||||
ARTICLE: "quoting" "Quotation marks"
|
||||
"The " { $vocab-link "quoting" } " vocabulary is for removing quotes from a string." $nl
|
||||
"Removing quotes:"
|
||||
{ $subsection unquote } ;
|
||||
|
||||
ABOUT: "quoting"
|
||||
|
|
@ -0,0 +1,10 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test quoting ;
|
||||
IN: quoting.tests
|
||||
|
||||
|
||||
[ "abc" ] [ "'abc'" unquote ] unit-test
|
||||
[ "abc" ] [ "\"abc\"" unquote ] unit-test
|
||||
[ "'abc" ] [ "'abc" unquote ] unit-test
|
||||
[ "abc'" ] [ "abc'" unquote ] unit-test
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators.short-circuit kernel math sequences strings ;
|
||||
IN: quoting
|
||||
|
||||
: quote? ( ch -- ? ) "'\"" member? ;
|
||||
|
||||
: quoted? ( str -- ? )
|
||||
{
|
||||
[ length 1 > ]
|
||||
[ first quote? ]
|
||||
[ [ first ] [ peek ] bi = ]
|
||||
} 1&& ;
|
||||
|
||||
: unquote ( str -- newstr )
|
||||
dup quoted? [ but-last-slice rest-slice >string ] when ;
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel strings words ;
|
||||
USING: help.markup help.syntax kernel strings words vocabs ;
|
||||
IN: tools.scaffold
|
||||
|
||||
HELP: developer-name
|
||||
|
|
@ -13,7 +13,7 @@ HELP: help.
|
|||
{ $description "Prints out scaffold help markup for a given word." } ;
|
||||
|
||||
HELP: scaffold-help
|
||||
{ $values { "string" string } }
|
||||
{ $values { "vocab" vocab } }
|
||||
{ $description "Takes an existing vocabulary and creates a help file with scaffolded help for each word. This word only works if no help file yet exists." } ;
|
||||
|
||||
HELP: scaffold-undocumented
|
||||
|
|
@ -28,6 +28,21 @@ HELP: scaffold-vocab
|
|||
{ "vocab-root" "a vocabulary root string" } { "string" string } }
|
||||
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
|
||||
|
||||
HELP: scaffold-emacs
|
||||
{ $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ;
|
||||
|
||||
HELP: scaffold-factor-boot-rc
|
||||
{ $description "Touches the .factor-boot-rc file in your home directory and provides a clickable link to open it in an editor." } ;
|
||||
|
||||
HELP: scaffold-factor-rc
|
||||
{ $description "Touches the .factor-rc file in your home directory and provides a clickable link to open it in an editor." } ;
|
||||
|
||||
HELP: scaffold-rc
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
}
|
||||
{ $description "Touches the given path in your home directory and provides a clickable link to open it in an editor." } ;
|
||||
|
||||
HELP: using
|
||||
{ $description "Stores the vocabularies that are pulled into the documentation file from looking up the stack effect types." } ;
|
||||
|
||||
|
|
@ -40,7 +55,12 @@ ARTICLE: "tools.scaffold" "Scaffold tool"
|
|||
{ $subsection scaffold-help }
|
||||
{ $subsection scaffold-undocumented }
|
||||
{ $subsection help. }
|
||||
"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead."
|
||||
"Types that are unrecognized by the scaffold generator will be of type " { $link null } ". The developer should change these to strings that describe the stack effect names instead." $nl
|
||||
"Scaffolding a configuration file:"
|
||||
{ $subsection scaffold-rc }
|
||||
{ $subsection scaffold-factor-boot-rc }
|
||||
{ $subsection scaffold-factor-rc }
|
||||
{ $subsection scaffold-emacs }
|
||||
;
|
||||
|
||||
ABOUT: "tools.scaffold"
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ io.encodings.utf8 hashtables kernel namespaces sequences
|
|||
vocabs.loader io combinators calendar accessors math.parser
|
||||
io.streams.string ui.tools.operations quotations strings arrays
|
||||
prettyprint words vocabs sorting sets classes math alien urls
|
||||
splitting ascii ;
|
||||
splitting ascii combinators.short-circuit ;
|
||||
IN: tools.scaffold
|
||||
|
||||
SYMBOL: developer-name
|
||||
|
|
@ -18,37 +18,61 @@ ERROR: no-vocab vocab ;
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: root? ( string -- ? ) vocab-roots get member? ;
|
||||
: vocab-root? ( string -- ? ) vocab-roots get member? ;
|
||||
|
||||
: contains-dot? ( string -- ? ) ".." swap subseq? ;
|
||||
|
||||
: contains-separator? ( string -- ? ) [ path-separator? ] any? ;
|
||||
|
||||
: check-vocab-name ( string -- string )
|
||||
dup contains-dot? [ vocab-name-contains-dot ] when
|
||||
dup contains-separator? [ vocab-name-contains-separator ] when ;
|
||||
[ ]
|
||||
[ contains-dot? [ vocab-name-contains-dot ] when ]
|
||||
[ contains-separator? [ vocab-name-contains-separator ] when ] tri ;
|
||||
|
||||
: check-root ( string -- string )
|
||||
dup root? [ not-a-vocab-root ] unless ;
|
||||
dup vocab-root? [ not-a-vocab-root ] unless ;
|
||||
|
||||
: check-vocab ( vocab -- vocab )
|
||||
dup find-vocab-root [ no-vocab ] unless ;
|
||||
|
||||
: check-vocab-root/vocab ( vocab-root string -- vocab-root string )
|
||||
[ check-root ] [ check-vocab-name ] bi* ;
|
||||
|
||||
: replace-vocab-separators ( vocab -- path )
|
||||
path-separator first CHAR: . associate substitute ; inline
|
||||
|
||||
: vocab-root/vocab>path ( vocab-root vocab -- path )
|
||||
check-vocab-root/vocab
|
||||
[ ] [ replace-vocab-separators ] bi* append-path ;
|
||||
|
||||
: vocab>path ( vocab -- path )
|
||||
check-vocab
|
||||
[ find-vocab-root ] keep vocab-root/vocab>path ;
|
||||
|
||||
: vocab-root/vocab/file>path ( vocab-root vocab file -- path )
|
||||
[ vocab-root/vocab>path ] dip append-path ;
|
||||
|
||||
: vocab-root/vocab/suffix>path ( vocab-root vocab suffix -- path )
|
||||
[ vocab-root/vocab>path dup file-name append-path ] dip append ;
|
||||
|
||||
: vocab/suffix>path ( vocab suffix -- path )
|
||||
[ vocab>path dup file-name append-path ] dip append ;
|
||||
|
||||
: directory-exists ( path -- )
|
||||
"Not creating a directory, it already exists: " write print ;
|
||||
|
||||
: scaffold-directory ( path -- )
|
||||
: scaffold-directory ( vocab-root vocab -- )
|
||||
vocab-root/vocab>path
|
||||
dup exists? [ directory-exists ] [ make-directories ] if ;
|
||||
|
||||
: not-scaffolding ( path -- )
|
||||
"Not creating scaffolding for " write <pathname> . ;
|
||||
: not-scaffolding ( path -- path )
|
||||
"Not creating scaffolding for " write dup <pathname> . ;
|
||||
|
||||
: scaffolding ( path -- )
|
||||
"Creating scaffolding for " write <pathname> . ;
|
||||
: scaffolding ( path -- path )
|
||||
"Creating scaffolding for " write dup <pathname> . ;
|
||||
|
||||
: (scaffold-path) ( path string -- path )
|
||||
dupd [ file-name ] dip append append-path ;
|
||||
|
||||
: scaffold-path ( path string -- path ? )
|
||||
(scaffold-path)
|
||||
dup exists? [ dup not-scaffolding f ] [ dup scaffolding t ] if ;
|
||||
: scaffolding? ( path -- path ? )
|
||||
dup exists? [ not-scaffolding f ] [ scaffolding t ] if ;
|
||||
|
||||
: scaffold-copyright ( -- )
|
||||
"! Copyright (C) " write now year>> number>string write
|
||||
|
|
@ -62,37 +86,25 @@ ERROR: no-vocab vocab ;
|
|||
"IN: " write print
|
||||
] with-string-writer ;
|
||||
|
||||
: set-scaffold-main-file ( path vocab -- )
|
||||
main-file-string swap utf8 set-file-contents ;
|
||||
: set-scaffold-main-file ( vocab path -- )
|
||||
[ main-file-string ] dip utf8 set-file-contents ;
|
||||
|
||||
: scaffold-main ( path vocab -- )
|
||||
[ ".factor" scaffold-path ] dip
|
||||
swap [ set-scaffold-main-file ] [ 2drop ] if ;
|
||||
|
||||
: tests-file-string ( vocab -- string )
|
||||
[
|
||||
scaffold-copyright
|
||||
"USING: tools.test " write dup write " ;" print
|
||||
"IN: " write write ".tests" print
|
||||
] with-string-writer ;
|
||||
|
||||
: set-scaffold-tests-file ( path vocab -- )
|
||||
tests-file-string swap utf8 set-file-contents ;
|
||||
|
||||
: scaffold-tests ( path vocab -- )
|
||||
[ "-tests.factor" scaffold-path ] dip
|
||||
swap [ set-scaffold-tests-file ] [ 2drop ] if ;
|
||||
|
||||
: scaffold-authors ( path -- )
|
||||
"authors.txt" append-path dup exists? [
|
||||
not-scaffolding
|
||||
: scaffold-main ( vocab-root vocab -- )
|
||||
tuck ".factor" vocab-root/vocab/suffix>path scaffolding? [
|
||||
set-scaffold-main-file
|
||||
] [
|
||||
dup scaffolding
|
||||
developer-name get swap utf8 set-file-contents
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
: scaffold-authors ( vocab-root vocab -- )
|
||||
"authors.txt" vocab-root/vocab/file>path scaffolding? [
|
||||
[ developer-name get ] dip utf8 set-file-contents
|
||||
] [
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: lookup-type ( string -- object/string ? )
|
||||
"new" ?head drop [ [ CHAR: ' = ] [ digit? ] bi or ] trim-tail
|
||||
"new" ?head drop [ { [ CHAR: ' = ] [ digit? ] } 1|| ] trim-tail
|
||||
H{
|
||||
{ "object" object } { "obj" object }
|
||||
{ "quot" quotation }
|
||||
|
|
@ -134,6 +146,9 @@ ERROR: no-vocab vocab ;
|
|||
" }" write
|
||||
] each ;
|
||||
|
||||
: 4bl ( -- )
|
||||
" " write ; inline
|
||||
|
||||
: $values. ( word -- )
|
||||
"declared-effect" word-prop [
|
||||
[ in>> ] [ out>> ] bi
|
||||
|
|
@ -141,8 +156,8 @@ ERROR: no-vocab vocab ;
|
|||
2drop
|
||||
] [
|
||||
"{ $values" print
|
||||
[ " " write ($values.) ]
|
||||
[ [ nl " " write ($values.) ] unless-empty ] bi*
|
||||
[ 4bl ($values.) ]
|
||||
[ [ nl 4bl ($values.) ] unless-empty ] bi*
|
||||
nl "}" print
|
||||
] if
|
||||
] when* ;
|
||||
|
|
@ -151,21 +166,21 @@ ERROR: no-vocab vocab ;
|
|||
drop
|
||||
"{ $description \"\" } ;" print ;
|
||||
|
||||
: help-header. ( word -- )
|
||||
: docs-header. ( word -- )
|
||||
"HELP: " write name>> print ;
|
||||
|
||||
: (help.) ( word -- )
|
||||
[ help-header. ] [ $values. ] [ $description. ] tri ;
|
||||
[ docs-header. ] [ $values. ] [ $description. ] tri ;
|
||||
|
||||
: interesting-words ( vocab -- array )
|
||||
words
|
||||
[ [ "help" word-prop ] [ predicate? ] bi or not ] filter
|
||||
[ { [ "help" word-prop ] [ predicate? ] } 1|| not ] filter
|
||||
natural-sort ;
|
||||
|
||||
: interesting-words. ( vocab -- )
|
||||
interesting-words [ (help.) nl ] each ;
|
||||
|
||||
: help-file-string ( vocab -- str2 )
|
||||
: docs-file-string ( vocab -- str2 )
|
||||
[
|
||||
{
|
||||
[ "IN: " write print nl ]
|
||||
|
|
@ -186,62 +201,68 @@ ERROR: no-vocab vocab ;
|
|||
[ bl write ] each
|
||||
" ;" print ;
|
||||
|
||||
: set-scaffold-help-file ( path vocab -- )
|
||||
swap utf8 <file-writer> [
|
||||
: set-scaffold-docs-file ( vocab path -- )
|
||||
utf8 <file-writer> [
|
||||
scaffold-copyright
|
||||
[ help-file-string ] [ write-using ] bi
|
||||
[ docs-file-string ] [ write-using ] bi
|
||||
write
|
||||
] with-output-stream ;
|
||||
|
||||
: check-scaffold ( vocab-root string -- vocab-root string )
|
||||
[ check-root ] [ check-vocab-name ] bi* ;
|
||||
|
||||
: vocab>scaffold-path ( vocab-root string -- path )
|
||||
path-separator first CHAR: . associate substitute
|
||||
append-path ;
|
||||
|
||||
: prepare-scaffold ( vocab-root string -- string path )
|
||||
check-scaffold [ vocab>scaffold-path ] keep ;
|
||||
|
||||
: with-scaffold ( quot -- )
|
||||
[ H{ } clone using ] dip with-variable ; inline
|
||||
|
||||
: check-vocab ( vocab -- vocab )
|
||||
dup find-vocab-root [ no-vocab ] unless ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: link-vocab ( vocab -- )
|
||||
check-vocab
|
||||
"Edit documentation: " write
|
||||
[ find-vocab-root ]
|
||||
[ vocab>scaffold-path ] bi
|
||||
"-docs.factor" (scaffold-path) <pathname> . ;
|
||||
"-docs.factor" vocab/suffix>path <pathname> . ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: help. ( word -- )
|
||||
[ (help.) ] [ nl vocabulary>> link-vocab ] bi ;
|
||||
|
||||
: scaffold-help ( string -- )
|
||||
: scaffold-help ( vocab -- )
|
||||
[
|
||||
[ find-vocab-root ] [ check-vocab ] bi
|
||||
prepare-scaffold
|
||||
[ "-docs.factor" scaffold-path ] dip
|
||||
swap [ set-scaffold-help-file ] [ 2drop ] if
|
||||
dup "-docs.factor" vocab/suffix>path scaffolding? [
|
||||
set-scaffold-docs-file
|
||||
] [
|
||||
2drop
|
||||
] if
|
||||
] with-scaffold ;
|
||||
|
||||
: scaffold-undocumented ( string -- )
|
||||
[ interesting-words. ] [ link-vocab ] bi ;
|
||||
|
||||
: scaffold-vocab ( vocab-root string -- )
|
||||
prepare-scaffold
|
||||
{
|
||||
[ drop scaffold-directory ]
|
||||
[ scaffold-directory ]
|
||||
[ scaffold-main ]
|
||||
[ scaffold-tests ]
|
||||
[ drop scaffold-authors ]
|
||||
[ scaffold-authors ]
|
||||
[ nip require ]
|
||||
} 2cleave ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: tests-file-string ( vocab -- string )
|
||||
[
|
||||
scaffold-copyright
|
||||
"USING: tools.test " write dup write " ;" print
|
||||
"IN: " write write ".tests" print
|
||||
] with-string-writer ;
|
||||
|
||||
: set-scaffold-tests-file ( vocab path -- )
|
||||
[ tests-file-string ] dip utf8 set-file-contents ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: scaffold-tests ( vocab -- )
|
||||
dup "-tests.factor" vocab/suffix>path
|
||||
scaffolding? [
|
||||
set-scaffold-tests-file
|
||||
] [
|
||||
2drop
|
||||
] if ;
|
||||
|
||||
SYMBOL: examples-flag
|
||||
|
||||
: example ( -- )
|
||||
|
|
@ -250,7 +271,7 @@ SYMBOL: examples-flag
|
|||
" \"\""
|
||||
" \"\""
|
||||
"}"
|
||||
} [ examples-flag get [ " " write ] when print ] each ;
|
||||
} [ examples-flag get [ 4bl ] when print ] each ;
|
||||
|
||||
: examples ( n -- )
|
||||
t \ examples-flag [
|
||||
|
|
@ -260,10 +281,11 @@ SYMBOL: examples-flag
|
|||
] with-variable ;
|
||||
|
||||
: scaffold-rc ( path -- )
|
||||
[ home ] dip append-path
|
||||
[ touch-file ] [ "Click to edit: " write <pathname> . ] bi ;
|
||||
|
||||
: scaffold-factor-boot-rc ( -- )
|
||||
home ".factor-boot-rc" append-path scaffold-rc ;
|
||||
: scaffold-factor-boot-rc ( -- ) ".factor-boot-rc" scaffold-rc ;
|
||||
|
||||
: scaffold-factor-rc ( -- )
|
||||
home ".factor-rc" append-path scaffold-rc ;
|
||||
: scaffold-factor-rc ( -- ) ".factor-rc" scaffold-rc ;
|
||||
|
||||
: scaffold-emacs ( -- ) ".emacs" scaffold-rc ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel base64 checksums.md5 sequences checksums
|
||||
locals prettyprint math math.bitwise grouping io combinators
|
||||
locals prettyprint math math.bits grouping io combinators
|
||||
fry make combinators.short-circuit math.functions splitting ;
|
||||
IN: crypto.passwd-md5
|
||||
|
||||
|
|
@ -22,8 +22,8 @@ PRIVATE>
|
|||
password length
|
||||
[ 16 / ceiling swap <repetition> concat ] keep
|
||||
head-slice append
|
||||
password [ length ] [ first ] bi
|
||||
'[ [ CHAR: \0 _ ? , ] each-bit ] "" make append
|
||||
password [ length make-bits ] [ first ] bi
|
||||
'[ CHAR: \0 _ ? ] "" map-as append
|
||||
md5 checksum-bytes ] |
|
||||
1000 [
|
||||
"" swap
|
||||
|
|
|
|||
|
|
@ -1,4 +0,0 @@
|
|||
! Copyright (C) 2009 Jason W. Merrill.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test automatic-differentiation.derivatives ;
|
||||
IN: automatic-differentiation.derivatives.tests
|
||||
|
|
@ -10,92 +10,14 @@ HELP: <dual>
|
|||
}
|
||||
{ $description "Creates a dual number from its ordinary and epsilon parts." } ;
|
||||
|
||||
HELP: d*
|
||||
{ $values
|
||||
{ "x" dual } { "y" dual }
|
||||
{ "x*y" dual }
|
||||
}
|
||||
{ $description "Multiply dual numbers." } ;
|
||||
|
||||
HELP: d+
|
||||
{ $values
|
||||
{ "x" dual } { "y" dual }
|
||||
{ "x+y" dual }
|
||||
}
|
||||
{ $description "Add dual numbers." } ;
|
||||
|
||||
HELP: d-
|
||||
{ $values
|
||||
{ "x" dual } { "y" dual }
|
||||
{ "x-y" dual }
|
||||
}
|
||||
{ $description "Subtract dual numbers." } ;
|
||||
|
||||
HELP: d/
|
||||
{ $values
|
||||
{ "x" dual } { "y" dual }
|
||||
{ "x/y" dual }
|
||||
}
|
||||
{ $description "Divide dual numbers." }
|
||||
{ $errors "Throws an error if the ordinary part of " { $snippet "x" } " is zero." } ;
|
||||
|
||||
HELP: d^
|
||||
{ $values
|
||||
{ "x" dual } { "y" dual }
|
||||
{ "x^y" dual }
|
||||
}
|
||||
{ $description "Raise a dual number to a (possibly dual) power" } ;
|
||||
|
||||
HELP: dabs
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "|x|" dual }
|
||||
}
|
||||
{ $description "Absolute value of a dual number." } ;
|
||||
|
||||
HELP: dacosh
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "y" dual }
|
||||
}
|
||||
{ $description "Inverse hyberbolic cosine of a dual number." } ;
|
||||
|
||||
HELP: dasinh
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "y" dual }
|
||||
}
|
||||
{ $description "Inverse hyberbolic sine of a dual number." } ;
|
||||
|
||||
HELP: datanh
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "y" dual }
|
||||
}
|
||||
{ $description "Inverse hyberbolic tangent of a dual number." } ;
|
||||
|
||||
HELP: dneg
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "-x" dual }
|
||||
}
|
||||
{ $description "Negative of a dual number." } ;
|
||||
|
||||
HELP: drecip
|
||||
{ $values
|
||||
{ "x" dual }
|
||||
{ "1/x" dual }
|
||||
}
|
||||
{ $description "Reciprocal of a dual number." } ;
|
||||
|
||||
HELP: define-dual-method
|
||||
HELP: define-dual
|
||||
{ $values
|
||||
{ "word" word }
|
||||
}
|
||||
{ $description "Defines a method on the dual numbers for generic word." }
|
||||
{ $description "Defines a word " { $snippet "d[word]" } " in the " { $vocab-link "math.dual" } " vocabulary that operates on dual numbers." }
|
||||
{ $notes "Uses the derivative word-prop, which holds a list of quotations giving the partial derivatives of the word with respect to each of its arguments. This can be set using " { $link POSTPONE: DERIVATIVE: } "." } ;
|
||||
|
||||
{ define-dual-method dual-op POSTPONE: DERIVATIVE: } related-words
|
||||
{ define-dual dual-op POSTPONE: DERIVATIVE: } related-words
|
||||
|
||||
HELP: dual
|
||||
{ $class-description "The class of dual numbers with non-zero epsilon part." } ;
|
||||
|
|
@ -128,5 +50,4 @@ $nl
|
|||
"Dual numbers are ordered pairs " { $snippet "<o,e>"} "--an ordinary part and an epsilon part--with component-wise addition and multiplication defined by "{ $snippet "<o1,e1>*<o2,e2> = <o1*o2,e1*o2 + e2*o1>" } ". They are analagous to complex numbers with " { $snippet "i^2 = 0" } "instead of " { $snippet "i^2 = -1" } ". For well-behaved functions " { $snippet "f" } ", " { $snippet "f(<o1,e1>) = f(o1) + e1*f'(o1)" } ", where " { $snippet "f'"} " is the derivative of " { $snippet "f" } "."
|
||||
;
|
||||
|
||||
|
||||
ABOUT: "math.dual"
|
||||
|
|
|
|||
|
|
@ -4,13 +4,13 @@ USING: tools.test math.dual kernel accessors math math.functions
|
|||
math.constants ;
|
||||
IN: math.dual.tests
|
||||
|
||||
[ 0.0 1.0 ] [ 0 1 <dual> sin unpack-dual ] unit-test
|
||||
[ 1.0 0.0 ] [ 0 1 <dual> cos unpack-dual ] unit-test
|
||||
[ 0.0 1.0 ] [ 0 1 <dual> dsin unpack-dual ] unit-test
|
||||
[ 1.0 0.0 ] [ 0 1 <dual> dcos unpack-dual ] unit-test
|
||||
[ 3 5 ] [ 1 5 <dual> 2 d+ unpack-dual ] unit-test
|
||||
[ 0 -1 ] [ 1 5 <dual> 1 6 <dual> d- unpack-dual ] unit-test
|
||||
[ 2 1 ] [ 2 3 <dual> 1 -1 <dual> d* unpack-dual ] unit-test
|
||||
[ 1/2 -1/4 ] [ 2 1 <dual> 1 swap d/ unpack-dual ] unit-test
|
||||
[ 2 ] [ 1 1 <dual> 2 d^ epsilon-part>> ] unit-test
|
||||
[ 2.0 .25 ] [ 4 1 <dual> sqrt unpack-dual ] unit-test
|
||||
[ 2.0 .25 ] [ 4 1 <dual> dsqrt unpack-dual ] unit-test
|
||||
[ 2 -1 ] [ -2 1 <dual> dabs unpack-dual ] unit-test
|
||||
[ -2 -1 ] [ 2 1 <dual> dneg unpack-dual ] unit-test
|
||||
|
|
@ -1,8 +1,9 @@
|
|||
! Copyright (C) 2009 Jason W. Merrill.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel math math.functions math.derivatives accessors
|
||||
macros words effects sequences generalizations fry
|
||||
combinators.smart generic compiler.units ;
|
||||
macros generic compiler.units words effects vocabs
|
||||
sequences arrays assocs generalizations fry make
|
||||
combinators.smart help help.markup ;
|
||||
|
||||
IN: math.dual
|
||||
|
||||
|
|
@ -48,6 +49,19 @@ MACRO: chain-rule ( word -- e )
|
|||
tri
|
||||
'[ [ @ _ @ ] sum-outputs ] ;
|
||||
|
||||
: set-dual-help ( word dword -- )
|
||||
[ swap
|
||||
[ stack-effect [ in>> ] [ out>> ] bi append
|
||||
[ dual ] { } map>assoc { $values } prepend
|
||||
]
|
||||
[ [ { $description } % "Version of " ,
|
||||
{ $link } swap suffix ,
|
||||
" extended to work on dual numbers." , ]
|
||||
{ } make
|
||||
]
|
||||
bi* 2array
|
||||
] keep set-word-help ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
MACRO: dual-op ( word -- )
|
||||
|
|
@ -57,36 +71,13 @@ MACRO: dual-op ( word -- )
|
|||
tri
|
||||
'[ _ @ @ <dual> ] ;
|
||||
|
||||
: define-dual-method ( word -- )
|
||||
[ \ dual swap create-method ] keep '[ _ dual-op ] define ;
|
||||
: define-dual ( word -- )
|
||||
dup name>> "d" prepend "math.dual" create
|
||||
[ [ stack-effect ] dip set-stack-effect ]
|
||||
[ set-dual-help ]
|
||||
[ swap '[ _ dual-op ] define ]
|
||||
2tri ;
|
||||
|
||||
! Specialize math functions to operate on dual numbers.
|
||||
[ { sqrt exp log sin cos tan sinh cosh tanh acos asin atan }
|
||||
[ define-dual-method ] each ] with-compilation-unit
|
||||
|
||||
! Inverse methods { asinh, acosh, atanh } are not generic, so
|
||||
! there is no way to specialize them for dual numbers. However,
|
||||
! they are defined in terms of functions that can operate on
|
||||
! dual numbers and arithmetic methods, so if it becomes
|
||||
! possible to make arithmetic operators work directly on dual
|
||||
! numbers, we will get these for free.
|
||||
|
||||
! Arithmetic words are not generic (yet?), so we have to
|
||||
! define special versions of them to operate on dual numbers.
|
||||
: d+ ( x y -- x+y ) \ + dual-op ;
|
||||
: d- ( x y -- x-y ) \ - dual-op ;
|
||||
: d* ( x y -- x*y ) \ * dual-op ;
|
||||
: d/ ( x y -- x/y ) \ / dual-op ;
|
||||
: d^ ( x y -- x^y ) \ ^ dual-op ;
|
||||
|
||||
: dabs ( x -- |x| ) \ abs dual-op ;
|
||||
|
||||
! The following words are also not generic, but are defined in
|
||||
! terms of words that can operate on dual numbers and
|
||||
! arithmetic. If it becomes possible to implement arithmetic on
|
||||
! dual numbers directly, these functions can be deleted.
|
||||
: dneg ( x -- -x ) \ neg dual-op ;
|
||||
: drecip ( x -- 1/x ) \ recip dual-op ;
|
||||
: dasinh ( x -- y ) \ asinh dual-op ;
|
||||
: dacosh ( x -- y ) \ acosh dual-op ;
|
||||
: datanh ( x -- y ) \ atanh dual-op ;
|
||||
[ all-words [ "derivative" word-prop ] filter
|
||||
[ define-dual ] each ] with-compilation-unit
|
||||
Loading…
Reference in New Issue