steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

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

Conflicts:

	extra/webapps/file/file.factor
	extra/webapps/source/source.factor
db4
Daniel Ehrenberg 2008-02-25 15:12:26 -06:00
parent 278509336d d8e19ccb95
commit 4cfdc3de62
49 changed files with 1333 additions and 575 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
core/alien/alien-docs.factor
View File

@ -87,7 +87,7 @@ $nl
HELP: alien-invoke-error
{ $error-description "Thrown if the word calling " { $link alien-invoke } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
{ $list
{ "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
{ "This can happen when experimenting with " { $link alien-invoke } " in this listener. To fix the problem, place the " { $link alien-invoke } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
{ "The return type or parameter list references an unknown C type." }
{ "The symbol or library could not be found." }
{ "One of the four inputs to " { $link alien-invoke } " is not a literal value. To call functions which are not known at compile-time, use " { $link alien-indirect } "." }
@ -103,7 +103,7 @@ HELP: alien-invoke
HELP: alien-indirect-error
{ $error-description "Thrown if the word calling " { $link alien-indirect } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
{ $list
{ "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
{ "This can happen when experimenting with " { $link alien-indirect } " in this listener. To fix the problem, place the " { $link alien-indirect } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
{ "The return type or parameter list references an unknown C type." }
{ "One of the three inputs to " { $link alien-indirect } " is not a literal value." }
}
@ -120,7 +120,7 @@ HELP: alien-indirect
HELP: alien-callback-error
{ $error-description "Thrown if the word calling " { $link alien-callback } " was not compiled with the optimizing compiler. This may be a result of one of several failure conditions:"
{ $list
{ "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word and then call " { $link recompile } ". See " { $link "compiler" } "." }
{ "This can happen when experimenting with " { $link alien-callback } " in this listener. To fix the problem, place the " { $link alien-callback } " call in a word; word definitions are automatically compiled with the optimizing compiler." }
{ "The return type or parameter list references an unknown C type." }
{ "One of the four inputs to " { $link alien-callback } " is not a literal value." }
}
@ -199,9 +199,7 @@ ARTICLE: "alien-invoke" "Calling C from Factor"
{ $subsection alien-invoke }
"Sometimes it is necessary to invoke a C function pointer, rather than a named C function:"
{ $subsection alien-indirect }
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "."
$nl
"Don't forget to compile your binding word after defining it; C library calls cannot be made from an interpreted definition. Words defined in source files are automatically compiled when the source file is loaded, but words defined in the listener are not; when interactively testing C libraries, use " { $link compile } " or " { $link recompile } " to compile binding words." ;
"There are some details concerning the conversion of Factor objects to C values, and vice versa. See " { $link "c-data" } "." ;
ARTICLE: "alien-callback-gc" "Callbacks and code GC"
"A callback consits of two parts; the callback word, which pushes the address of the callback on the stack when executed, and the callback body itself. If the callback word is redefined, removed from the dictionary using " { $link forget } ", or recompiled, the callback body will not be reclaimed by the garbage collector, since potentially C code may be holding a reference to the callback body."

16
core/bootstrap/compiler/compiler.factor
View File

@ -16,6 +16,14 @@ IN: bootstrap.compiler
"cpu." cpu append require
: enable-compiler ( -- )
[ optimized-recompile-hook ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
enable-compiler
nl
"Compiling some words to speed up bootstrap..." write flush
@ -74,12 +82,4 @@ nl
malloc free memcpy
} compile
: enable-compiler ( -- )
[ compiled-usages recompile ] recompile-hook set-global ;
: disable-compiler ( -- )
[ default-recompile-hook ] recompile-hook set-global ;
enable-compiler
" done" print flush

2
core/bootstrap/primitives.factor
View File

@ -30,7 +30,7 @@ crossref off
"syntax" vocab vocab-words bootstrap-syntax set
H{ } clone dictionary set
H{ } clone changed-words set
[ drop ] recompile-hook set
[ default-recompile-hook ] recompile-hook set
call
call

4
core/bootstrap/stage2.factor
View File

@ -29,9 +29,7 @@ SYMBOL: bootstrap-time
: compile-remaining ( -- )
"Compiling remaining words..." print flush
vocabs [
words "compile" "compiler" lookup execute
] each ;
vocabs [ words [ compiled? not ] subset compile ] each ;
: count-words ( pred -- )
all-words swap subset length number>string write ;

3
core/classes/classes.factor
View File

@ -255,8 +255,7 @@ PRIVATE>
: (define-class) ( word props -- )
over reset-class
over reset-generic
over define-symbol
over deferred? [ over define-symbol ] when
>r dup word-props r> union over set-word-props
t "class" set-word-prop ;

33
core/compiler/compiler-docs.factor
View File

@ -1,18 +1,14 @@
USING: generator help.markup help.syntax words io parser
assocs words.private sequences ;
assocs words.private sequences compiler.units ;
IN: compiler
ARTICLE: "compiler-usage" "Calling the optimizing compiler"
"Normally, new word definitions are recompiled automatically, however in some circumstances the optimizing compiler may need to be called directly."
$nl
"The main entry points to the optimizing compiler:"
{ $subsection compile }
{ $subsection recompile }
{ $subsection recompile-all }
"The main entry point to the optimizing compiler:"
{ $subsection optimized-recompile-hook }
"Removing a word's optimized definition:"
{ $subsection decompile }
"The optimizing compiler can also compile and call a single quotation:"
{ $subsection compile-call } ;
{ $subsection decompile } ;
ARTICLE: "compiler" "Optimizing compiler"
"Factor is a fully compiled language implementation with two distinct compilers:"
@ -26,22 +22,6 @@ ARTICLE: "compiler" "Optimizing compiler"
ABOUT: "compiler"
HELP: compile
{ $values { "seq" "a sequence of words" } }
{ $description "Compiles a set of words. Ignores words which are already compiled." } ;
HELP: recompile
{ $values { "seq" "a sequence of words" } }
{ $description "Compiles a set of words. Re-compiles words which are already compiled." } ;
HELP: compile-call
{ $values { "quot" "a quotation" } }
{ $description "Compiles and runs a quotation." }
{ $errors "Throws an error if the stack effect of the quotation cannot be inferred." } ;
HELP: recompile-all
{ $description "Recompiles all words." } ;
HELP: decompile
{ $values { "word" word } }
{ $description "Removes a word's optimized definition. The word will be compiled with the non-optimizing compiler until recompiled with the optimizing compiler again." } ;
@ -50,3 +30,8 @@ HELP: (compile)
{ $values { "word" word } }
{ $description "Compile a single word." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;
HELP: optimized-recompile-hook
{ $values { "words" "a sequence of words" } { "alist" "an association list" } }
{ $description "Compile a set of words." }
{ $notes "This is an internal word, and user code should call " { $link compile } " instead." } ;

29
core/compiler/compiler.factor
View File

@ -4,14 +4,9 @@ USING: kernel namespaces arrays sequences io inference.backend
inference.state generator debugger math.parser prettyprint words
compiler.units continuations vocabs assocs alien.compiler dlists
optimizer definitions math compiler.errors threads graphs
generic ;
generic inference ;
IN: compiler
: compiled-usages ( words -- seq )
[ [ dup ] H{ } map>assoc dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
] with each keys ;
: ripple-up ( word -- )
compiled-usage [ drop queue-compile ] assoc-each ;
@ -49,27 +44,17 @@ IN: compiler
compile-loop
] if ;
: recompile ( words -- )
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
: optimized-recompile-hook ( words -- alist )
[
H{ } clone compile-queue set
H{ } clone compiled set
[ queue-compile ] each
compile-queue get compile-loop
compiled get >alist
dup [ drop crossref? ] assoc-contains?
modify-code-heap
] with-scope ; inline
: compile ( words -- )
[ compiled? not ] subset recompile ;
: compile-call ( quot -- )
H{ } clone changed-words
[ define-temp dup 1array compile ] with-variable
execute ;
] with-scope ;
: recompile-all ( -- )
[ all-words recompile ] with-compiler-errors ;
: decompile ( word -- )
f 2array 1array t modify-code-heap ;
forget-errors all-words compile ;

8
core/compiler/units/units-docs.factor
View File

@ -61,3 +61,11 @@ HELP: modify-code-heap ( alist -- )
{ { $snippet "{ code labels rel words literals }" } " - in this case, a code heap block is allocated with the given data." }
} }
{ $notes "This word is called at the end of " { $link with-compilation-unit } "." } ;
HELP: compile
{ $values { "seq" "a sequence of words" } }
{ $description "Compiles a set of words." } ;
HELP: compile-call
{ $values { "quot" "a quotation" } }
{ $description "Compiles and runs a quotation." } ;

31
core/compiler/units/units.factor
View File

@ -63,24 +63,45 @@ GENERIC: definitions-changed ( assoc obj -- )
dup changed-words get update
dup dup changed-vocabs update ;
: compile ( words -- )
recompile-hook get call
dup [ drop crossref? ] assoc-contains?
modify-code-heap ;
SYMBOL: post-compile-tasks
: after-compilation ( quot -- )
post-compile-tasks get push ;
: call-recompile-hook ( -- )
changed-words get keys
compiled-usages recompile-hook get call ;
: call-post-compile-tasks ( -- )
post-compile-tasks get [ call ] each ;
: finish-compilation-unit ( -- )
changed-words get keys recompile-hook get call
call-recompile-hook
call-post-compile-tasks
dup [ drop crossref? ] assoc-contains? modify-code-heap
changed-definitions notify-definition-observers ;
: with-compilation-unit ( quot -- )
[
H{ } clone changed-words set
H{ } clone forgotten-definitions set
V{ } clone post-compile-tasks set
<definitions> new-definitions set
<definitions> old-definitions set
[ finish-compilation-unit ]
[ ] cleanup
] with-scope ; inline
: default-recompile-hook
[ f ] { } map>assoc
dup [ drop crossref? ] assoc-contains?
modify-code-heap ;
: compile-call ( quot -- )
[ define-temp ] with-compilation-unit execute ;
: default-recompile-hook ( words -- alist )
[ f ] { } map>assoc ;
recompile-hook global
[ [ default-recompile-hook ] or ]

9
core/cpu/x86/32/32.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays cpu.x86.assembler
cpu.x86.architecture cpu.x86.intrinsics cpu.x86.allot
cpu.architecture kernel kernel.private math namespaces sequences
generator.registers generator.fixup generator system
alien.compiler combinators command-line
compiler io vocabs.loader ;
compiler compiler.units io vocabs.loader ;
IN: cpu.x86.32
PREDICATE: x86-backend x86-32-backend
@ -281,7 +281,10 @@ T{ x86-backend f 4 } compiler-backend set-global
"-no-sse2" cli-args member? [
"Checking if your CPU supports SSE2..." print flush
[ sse2? ] compile-call [
[ optimized-recompile-hook ] recompile-hook [
[ sse2? ] compile-call
] with-variable
[
" - yes" print
"cpu.x86.sse2" require
] [

5
core/inference/state/state.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel ;
USING: assocs namespaces sequences kernel words ;
IN: inference.state
! Nesting state to solve recursion
@ -31,9 +31,6 @@ SYMBOL: current-node
! Words that the current dataflow IR depends on
SYMBOL: dependencies
SYMBOL: +inlined+
SYMBOL: +called+
: depends-on ( word how -- )
swap dependencies get dup [
2dup at +inlined+ eq? [ 3drop ] [ set-at ] if

4
core/memory/memory-docs.factor Normal file → Executable file
View File

@ -47,8 +47,8 @@ HELP: gc-time ( -- n )
{ $values { "n" "a timestamp in milliseconds" } }
{ $description "Outputs the total time spent in garbage collection during this Factor session." } ;
HELP: data-room ( -- cards semi generations )
{ $values { "cards" "number of bytes reserved for card marking" } { "semi" "number of bytes reserved for tenured semi-space" } { "generations" "array of free/total bytes pairs" } }
HELP: data-room ( -- cards generations )
{ $values { "cards" "number of bytes reserved for card marking" } { "generations" "array of free/total bytes pairs" } }
{ $description "Queries the runtime for memory usage information." } ;
HELP: code-room ( -- code-free code-total )

31
core/parser/parser-tests.factor
View File

@ -395,3 +395,34 @@ IN: temporary
[ t ] [
"foo?" "temporary" lookup word eq?
] unit-test
[ ] [
"IN: temporary TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ ] [
"IN: temporary M: f foo ;"
<string-reader> "redefining-a-class-6" parse-stream drop
] unit-test
[ f ] [ f "foo" "temporary" lookup execute ] unit-test
[ ] [
"IN: temporary TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-5" parse-stream drop
] unit-test
[ f ] [ f "foo" "temporary" lookup execute ] unit-test
[ ] [
"IN: temporary TUPLE: foo ; GENERIC: foo"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
[ ] [
"IN: temporary TUPLE: foo ;"
<string-reader> "redefining-a-class-7" parse-stream drop
] unit-test
[ t ] [ "foo" "temporary" lookup symbol? ] unit-test

9
core/parser/parser.factor
View File

@ -464,9 +464,16 @@ SYMBOL: interactive-vocabs
dup values concat prune swap keys
] keep ;
: fix-class-words ( -- )
#! If a class word had a compound definition which was
#! removed, it must go back to being a symbol.
new-definitions get first2 diff
[ nip define-symbol ] assoc-each ;
: forget-smudged ( -- )
smudged-usage forget-all
over empty? [ 2dup smudged-usage-warning ] unless 2drop ;
over empty? [ 2dup smudged-usage-warning ] unless 2drop
fix-class-words ;
: finish-parsing ( lines quot -- )
file get

7
core/threads/threads-docs.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax kernel kernel.private io
threads.private continuations dlists init quotations strings
assocs heaps boxes ;
assocs heaps boxes namespaces ;
IN: threads
ARTICLE: "threads-start/stop" "Starting and stopping threads"
@ -127,7 +127,10 @@ HELP: spawn
{ $values { "quot" quotation } { "name" string } }
{ $description "Spawns a new thread. The thread begins executing the given quotation; the name is for debugging purposes. The new thread begins running immediately and the current thread is added to the end of the run queue."
$nl
"The new thread begins with an empty data stack, an empty catch stack, and a name stack containing the global namespace only. This means that the only way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "." }
"The new thread begins with an empty data stack, an empty retain stack, and an empty catch stack. The name stack is inherited from the parent thread but may be cleared with " { $link init-namespaces } "." }
{ $notes
"The recommended way to pass data to the new thread is to explicitly construct a quotation containing the data, for example using " { $link curry } " or " { $link compose } "."
}
{ $examples
{ $code "1 2 [ + . ] 2curry \"Addition thread\" spawn" }
} ;

1
core/threads/threads.factor
View File

@ -165,7 +165,6 @@ M: f nap nap-until ;
resume-now [
dup set-self
dup register-thread
init-namespaces
V{ } set-catchstack
{ } set-retainstack
>r { } set-datastack r>

37
core/tuples/tuples-tests.factor
View File

@ -237,3 +237,40 @@ C: <erg's-reshape-problem> erg's-reshape-problem
[
"IN: temporary SYMBOL: not-a-class C: <not-a-class> not-a-class" eval
] [ [ check-tuple? ] is? ] must-fail-with
! Hardcore unit tests
USE: threads
\ thread "slot-names" word-prop "slot-names" set
[ ] [
[
\ thread { "xxx" } "slot-names" get append
define-tuple-class
] with-compilation-unit
[ 1337 sleep ] "Test" spawn drop
[
\ thread "slot-names" get
define-tuple-class
] with-compilation-unit
] unit-test
USE: vocabs
\ vocab "slot-names" word-prop "slot-names" set
[ ] [
[
\ vocab { "xxx" } "slot-names" get append
define-tuple-class
] with-compilation-unit
all-words drop
[
\ vocab "slot-names" get
define-tuple-class
] with-compilation-unit
] unit-test

12
core/tuples/tuples.factor
View File

@ -3,7 +3,7 @@
USING: arrays definitions hashtables kernel
kernel.private math namespaces sequences sequences.private
strings vectors words quotations memory combinators generic
classes classes.private slots slots.private ;
classes classes.private slots slots.private compiler.units ;
IN: tuples
M: tuple delegate 3 slot ;
@ -35,9 +35,12 @@ M: tuple class class-of-tuple ;
append (>tuple) ;
: reshape-tuples ( class newslots -- )
>r dup [ swap class eq? ] curry instances dup
rot "slot-names" word-prop r> permutation
[ reshape-tuple ] curry map become ;
>r dup "slot-names" word-prop r> permutation
[
>r [ swap class eq? ] curry instances dup r>
[ reshape-tuple ] curry map
become
] 2curry after-compilation ;
: old-slots ( class newslots -- seq )
swap "slots" word-prop 1 tail-slice
@ -55,6 +58,7 @@ M: tuple class class-of-tuple ;
over "slot-names" word-prop over = [
2dup forget-slots
2dup reshape-tuples
over changed-word
over redefined
] unless
] when 2drop ;

4
core/words/words-docs.factor
View File

@ -76,9 +76,9 @@ $nl
ARTICLE: "declarations" "Declarations"
"Declarations give special behavior to a word. Declarations are parsing words that set a word property in the most recently defined word."
$nl
"The first declaration specifies the time when a word runs. It affects both interpreted and compiled definitions."
"The first declaration specifies the time when a word runs. It affects both the non-optimizing and optimizing compilers:"
{ $subsection POSTPONE: parsing }
"The remaining declarations only affect compiled definitions. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently."
"The remaining declarations only affect definitions compiled with the optimizing compiler. They do not change evaluation semantics of a word, but instead declare that the word follows a certain contract, and thus may be compiled differently."
{ $warning "If a generic word is declared " { $link POSTPONE: foldable } " or " { $link POSTPONE: flushable } ", all methods must satisfy the contract, otherwise unpredicable behavior will occur." }
{ $subsection POSTPONE: inline }
{ $subsection POSTPONE: foldable }

8
core/words/words.factor
View File

@ -111,9 +111,17 @@ compiled-crossref global [ H{ } assoc-like ] change-at
dup compiled-unxref
compiled-crossref get delete-at ;
SYMBOL: +inlined+
SYMBOL: +called+
: compiled-usage ( word -- assoc )
compiled-crossref get at ;
: compiled-usages ( words -- seq )
[ [ dup ] H{ } map>assoc dup ] keep [
compiled-usage [ nip +inlined+ eq? ] assoc-subset update
] with each keys ;
M: word redefined* ( word -- )
{ "inferred-effect" "no-effect" } reset-props ;

0
extra/benchmark/reverse-complement/reverse-complement-test-out.txt Normal file → Executable file
View File

13
extra/benchmark/reverse-complement/reverse-complement-tests.factor Executable file
View File

@ -0,0 +1,13 @@
IN: temporary
USING: tools.test benchmark.reverse-complement crypto.md5
io.files kernel ;
[ "c071aa7e007a9770b2fb4304f55a17e5" ] [
"extra/benchmark/reverse-complement/reverse-complement-test-in.txt"
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
[ resource-path ] 2apply
reverse-complement
"extra/benchmark/reverse-complement/reverse-complement-test-out.txt"
resource-path file>md5str
] unit-test

1
extra/builder/builder.factor
View File

@ -178,6 +178,7 @@ SYMBOL: builder-recipients
: build ( -- )
[ (build) ] [ drop ] recover
maybe-release
[ send-builder-email ] [ drop "not sending mail" . ] recover
".." cd { "rm" "-rf" "factor" } run-process drop
[ compress-image ] [ drop ] recover ;

22
extra/builder/release/release.factor
View File

@ -1,12 +1,12 @@
USING: kernel namespaces sequences combinators io.files io.launcher
combinators.cleave builder.common builder.util ;
bake combinators.cleave builder.common builder.util ;
IN: builder.release
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: releases ( -- path ) builds "/releases" append ;
: releases ( -- path ) builds "/releases" append dup make-directory ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -57,7 +57,8 @@ USING: system sequences splitting ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: move-file ( source destination -- ) swap { "mv" , , } run-process drop ;
: move-file ( source destination -- )
swap { "mv" , , } bake run-process drop ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
@ -114,4 +115,17 @@ USING: system sequences splitting ;
{ "macosx" [ macosx-release ] }
}
case ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: release? ( -- ? )
{
"../load-everything-vocabs"
"../test-all-vocabs"
}
[ eval-file empty? ]
all? ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: maybe-release ( -- ) release? [ release ] when ;

58
extra/db/db.factor
View File

@ -1,14 +1,18 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes continuations kernel math
namespaces sequences sequences.lib tuples words strings ;
namespaces sequences sequences.lib tuples words strings
tools.walker ;
IN: db
TUPLE: db handle insert-statements update-statements delete-statements ;
TUPLE: db handle ;
! TUPLE: db handle insert-statements update-statements delete-statements ;
: <db> ( handle -- obj )
H{ } clone H{ } clone H{ } clone
! H{ } clone H{ } clone H{ } clone
db construct-boa ;
GENERIC: make-db* ( seq class -- db )
: make-db ( seq class -- db ) construct-empty make-db* ;
GENERIC: db-open ( db -- )
HOOK: db-close db ( handle -- )
@ -17,22 +21,29 @@ HOOK: db-close db ( handle -- )
: dispose-db ( db -- )
dup db [
dup db-insert-statements dispose-statements
dup db-update-statements dispose-statements
dup db-delete-statements dispose-statements
! dup db-insert-statements dispose-statements
! dup db-update-statements dispose-statements
! dup db-delete-statements dispose-statements
db-handle db-close
] with-variable ;
TUPLE: statement sql params handle bound? slot-names ;
TUPLE: statement handle sql in-params out-params bind-params bound? ;
: <statement> ( sql in out -- statement )
{
set-statement-sql
set-statement-in-params
set-statement-out-params
} statement construct ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
HOOK: <simple-statement> db ( str -- statement )
HOOK: <prepared-statement> db ( str -- statement )
HOOK: <simple-statement> db ( str in out -- statement )
HOOK: <prepared-statement> db ( str in out -- statement )
GENERIC: prepare-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: reset-statement ( statement -- )
GENERIC: insert-statement ( statement -- id )
GENERIC: bind-tuple ( tuple statement -- )
TUPLE: result-set sql params handle n max ;
GENERIC: query-results ( query -- result-set )
@ -42,12 +53,17 @@ GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- )
GENERIC: more-rows? ( result-set -- ? )
: execute-statement ( statement -- ) query-results dispose ;
: execute-statement ( statement -- )
dup sequence? [
[ execute-statement ] each
] [
query-results dispose
] if ;
: bind-statement ( obj statement -- )
dup statement-bound? [ dup reset-statement ] when
[ bind-statement* ] 2keep
[ set-statement-params ] keep
[ set-statement-bind-params ] keep
t swap set-statement-bound? ;
: init-result-set ( result-set -- )
@ -55,7 +71,7 @@ GENERIC: more-rows? ( result-set -- ? )
0 swap set-result-set-n ;
: <result-set> ( query handle tuple -- result-set )
>r >r { statement-sql statement-params } get-slots r>
>r >r { statement-sql statement-in-params } get-slots r>
{
set-result-set-sql
set-result-set-params
@ -75,17 +91,15 @@ GENERIC: more-rows? ( result-set -- ? )
: query-map ( statement quot -- seq )
accumulator >r query-each r> { } like ; inline
: with-db ( db quot -- )
[
over db-open
[ db swap with-variable ] curry with-disposal
] with-scope ;
: with-db ( db seq quot -- )
>r make-db dup db-open db r>
[ db get swap [ drop ] swap compose with-disposal ] curry with-variable ;
: do-query ( query -- result-set )
: default-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ;
: do-bound-query ( obj query -- rows )
[ bind-statement ] keep do-query ;
[ bind-statement ] keep default-query ;
: do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ;
@ -105,11 +119,11 @@ HOOK: rollback-transaction db ( -- )
] with-variable ;
: sql-query ( sql -- rows )
<simple-statement> [ do-query ] with-disposal ;
f f <simple-statement> [ default-query ] with-disposal ;
: sql-command ( sql -- )
dup string? [
<simple-statement> [ execute-statement ] with-disposal
f f <simple-statement> [ execute-statement ] with-disposal
] [
! [
[ sql-command ] each

18
extra/db/postgresql/lib/lib.factor Normal file → Executable file
View File

@ -2,21 +2,25 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces
quotations sequences db.postgresql.ffi alien alien.c-types
db.types ;
db.types tools.walker ascii splitting ;
IN: db.postgresql.lib
: postgresql-result-error-message ( res -- str/f )
dup zero? [
drop f
] [
PQresultErrorMessage [ CHAR: \n = ] right-trim
PQresultErrorMessage [ blank? ] trim
] if ;
: postgres-result-error ( res -- )
postgresql-result-error-message [ throw ] when* ;
: (postgresql-error-message) ( handle -- str )
PQerrorMessage
"\n" split [ [ blank? ] trim ] map "\n" join ;
: postgresql-error-message ( -- str )
db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
db get db-handle (postgresql-error-message) ;
: postgresql-error ( res -- res )
dup [ postgresql-error-message throw ] unless ;
@ -27,7 +31,7 @@ IN: db.postgresql.lib
: connect-postgres ( host port pgopts pgtty db user pass -- conn )
PQsetdbLogin
dup PQstatus zero? [ postgresql-error-message throw ] unless ;
dup PQstatus zero? [ (postgresql-error-message) throw ] unless ;
: do-postgresql-statement ( statement -- res )
db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
@ -37,9 +41,9 @@ IN: db.postgresql.lib
: do-postgresql-bound-statement ( statement -- res )
>r db get db-handle r>
[ statement-sql ] keep
[ statement-params length f ] keep
statement-params
[ first number>string* malloc-char-string ] map >c-void*-array
[ statement-bind-params length f ] keep
statement-bind-params
[ number>string* malloc-char-string ] map >c-void*-array
f f 0 PQexecParams
dup postgresql-result-ok? [
dup postgresql-result-error-message swap PQclear throw

254
extra/db/postgresql/postgresql-tests.factor Normal file → Executable file
View File

@ -1,13 +1,14 @@
! You will need to run 'createdb factor-test' to create the database.
! Set username and password in the 'connect' word.
USING: kernel db.postgresql alien continuations io prettyprint
sequences namespaces tools.test db db.types ;
USING: kernel db.postgresql alien continuations io classes
prettyprint sequences namespaces tools.test db
db.tuples db.types unicode.case ;
IN: temporary
IN: scratchpad
: test-db ( -- postgresql-db )
"localhost" "postgres" "" "factor-test" <postgresql-db> ;
{ "localhost" "postgres" "" "factor-test" } postgresql-db ;
IN: temporary
[ ] [ test-db [ ] with-db ] unit-test
@ -39,7 +40,7 @@ IN: temporary
] [
test-db [
"select * from person where name = $1 and country = $2"
<simple-statement> [
f f <simple-statement> [
{ { "Jane" TEXT } { "New Zealand" TEXT } }
over do-bound-query
@ -108,3 +109,248 @@ IN: temporary
"select * from person" sql-query length
] with-db
] unit-test
: with-dummy-db ( quot -- )
>r T{ postgresql-db } db r> with-variable ;
! TEST TUPLE DB
TUPLE: puppy id name age ;
: <puppy> ( name age -- puppy )
{ set-puppy-name set-puppy-age } puppy construct ;
puppy "PUPPY" {
{ "id" "ID" +native-id+ +not-null+ }
{ "name" "NAME" { VARCHAR 256 } }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: kitty id name age ;
: <kitty> ( name age -- kitty )
{ set-kitty-name set-kitty-age } kitty construct ;
kitty "KITTY" {
{ "id" "ID" INTEGER +assigned-id+ }
{ "name" "NAME" TEXT }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: basket id puppies kitties ;
basket "BASKET"
{
{ "id" "ID" +native-id+ +not-null+ }
{ "location" "LOCATION" TEXT }
{ "puppies" { +has-many+ puppy } }
{ "kitties" { +has-many+ kitty } }
} define-persistent
! Create table
[
"create table puppy(id serial primary key not null, name varchar 256, age integer);"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
[
"create table kitty(id integer primary key, name text, age integer);"
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
[
"create table basket(id serial primary key not null, location text);"
] [
T{ postgresql-db } db [
basket dup db-columns swap db-table create-table-sql >lower
] with-variable
] unit-test
! Create function
[
"create function add_puppy(varchar,integer) returns bigint as 'insert into puppy(name, age) values($1, $2); select currval(''puppy_id_seq'');' language sql;"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table create-function-sql >lower
] with-variable
] unit-test
! Drop table
[
"drop table puppy;"
] [
T{ postgresql-db } db [
puppy db-table drop-table-sql >lower
] with-variable
] unit-test
[
"drop table kitty;"
] [
T{ postgresql-db } db [
kitty db-table drop-table-sql >lower
] with-variable
] unit-test
[
"drop table basket;"
] [
T{ postgresql-db } db [
basket db-table drop-table-sql >lower
] with-variable
] unit-test
! Drop function
[
"drop function add_puppy(varchar, integer);"
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table drop-function-sql >lower
] with-variable
] unit-test
! Insert
[
] [
T{ postgresql-db } db [
puppy <insert-native-statement>
] with-variable
] unit-test
[
"insert into kitty(id, name, age) values($1, $2, $3);"
{
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
T{ sql-spec f "name" "NAME" TEXT { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
{ }
] [
T{ postgresql-db } db [
kitty <insert-assigned-statement>
] with-variable
] unit-test
! Update
[
"update puppy set name = $1, age = $2 where id = $3"
{
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
}
{ }
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
[
"update kitty set name = $1, age = $2 where id = $3"
{
T{ sql-spec f "name" "NAME" TEXT { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
}
{ }
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table <update-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
! Delete
[
"delete from puppy where id = $1"
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
}
{ }
] [
T{ postgresql-db } db [
puppy dup db-columns swap db-table <delete-tuple-statement> >r >r >lower r> r>
] with-variable
] unit-test
[
"delete from KITTY where ID = $1"
{
T{
sql-spec
f
"id"
"ID"
INTEGER
{ +assigned-id+ }
+assigned-id+
}
}
{ }
] [
T{ postgresql-db } db [
kitty dup db-columns swap db-table <delete-tuple-statement>
] with-variable
] unit-test
! Select
[
"select from PUPPY ID, NAME, AGE where NAME = $1;"
{ T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f } }
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
] [
T{ postgresql-db } db [
T{ puppy f f "Mr. Clunkers" }
<select-by-slots-statement>
] with-variable
] unit-test

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

@ -4,25 +4,28 @@ USING: arrays assocs alien alien.syntax continuations io
kernel math math.parser namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators ;
combinators sequences.lib classes locals words tools.walker ;
IN: db.postgresql
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
TUPLE: postgresql-statement ;
TUPLE: postgresql-result-set ;
: <postgresql-statement> ( statement -- postgresql-statement )
: <postgresql-statement> ( statement in out -- postgresql-statement )
<statement>
postgresql-statement construct-delegate ;
: <postgresql-db> ( host user pass db -- obj )
{
set-postgresql-db-host
set-postgresql-db-user
set-postgresql-db-pass
set-postgresql-db-db
} postgresql-db construct ;
M: postgresql-db make-db* ( seq tuple -- db )
>r first4 r> [
{
set-postgresql-db-host
set-postgresql-db-user
set-postgresql-db-pass
set-postgresql-db-db
} set-slots
] keep ;
M: postgresql-db db-open ( db -- )
dup {
dup {
postgresql-db-host
postgresql-db-port
postgresql-db-pgopts
@ -35,15 +38,18 @@ M: postgresql-db db-open ( db -- )
M: postgresql-db dispose ( db -- )
db-handle PQfinish ;
: with-postgresql ( host ust pass db quot -- )
>r <postgresql-db> r> with-disposal ;
M: postgresql-statement bind-statement* ( seq statement -- )
set-statement-params ;
set-statement-bind-params ;
M: postgresql-statement reset-statement ( statement -- )
drop ;
M: postgresql-statement bind-tuple ( tuple statement -- )
[
statement-in-params
[ sql-spec-slot-name swap get-slot-named ] with map
] keep set-statement-bind-params ;
M: postgresql-result-set #rows ( result-set -- n )
result-set-handle PQntuples ;
@ -56,19 +62,8 @@ M: postgresql-result-set row-column ( result-set n -- obj )
M: postgresql-result-set row-column-typed ( result-set n type -- obj )
>r row-column r> sql-type>factor-type ;
M: postgresql-result-set sql-type>factor-type ( obj type -- newobj )
{
{ INTEGER [ string>number ] }
{ BIG_INTEGER [ string>number ] }
{ DOUBLE [ string>number ] }
[ drop ]
} case ;
M: postgresql-statement insert-statement ( statement -- id )
query-results [ 0 row-column ] with-disposal string>number ;
M: postgresql-statement query-results ( query -- result-set )
dup statement-params [
dup statement-bind-params [
over [ bind-statement ] keep
do-postgresql-bound-statement
] [
@ -96,17 +91,15 @@ M: postgresql-result-set dispose ( result-set -- )
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get db-handle "" r>
dup statement-sql swap statement-params
dup statement-sql swap statement-in-params
length f PQprepare postgresql-error
] keep set-statement-handle ;
M: postgresql-db <simple-statement> ( sql -- statement )
{ set-statement-sql } statement construct
M: postgresql-db <simple-statement> ( sql in out -- statement )
<postgresql-statement> ;
M: postgresql-db <prepared-statement> ( sql -- statement )
{ set-statement-sql } statement construct
<postgresql-statement> ;
M: postgresql-db <prepared-statement> ( sql in out -- statement )
<postgresql-statement> dup prepare-statement ;
M: postgresql-db begin-transaction ( -- )
"BEGIN" sql-command ;
@ -117,139 +110,176 @@ M: postgresql-db commit-transaction ( -- )
M: postgresql-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
: postgresql-type-hash* ( -- assoc )
H{
{ SERIAL "serial" }
} ;
SYMBOL: postgresql-counter
: bind-name% ( -- )
CHAR: $ 0,
postgresql-counter [ inc ] keep get 0# ;
: postgresql-type-hash ( -- assoc )
M: postgresql-db bind% ( spec -- )
1, bind-name% ;
: postgresql-make ( class quot -- )
>r sql-props r>
[ postgresql-counter off ] swap compose
{ "" { } { } } nmake <postgresql-statement> ;
: create-table-sql ( class -- statement )
[
"create table " 0% 0%
"(" 0%
[ ", " 0% ] [
dup sql-spec-column-name 0%
" " 0%
dup sql-spec-type t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] postgresql-make ;
: create-function-sql ( class -- statement )
[
>r remove-id r>
"create function add_" 0% dup 0%
"(" 0%
over [ "," 0% ]
[
sql-spec-type f lookup-type 0%
] interleave
")" 0%
" returns bigint as '" 0%
"insert into " 0%
dup 0%
"(" 0%
over [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
") values(" 0%
swap [ ", " 0% ] [ drop bind-name% ] interleave
"); " 0%
"select currval(''" 0% 0% "_id_seq'');' language sql;" 0%
] postgresql-make ;
M: postgresql-db create-sql-statement ( class -- seq )
[
[ create-table-sql , ] keep
dup db-columns find-primary-key native-id?
[ create-function-sql , ] [ 2drop ] if
] { } make ;
: drop-function-sql ( class -- statement )
[
"drop function add_" 0% 0%
"(" 0%
remove-id
[ ", " 0% ] [ sql-spec-type f lookup-type 0% ] interleave
");" 0%
] postgresql-make ;
: drop-table-sql ( table -- statement )
[
"drop table " 0% 0% ";" 0% drop
] postgresql-make dup . ;
M: postgresql-db drop-sql-statement ( class -- seq )
[
[ drop-table-sql , ] keep
dup db-columns find-primary-key native-id?
[ drop-function-sql , ] [ 2drop ] if
] { } make ;
M: postgresql-db <insert-native-statement> ( class -- statement )
[
"select add_" 0% 0%
"(" 0%
dup find-primary-key 2,
remove-id
[ ", " 0% ] [ bind% ] interleave
");" 0%
] postgresql-make ;
M: postgresql-db <insert-assigned-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
")" 0%
" values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
] postgresql-make ;
M: postgresql-db insert-tuple* ( tuple statement -- )
query-modify-tuple ;
M: postgresql-db <update-tuple-statement> ( class -- statement )
[
"update " 0% 0%
" set " 0%
dup remove-id
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
" where " 0%
find-primary-key
dup sql-spec-column-name 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <delete-tuple-statement> ( class -- statement )
[
"delete from " 0% 0%
" where " 0%
find-primary-key
dup sql-spec-column-name 0% " = " 0% bind%
] postgresql-make ;
M: postgresql-db <select-by-slots-statement> ( tuple class -- statement )
[
! tuple columns table
"select " 0%
over [ ", " 0% ]
[ dup sql-spec-column-name 0% 2, ] interleave
" from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset
" where " 0%
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
";" 0%
] postgresql-make ;
M: postgresql-db type-table ( -- hash )
H{
{ INTEGER "integer" }
{ SERIAL "integer" }
{ +native-id+ "integer" }
{ TEXT "text" }
{ VARCHAR "varchar" }
{ INTEGER "integer" }
{ DOUBLE "real" }
{ TIMESTAMP "timestamp" }
} ;
: enquote ( str -- newstr ) "(" swap ")" 3append ;
: postgresql-type ( str n/str -- newstr )
" " swap number>string* enquote 3append ;
: >sql-type* ( obj -- str )
dup pair? [
first2 >r >sql-type* r> postgresql-type
] [
dup postgresql-type-hash* at* [
nip
] [
drop >sql-type
] if
] if ;
M: postgresql-db >sql-type ( hash obj -- str )
dup pair? [
first2 >r >sql-type r> postgresql-type
] [
postgresql-type-hash at* [
no-sql-type
] unless
] if ;
: insert-function ( columns table -- sql )
[
>r remove-id r>
"create function add_" % dup %
"(" %
over [ "," % ]
[ third dup array? [ first ] when >sql-type % ] interleave
")" %
" returns bigint as '" %
2dup "insert into " %
%
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
length [1,b] [ ", " % ] [ "$" % # ] interleave
"); " %
"select currval(''" % % "_id_seq'');' language sql;" %
drop
] "" make ;
: drop-function ( columns table -- sql )
[
>r remove-id r>
"drop function add_" % %
"(" %
[ "," % ] [ third >sql-type % ] interleave
")" %
] "" make ;
M: postgresql-db create-sql ( columns table -- seq )
[
[
2dup
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type* % " " %
sql-modifiers " " join %
] interleave "); " %
] "" make ,
over native-id? [ insert-function , ] [ 2drop ] if
] { } make ;
M: postgresql-db drop-sql ( columns table -- seq )
[
[
dup "drop table " % % ";" %
] "" make ,
over native-id? [ drop-function , ] [ 2drop ] if
] { } make ;
M: postgresql-db insert-sql* ( columns table -- slot-names sql )
[
"select add_" % %
"(" %
length [1,b] [ ", " % ] [ "$" % # ] interleave
")" %
] "" make ;
M: postgresql-db update-sql* ( columns table -- slot-names sql )
[
"update " %
%
" set " %
dup remove-id
dup length [1,b] swap 2array flip
[ ", " % ] [ first2 second % " = $" % # ] interleave
" where " %
[ primary-key? ] find nip second dup % " = $" % length 2 + #
] "" make ;
M: postgresql-db delete-sql* ( columns table -- slot-names sql )
[
"delete from " %
%
" where " %
first second % " = $1" %
] "" make ;
M: postgresql-db select-sql ( columns table -- slot-names sql )
drop ;
M: postgresql-db tuple>params ( columns tuple -- obj )
[ >r dup third swap first r> get-slot-named swap ]
curry { } map>assoc ;
: postgresql-db-modifiers ( -- hashtable )
M: postgresql-db create-type-table ( -- hash )
H{
{ +native-id+ "not null primary key" }
{ +native-id+ "serial primary key" }
} ;
: postgresql-compound ( str n -- newstr )
over {
{ "default" [ first number>string join-space ] }
{ "varchar" [ first number>string paren append ] }
{ "references" [
first2 >r [ unparse join-space ] keep db-columns r>
swap [ sql-spec-slot-name = ] with find nip
sql-spec-column-name paren append
] }
[ "no compound found" 3array throw ]
} case ;
M: postgresql-db compound-modifier ( str seq -- newstr )
postgresql-compound ;
M: postgresql-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
{ +foreign-id+ "references" }
{ +autoincrement+ "autoincrement" }
{ +unique+ "unique" }
{ +default+ "default" }
@ -257,13 +287,5 @@ M: postgresql-db tuple>params ( columns tuple -- obj )
{ +not-null+ "not null" }
} ;
M: postgresql-db sql-modifiers* ( modifiers -- str )
postgresql-db-modifiers swap [
dup array? [
first2
>r swap at r> number>string*
" " swap 3append
] [
swap at
] if
] with map [ ] subset ;
M: postgresql-db compound-type ( str n -- newstr )
postgresql-compound ;

5
extra/db/sqlite/lib/lib.factor
View File

@ -78,7 +78,8 @@ IN: db.sqlite.lib
{ TEXT [ sqlite-bind-text-by-name ] }
{ VARCHAR [ sqlite-bind-text-by-name ] }
{ DOUBLE [ sqlite-bind-double-by-name ] }
{ SERIAL [ sqlite-bind-int-by-name ] }
{ TIMESTAMP [ sqlite-bind-double-by-name ] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
! { NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
} case ;
@ -102,6 +103,8 @@ IN: db.sqlite.lib
{ BIG_INTEGER [ sqlite3_column_int64 ] }
{ TEXT [ sqlite3_column_text ] }
{ DOUBLE [ sqlite3_column_double ] }
{ TIMESTAMP [ sqlite3_column_double ] }
[ no-sql-type ]
} case ;
! TODO

157
extra/db/sqlite/sqlite-tests.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: io io.files io.launcher kernel namespaces
prettyprint tools.test db.sqlite db sequences
continuations db.types ;
continuations db.types db.tuples unicode.case ;
IN: temporary
: test.db "extra/db/sqlite/test.db" resource-path ;
@ -89,3 +89,158 @@ IN: temporary
"select * from person" sql-query length
] with-sqlite
] unit-test
! TEST TUPLE DB
TUPLE: puppy id name age ;
: <puppy> ( name age -- puppy )
{ set-puppy-name set-puppy-age } puppy construct ;
puppy "PUPPY" {
{ "id" "ID" +native-id+ +not-null+ }
{ "name" "NAME" { VARCHAR 256 } }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: kitty id name age ;
: <kitty> ( name age -- kitty )
{ set-kitty-name set-kitty-age } kitty construct ;
kitty "KITTY" {
{ "id" "ID" INTEGER +assigned-id+ }
{ "name" "NAME" TEXT }
{ "age" "AGE" INTEGER }
} define-persistent
TUPLE: basket id puppies kitties ;
basket "BASKET"
{
{ "id" "ID" +native-id+ +not-null+ }
{ "location" "LOCATION" TEXT }
{ "puppies" { +has-many+ puppy } }
{ "kitties" { +has-many+ kitty } }
} define-persistent
! Create table
[
"create table puppy(id integer primary key not null, name varchar, age integer);"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
[
"create table kitty(id integer primary key, name text, age integer);"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
[
"create table basket(id integer primary key not null, location text);"
] [
T{ sqlite-db } db [
basket dup db-columns swap db-table create-sql >lower
] with-variable
] unit-test
! Drop table
[
"drop table puppy;"
] [
T{ sqlite-db } db [
puppy db-table drop-sql >lower
] with-variable
] unit-test
[
"drop table kitty;"
] [
T{ sqlite-db } db [
kitty db-table drop-sql >lower
] with-variable
] unit-test
[
"drop table basket;"
] [
T{ sqlite-db } db [
basket db-table drop-sql >lower
] with-variable
] unit-test
! Insert
[
"insert into puppy(name, age) values(:name, :age);"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table insert-sql* >lower
] with-variable
] unit-test
[
"insert into kitty(id, name, age) values(:id, :name, :age);"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table insert-sql* >lower
] with-variable
] unit-test
! Update
[
"update puppy set name = :name, age = :age where id = :id"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table update-sql* >lower
] with-variable
] unit-test
[
"update kitty set name = :name, age = :age where id = :id"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table update-sql* >lower
] with-variable
] unit-test
! Delete
[
"delete from puppy where id = :id"
] [
T{ sqlite-db } db [
puppy dup db-columns swap db-table delete-sql* >lower
] with-variable
] unit-test
[
"delete from kitty where id = :id"
] [
T{ sqlite-db } db [
kitty dup db-columns swap db-table delete-sql* >lower
] with-variable
] unit-test
! Select
[
"select from puppy id, name, age where name = :name;"
{
T{
sql-spec
f
"id"
"ID"
+native-id+
{ +not-null+ }
+native-id+
}
T{ sql-spec f "name" "NAME" { VARCHAR 256 } { } f }
T{ sql-spec f "age" "AGE" INTEGER { } f }
}
] [
T{ sqlite-db } db [
T{ puppy f f "Mr. Clunkers" }
select-sql >r >lower r>
] with-variable
] unit-test

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

@ -4,7 +4,7 @@ USING: alien arrays assocs classes compiler db
hashtables io.files kernel math math.parser namespaces
prettyprint sequences strings tuples alien.c-types
continuations db.sqlite.lib db.sqlite.ffi db.tuples
words combinators.lib db.types ;
words combinators.lib db.types combinators tools.walker ;
IN: db.sqlite
TUPLE: sqlite-db path ;
@ -23,7 +23,6 @@ M: sqlite-db dispose ( db -- ) dispose-db ;
>r <sqlite-db> r> with-db ; inline
TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement
TUPLE: sqlite-result-set has-more? ;
@ -31,9 +30,15 @@ M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ;
M: sqlite-db <prepared-statement> ( str -- obj )
db get db-handle over sqlite-prepare
{ set-statement-sql set-statement-handle } statement construct
<sqlite-statement> [ set-delegate ] keep ;
db get db-handle
{
set-statement-sql
set-statement-in-params
set-statement-out-params
set-statement-handle
} statement construct
dup statement-handle over statement-sql sqlite-prepare
sqlite-statement construct-delegate ;
M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ;
@ -41,10 +46,11 @@ M: sqlite-statement dispose ( statement -- )
M: sqlite-result-set dispose ( result-set -- )
f swap set-result-set-handle ;
: sqlite-bind ( triples handle -- )
swap [ first3 sqlite-bind-type ] with each ;
: sqlite-bind ( specs handle -- )
break
swap [ sqlite-bind-type ] with each ;
M: sqlite-statement bind-statement* ( triples statement -- )
M: sqlite-statement bind-statement* ( obj statement -- )
statement-handle sqlite-bind ;
M: sqlite-statement reset-statement ( statement -- )
@ -54,8 +60,8 @@ M: sqlite-statement reset-statement ( statement -- )
db get db-handle sqlite3_last_insert_rowid
dup zero? [ "last-id failed" throw ] when ;
M: sqlite-statement insert-statement ( statement -- id )
execute-statement last-insert-id ;
M: sqlite-statement insert-tuple* ( tuple statement -- )
execute-statement last-insert-id swap set-primary-key ;
M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ;
@ -74,6 +80,7 @@ M: sqlite-result-set more-rows? ( result-set -- ? )
sqlite-result-set-has-more? ;
M: sqlite-statement query-results ( query -- result-set )
break
dup statement-handle sqlite-result-set <result-set>
dup advance-row ;
@ -86,78 +93,85 @@ M: sqlite-db commit-transaction ( -- )
M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;
M: sqlite-db create-sql ( columns table -- sql )
[
"create table " % %
" (" % [ ", " % ] [
dup second % " " %
dup third >sql-type % " " %
sql-modifiers " " join %
] interleave ")" %
] "" make ;
: sqlite-make ( class quot -- )
>r sql-props r>
{ "" { } { } } nmake <simple-statement> ;
M: sqlite-db drop-sql ( columns table -- sql )
M: sqlite-db create-sql-statement ( class -- statement )
[
"drop table " % %
drop
] "" make ;
"create table " 0% 0%
"(" 0% [ ", " 0% ] [
dup sql-spec-column-name 0%
" " 0%
dup sql-spec-type t lookup-type 0%
modifiers 0%
] interleave ");" 0%
] sqlite-make ;
M: sqlite-db insert-sql* ( columns table -- sql )
M: sqlite-db drop-sql-statement ( class -- statement )
[
"insert into " %
%
"(" %
dup [ ", " % ] [ second % ] interleave
") " %
" values (" %
[ ", " % ] [ ":" % second % ] interleave
")" %
] "" make ;
"drop table " 0% 0% ";" 0% drop
] sqlite-make ;
: where-primary-key% ( columns -- )
" where " %
[ primary-key? ] find nip second dup % " = :" % % ;
M: sqlite-db update-sql* ( columns table -- sql )
M: sqlite-db <insert-native-statement> ( tuple -- statement )
[
"update " %
%
" set " %
"insert into " 0% 0%
"(" 0%
maybe-remove-id
dup [ ", " 0% ] [ sql-spec-column-name 0% ] interleave
") values(" 0%
[ ", " 0% ] [ bind% ] interleave
");" 0%
] sqlite-make ;
M: sqlite-db <insert-assigned-statement> ( tuple -- statement )
<insert-native-statement> ;
: where-primary-key% ( specs -- )
" where " 0%
find-primary-key sql-spec-column-name dup 0% " = " 0% bind% ;
M: sqlite-db <update-tuple-statement> ( class -- statement )
[
"update " 0%
0%
" set " 0%
dup remove-id
[ ", " % ] [ second dup % " = :" % % ] interleave
[ ", " 0% ] [ sql-spec-column-name dup 0% " = " 0% bind% ] interleave
where-primary-key%
] "" make ;
] sqlite-make ;
M: sqlite-db delete-sql* ( columns table -- sql )
M: sqlite-db <delete-tuple-statement> ( specs table -- sql )
[
"delete from " %
%
" where " %
first second dup % " = :" % %
] "" make ;
"delete from " 0% 0%
" where " 0%
find-primary-key
sql-spec-column-name dup 0% " = " 0% bind%
] sqlite-make ;
: select-interval ( interval name -- )
;
! : select-interval ( interval name -- ) ;
! : select-sequence ( seq name -- ) ;
: select-sequence ( seq name -- )
;
M: sqlite-db bind% ( spec -- )
dup 1, sql-spec-column-name ":" swap append 0% ;
! dup 1, sql-spec-column-name
! dup 0% " = " 0% ":" swap append 0% ;
M: sqlite-db select-sql ( columns table -- sql )
M: sqlite-db <select-by-slots-statement> ( tuple class -- statement )
[
"select ROWID, " %
over [ ", " % ] [ second % ] interleave
" from " % %
" where " %
] "" make ;
"select " 0%
over [ ", " 0% ]
[ dup sql-spec-column-name 0% 2, ] interleave
M: sqlite-db tuple>params ( columns tuple -- obj )
[
>r [ second ":" swap append ] keep r>
dupd >r first r> get-slot-named swap
third 3array
] curry map ;
" from " 0% 0%
[ sql-spec-slot-name swap get-slot-named ] with subset
" where " 0%
[ ", " 0% ]
[ dup sql-spec-column-name 0% " = " 0% bind% ] interleave
";" 0%
] sqlite-make ;
: sqlite-db-modifiers ( -- hashtable )
M: sqlite-db modifier-table ( -- hashtable )
H{
{ +native-id+ "primary key" }
{ +assigned-id+ "primary key" }
@ -168,32 +182,27 @@ M: sqlite-db tuple>params ( columns tuple -- obj )
{ +not-null+ "not null" }
} ;
M: sqlite-db sql-modifiers* ( modifiers -- str )
sqlite-db-modifiers swap [
dup array? [
first2
>r swap at r> number>string*
" " swap 3append
] [
swap at
] if
] with map [ ] subset ;
M: sqlite-db compound-modifier ( str obj -- newstr )
compound-type ;
: sqlite-type-hash ( -- assoc )
M: sqlite-db compound-type ( str seq -- newstr )
over {
{ "default" [ first number>string join-space ] }
[ 2drop ] ! "no sqlite compound data type" 3array throw ]
} case ;
M: sqlite-db type-table ( -- assoc )
H{
{ +native-id+ "integer primary key" }
{ INTEGER "integer" }
{ SERIAL "integer" }
{ TEXT "text" }
{ VARCHAR "text" }
{ TIMESTAMP "timestamp" }
{ DOUBLE "real" }
} ;
M: sqlite-db >sql-type ( obj -- str )
dup pair? [
first >sql-type
] [
sqlite-type-hash at* [ T{ no-sql-type } throw ] unless
] if ;
M: sqlite-db create-type-table
type-table ;
! HOOK: get-column-value ( n result-set type -- )
! M: sqlite get-column-value { { "TEXT" get-text-column } {

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

@ -1,19 +1,19 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.sqlite db.tuples
db.types continuations namespaces db.postgresql math ;
! tools.time ;
USING: io.files kernel tools.test db db.tuples
db.types continuations namespaces db.postgresql math
prettyprint tools.walker db.sqlite ;
IN: temporary
TUPLE: person the-id the-name the-number real ;
TUPLE: person the-id the-name the-number the-real ;
: <person> ( name age real -- person )
{
set-person-the-name
set-person-the-number
set-person-real
set-person-the-real
} person construct ;
: <assigned-person> ( id name number real -- obj )
: <assigned-person> ( id name number the-real -- obj )
<person> [ set-person-the-id ] keep ;
SYMBOL: the-person
@ -30,8 +30,12 @@ SYMBOL: the-person
[ ] [ the-person get update-tuple ] unit-test
[ ] [ the-person get delete-tuple ] unit-test
; ! 1 [ ] [ person drop-table ] unit-test ;
[ T{ person f 1 "billy" 200 3.14 } ]
[ T{ person f 1 } select-tuple ] unit-test
! [ ] [ the-person get delete-tuple ] unit-test
! [ ] [ person drop-table ] unit-test
;
: test-sqlite ( -- )
"tuples-test.db" resource-path <sqlite-db> [
@ -39,32 +43,66 @@ SYMBOL: the-person
] with-db ;
: test-postgresql ( -- )
"localhost" "postgres" "" "factor-test" <postgresql-db> [
{ "localhost" "postgres" "" "factor-test" } postgresql-db [
test-tuples
] with-db ;
person "PERSON"
{
{ "the-id" "ID" SERIAL +native-id+ }
{ "the-id" "ID" +native-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "real" "REAL" DOUBLE { +default+ 0.3 } }
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
} define-persistent
"billy" 10 3.14 <person> the-person set
! test-sqlite
test-postgresql
test-postgresql
! person "PERSON"
! {
! { "the-id" "ID" INTEGER +assigned-id+ }
! { "the-name" "NAME" { VARCHAR 256 } +not-null+ }
! { "the-number" "AGE" INTEGER { +default+ 0 } }
! { "real" "REAL" DOUBLE { +default+ 0.3 } }
! { "the-real" "REAL" DOUBLE { +default+ 0.3 } }
! } define-persistent
! 1 "billy" 20 6.28 <assigned-person> the-person set
! test-sqlite
! test-postgresql
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
paste "PASTE"
{
{ "n" "ID" +native-id+ }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "channel" "CHANNEL" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
{ "date" "DATE" TIMESTAMP }
{ "annotations" { +has-many+ annotation } }
} define-persistent
annotation "ANNOTATION"
{
{ "n" "ID" +native-id+ }
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "mode" "MODE" TEXT }
{ "contents" "CONTENTS" TEXT }
} define-persistent
! "localhost" "postgres" "" "factor-test" <postgresql-db> [
! [ paste drop-table ] [ drop ] recover
! [ annotation drop-table ] [ drop ] recover
! [ paste drop-table ] [ drop ] recover
! [ annotation drop-table ] [ drop ] recover
! [ ] [ paste create-table ] unit-test
! [ ] [ annotation create-table ] unit-test
! ] with-db

160
extra/db/tuples/tuples.factor
View File

@ -1,115 +1,103 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs classes db kernel namespaces
tuples words sequences slots slots.private math
math.parser io prettyprint db.types continuations ;
tuples words sequences slots math
math.parser io prettyprint db.types continuations
mirrors sequences.lib tools.walker combinators.lib ;
IN: db.tuples
: db-columns ( class -- obj ) "db-columns" word-prop ;
: define-persistent ( class table columns -- )
>r dupd "db-table" set-word-prop dup r>
[ relation? ] partition swapd
dupd [ spec>tuple ] with map
"db-columns" set-word-prop
"db-relations" set-word-prop ;
: db-table ( class -- obj ) "db-table" word-prop ;
: db-columns ( class -- obj ) "db-columns" word-prop ;
: db-relations ( class -- obj ) "db-relations" word-prop ;
TUPLE: no-slot-named ;
: no-slot-named ( -- * ) T{ no-slot-named } throw ;
: set-primary-key ( key tuple -- )
[
class db-columns find-primary-key sql-spec-slot-name
] keep set-slot-named ;
: slot-spec-named ( str class -- slot-spec )
"slots" word-prop [ slot-spec-name = ] with find nip
[ no-slot-named ] unless* ;
! returns a sequence of prepared-statements
HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
: offset-of-slot ( str obj -- n )
class slot-spec-named slot-spec-offset ;
HOOK: <insert-native-statement> db ( tuple -- obj )
HOOK: <insert-assigned-statement> db ( tuple -- obj )
: get-slot-named ( str obj -- value )
tuck offset-of-slot [ no-slot-named ] unless* slot ;
HOOK: <update-tuple-statement> db ( tuple -- obj )
HOOK: <update-tuples-statement> db ( tuple -- obj )
: set-slot-named ( value str obj -- )
tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
HOOK: <delete-tuple-statement> db ( tuple -- obj )
HOOK: <delete-tuples-statement> db ( tuple -- obj )
: primary-key-spec ( class -- spec )
db-columns [ primary-key? ] find nip ;
: primary-key ( tuple -- obj )
dup class primary-key-spec get-slot-named ;
: set-primary-key ( obj tuple -- )
[ class primary-key-spec first ] keep
set-slot-named ;
: cache-statement ( columns class assoc quot -- statement )
[ db-table dupd ] swap
[ <prepared-statement> ] 3compose cache nip ; inline
HOOK: create-sql db ( columns table -- seq )
HOOK: drop-sql db ( columns table -- seq )
HOOK: insert-sql* db ( columns table -- slot-names sql )
HOOK: update-sql* db ( columns table -- slot-names sql )
HOOK: delete-sql* db ( columns table -- slot-names sql )
HOOK: select-sql db ( tuple -- statement )
HOOK: <select-by-slots-statement> db ( tuple -- tuple )
HOOK: row-column-typed db ( result-set n type -- sql )
HOOK: sql-type>factor-type db ( obj type -- obj )
HOOK: tuple>params db ( columns tuple -- obj )
HOOK: insert-tuple* db ( tuple statement -- )
: resulting-tuple ( row out-params -- tuple )
dup first sql-spec-class construct-empty [
[
>r [ sql-spec-type sql-type>factor-type ] keep
sql-spec-slot-name r> set-slot-named
] curry 2each
] keep ;
HOOK: make-slot-names* db ( quot -- seq )
HOOK: column-slot-name% db ( spec -- )
HOOK: column-bind-name% db ( spec -- )
: query-tuples ( statement -- seq )
[ statement-out-params ] keep query-results [
! out-parms result-set
[
sql-row swap resulting-tuple
] with query-map
] with-disposal ;
: query-modify-tuple ( tuple statement -- )
[ query-results [ sql-row ] with-disposal ] keep
statement-out-params rot [
>r [ sql-spec-type sql-type>factor-type ] keep
sql-spec-slot-name r> set-slot-named
] curry 2each ;
: make-slots-names ( quot -- seq str )
[ make-slot-names* ] "" make ; inline
: slot-name% ( seq -- ) first % ;
: column-name% ( seq -- ) second % ;
: column-type% ( seq -- ) third % ;
: sql-props ( class -- columns table )
dup db-columns swap db-table ;
: insert-sql ( columns class -- statement )
db get db-insert-statements [ insert-sql* ] cache-statement ;
: create-table ( class -- ) create-sql-statement execute-statement ;
: drop-table ( class -- ) drop-sql-statement execute-statement ;
: update-sql ( columns class -- statement )
db get db-update-statements [ update-sql* ] cache-statement ;
: insert-native ( tuple -- )
dup class <insert-native-statement>
[ bind-tuple ] 2keep insert-tuple* ;
: delete-sql ( columns class -- statement )
db get db-delete-statements [ delete-sql* ] cache-statement ;
: tuple-statement ( columns tuple quot -- statement )
>r [ tuple>params ] 2keep class r> call
2dup . .
[ bind-statement ] keep ;
: make-tuple-statement ( tuple columns-quot statement-quot -- statement )
>r [ class db-columns ] swap compose keep
r> tuple-statement ;
: do-tuple-statement ( tuple columns-quot statement-quot -- )
make-tuple-statement execute-statement ;
: create-table ( class -- )
dup db-columns swap db-table create-sql sql-command ;
: drop-table ( class -- )
dup db-columns swap db-table drop-sql sql-command ;
: insert-assigned ( tuple -- )
dup class <insert-assigned-statement>
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
[
[ maybe-remove-id ] [ insert-sql ]
make-tuple-statement insert-statement
] keep set-primary-key ;
dup class db-columns find-primary-key assigned-id? [
insert-assigned
] [
insert-native
] if ;
: update-tuple ( tuple -- )
[ ] [ update-sql ] do-tuple-statement ;
dup class <update-tuple-statement>
[ bind-tuple ] keep execute-statement ;
: delete-tuple ( tuple -- )
[ [ primary-key? ] subset ] [ delete-sql ] do-tuple-statement ;
: select-tuple ( tuple -- )
[ select-sql ] keep do-query ;
: update-tuples ( seq -- )
<update-tuples-statement> execute-statement ;
: persist ( tuple -- )
dup primary-key [ update-tuple ] [ insert-tuple ] if ;
dup class db-columns find-primary-key ;
: define-persistent ( class table columns -- )
>r dupd "db-table" set-word-prop r>
"db-columns" set-word-prop ;
: define-relation ( spec -- )
drop ;
: setup-select ( tuple -- statement )
dup dup class <select-by-slots-statement>
[ bind-tuple ] keep ;
: select-tuples ( tuple -- tuple ) setup-select query-tuples ;
: select-tuple ( tuple -- tuple ) select-tuples first ;

205
extra/db/types/types.factor
View File

@ -1,21 +1,50 @@
! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
sequences continuations ;
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors tuples combinators ;
IN: db.types
HOOK: modifier-table db ( -- hash )
HOOK: compound-modifier db ( str seq -- hash )
HOOK: type-table db ( -- hash )
HOOK: create-type-table db ( -- hash )
HOOK: compound-type db ( str n -- hash )
TUPLE: sql-spec class slot-name column-name type modifiers primary-key ;
! ID is the Primary key
! +native-id+ can be a columns type or a modifier
SYMBOL: +native-id+
! +assigned-id+ can only be a modifier
SYMBOL: +assigned-id+
: primary-key? ( spec -- ? )
[ { +native-id+ +assigned-id+ } member? ] contains? ;
: (primary-key?) ( obj -- ? )
{ +native-id+ +assigned-id+ } member? ;
: contains-id? ( columns id -- ? )
swap [ member? ] with contains? ;
: assigned-id? ( columns -- ? ) +assigned-id+ contains-id? ;
: native-id? ( columns -- ? ) +native-id+ contains-id? ;
: primary-key? ( spec -- ? )
sql-spec-primary-key (primary-key?) ;
: normalize-spec ( spec -- )
dup sql-spec-type dup (primary-key?) [
swap set-sql-spec-primary-key
] [
drop dup sql-spec-modifiers [
(primary-key?)
] deep-find
[ swap set-sql-spec-primary-key ] [ drop ] if*
] if ;
: find-primary-key ( specs -- obj )
[ sql-spec-primary-key ] find nip ;
: native-id? ( spec -- ? )
sql-spec-primary-key +native-id+ = ;
: assigned-id? ( spec -- ? )
sql-spec-primary-key +assigned-id+ = ;
SYMBOL: +foreign-id+
! Same concept, SQLite has autoincrement, PostgreSQL has serial
SYMBOL: +autoincrement+
@ -28,40 +57,168 @@ SYMBOL: +not-null+
SYMBOL: +has-many+
SYMBOL: SERIAL
SYMBOL: INTEGER
SYMBOL: DOUBLE
SYMBOL: BOOLEAN
: relation? ( spec -- ? ) [ +has-many+ = ] deep-find ;
SYMBOL: INTEGER
SYMBOL: BIG_INTEGER
SYMBOL: DOUBLE
SYMBOL: REAL
SYMBOL: BOOLEAN
SYMBOL: TEXT
SYMBOL: VARCHAR
SYMBOL: TIMESTAMP
SYMBOL: DATE
SYMBOL: BIG_INTEGER
: spec>tuple ( class spec -- tuple )
[ ?first3 ] keep 3 ?tail*
{
set-sql-spec-class
set-sql-spec-slot-name
set-sql-spec-column-name
set-sql-spec-type
set-sql-spec-modifiers
} sql-spec construct
dup normalize-spec ;
: sql-type-hash ( -- assoc )
H{
{ INTEGER "integer" }
{ TEXT "text" }
{ VARCHAR "varchar" }
{ DOUBLE "real" }
{ TIMESTAMP "timestamp" }
} ;
TUPLE: no-sql-type ;
: no-sql-type ( -- * ) T{ no-sql-type } throw ;
HOOK: sql-modifiers* db ( modifiers -- str )
HOOK: >sql-type db ( obj -- str )
! HOOK: >factor-type db ( obj -- obj )
TUPLE: no-sql-modifier ;
: no-sql-modifier ( -- * ) T{ no-sql-modifier } throw ;
: number>string* ( n/str -- str )
dup number? [ number>string ] when ;
: maybe-remove-id ( columns -- obj )
[ +native-id+ swap member? not ] subset ;
: maybe-remove-id ( specs -- obj )
[ native-id? not ] subset ;
: remove-id ( columns -- obj )
[ primary-key? not ] subset ;
: remove-relations ( specs -- newcolumns )
[ relation? not ] subset ;
: sql-modifiers ( spec -- seq )
3 tail sql-modifiers* ;
: remove-id ( specs -- obj )
[ sql-spec-primary-key not ] subset ;
! SQLite Types: http://www.sqlite.org/datatype3.html
! NULL INTEGER REAL TEXT BLOB
! PostgreSQL Types:
! http://developer.postgresql.org/pgdocs/postgres/datatype.html
: lookup-modifier ( obj -- str )
dup array? [
unclip lookup-modifier swap compound-modifier
] [
modifier-table at*
[ "unknown modifier" throw ] unless
] if ;
: lookup-type* ( obj -- str )
dup array? [
first lookup-type*
] [
type-table at*
[ no-sql-type ] unless
] if ;
: lookup-create-type ( obj -- str )
dup array? [
unclip lookup-create-type swap compound-type
] [
dup create-type-table at*
[ nip ] [ drop lookup-type* ] if
] if ;
: lookup-type ( obj create? -- str )
[ lookup-create-type ] [ lookup-type* ] if ;
: single-quote ( str -- newstr )
"'" swap "'" 3append ;
: double-quote ( str -- newstr )
"\"" swap "\"" 3append ;
: paren ( str -- newstr )
"(" swap ")" 3append ;
: join-space ( str1 str2 -- newstr )
" " swap 3append ;
: modifiers ( spec -- str )
sql-spec-modifiers
[ lookup-modifier ] map " " join
dup empty? [ " " swap append ] unless ;
SYMBOL: building-seq
: get-building-seq ( n -- seq )
building-seq get nth ;
: n, get-building-seq push ;
: n% get-building-seq push-all ;
: n# >r number>string r> n% ;
: 0, 0 n, ;
: 0% 0 n% ;
: 0# 0 n# ;
: 1, 1 n, ;
: 1% 1 n% ;
: 1# 1 n# ;
: 2, 2 n, ;
: 2% 2 n% ;
: 2# 2 n# ;
: nmake ( quot exemplars -- seqs )
dup length dup zero? [ 1+ ] when
[
[
[ drop 1024 swap new-resizable ] 2map
[ building-seq set call ] keep
] 2keep >r [ like ] 2map r> firstn
] with-scope ;
HOOK: bind% db ( spec -- )
TUPLE: no-slot-named ;
: no-slot-named ( -- * ) T{ no-slot-named } throw ;
: slot-spec-named ( str class -- slot-spec )
"slots" word-prop [ slot-spec-name = ] with find nip
[ no-slot-named ] unless* ;
: offset-of-slot ( str obj -- n )
class slot-spec-named slot-spec-offset ;
: get-slot-named ( str obj -- value )
tuck offset-of-slot [ no-slot-named ] unless* slot ;
: set-slot-named ( value str obj -- )
tuck offset-of-slot [ no-slot-named ] unless* set-slot ;
: tuple>filled-slots ( tuple -- alist )
dup <mirror> mirror-slots [ slot-spec-name ] map
swap tuple-slots 2array flip [ nip ] assoc-subset ;
: tuple>params ( specs tuple -- obj )
[
>r dup sql-spec-type swap sql-spec-slot-name r>
get-slot-named swap
] curry { } map>assoc ;
: sql-type>factor-type ( obj type -- obj )
dup array? [ first ] when
{
{ +native-id+ [ string>number ] }
{ INTEGER [ string>number ] }
{ DOUBLE [ string>number ] }
{ REAL [ string>number ] }
{ TEXT [ ] }
{ VARCHAR [ ] }
[ "no conversion from sql type to factor type" throw ]
} case ;

3
extra/editors/editors.factor
View File

@ -35,6 +35,9 @@ SYMBOL: edit-hook
: edit ( defspec -- )
where [ first2 edit-location ] when* ;
: edit-vocab ( name -- )
vocab-source-path 1 edit-location ;
: :edit ( -- )
error get delegates [ parse-error? ] find-last nip [
dup parse-error-file source-file-path ?resource-path

2
extra/editors/editpadpro/editpadpro.factor
View File

@ -6,7 +6,7 @@ IN: editors.editpadpro
: editpadpro-path
\ editpadpro-path get-global [
program-files "JGsoft" path+
[ >lower "editpadpro.exe" tail? ] find-file-breadth
t [ >lower "editpadpro.exe" tail? ] find-file
] unless* ;
: editpadpro ( file line -- )

2
extra/editors/gvim/windows/windows.factor Normal file → Executable file
View File

@ -5,5 +5,5 @@ IN: editors.gvim.windows
M: windows-io gvim-path
\ gvim-path get-global [
program-files "vim" path+
[ "gvim.exe" tail? ] find-file-breadth
t [ "gvim.exe" tail? ] find-file
] unless* ;

4
extra/http/server/responders/responders.factor
View File

@ -77,7 +77,7 @@ SYMBOL: max-post-request
1024 256 * max-post-request set-global
: content-length ( header -- n )
"Content-Length" swap at string>number dup [
"content-length" peek at string>number dup [
dup max-post-request get > [
"Content-Length > max-post-request" throw
] when
@ -136,7 +136,7 @@ LOG: log-headers DEBUG
: host ( -- string )
#! The host the current responder was called from.
"Host" header-param ":" split1 drop ;
"host" header-param ":" split1 drop ;
: add-responder ( responder -- )
#! Add a responder object to the list.

85
extra/io/paths/paths.factor Normal file → Executable file
View File

@ -1,49 +1,52 @@
USING: arrays assocs combinators.lib dlists io.files
kernel namespaces sequences shuffle vectors ;
USING: io.files kernel sequences new-slots accessors
dlists arrays ;
IN: io.paths
! HOOK: library-roots io-backend ( -- seq )
! HOOK: binary-roots io-backend ( -- seq )
TUPLE: directory-iterator path bfs queue ;
<PRIVATE
: append-path ( path files -- paths )
[ >r path+ r> ] with* assoc-map ;
: qualified-directory ( path -- seq )
dup directory [ first2 >r path+ r> 2array ] with map ;
: get-paths ( dir -- paths )
dup directory append-path ;
: push-directory ( path iter -- )
>r qualified-directory r> [
dup queue>> swap bfs>>
[ push-front ] [ push-back ] if
] curry each ;
: (walk-dir) ( path -- )
first2 [
get-paths dup keys % [ (walk-dir) ] each
: <directory-iterator> ( path bfs? -- iterator )
<dlist> directory-iterator construct-boa
dup path>> over push-directory ;
: next-file ( iter -- file/f )
dup queue>> dlist-empty? [ drop f ] [
dup queue>> pop-back first2
[ over push-directory next-file ] [ nip ] if
] if ;
: iterate-directory ( iter quot -- obj )
2dup >r >r >r next-file dup [
r> call dup [
r> r> 2drop
] [
drop r> r> iterate-directory
] if
] [
drop r> r> r> 3drop f
] if ; inline
: prepare-find-file ( path bfs? quot -- iter quot' )
>r <directory-iterator> r> [ keep and ] curry ; inline
: find-file ( path bfs? quot -- path/f )
prepare-find-file iterate-directory ;
: find-all-files ( path bfs? quot -- paths )
prepare-find-file V{ } clone [
[ over [ push ] [ 2drop ] if f ] curry compose
iterate-directory
drop
] if ;
PRIVATE>
] keep ; inline
: walk-dir ( path -- seq )
dup directory? 2array [ (walk-dir) ] { } make ;
GENERIC# find-file* 1 ( obj quot -- path/f )
M: dlist find-file* ( dlist quot -- path/f )
over dlist-empty? [ 2drop f ] [
2dup >r pop-front get-paths dup r> assoc-find
[ drop 3nip ]
[ 2drop [ nip ] assoc-subset keys pick push-all-back find-file* ] if
] if ;
M: vector find-file* ( vector quot -- path/f )
over empty? [ 2drop f ] [
2dup >r pop get-paths dup r> assoc-find
[ drop 3nip ]
[ 2drop [ nip ] assoc-subset keys pick push-all find-file* ] if
] if ;
: prepare-find-file ( quot -- quot )
[ drop ] swap compose ;
: find-file-depth ( path quot -- path/f )
prepare-find-file >r 1vector r> find-file* ;
: find-file-breadth ( path quot -- path/f )
prepare-find-file >r 1dlist r> find-file* ;
: recursive-directory ( path bfs? -- paths )
<directory-iterator>
[ dup next-file dup ] [ ] [ drop ] unfold nip ;

7
extra/io/server/server.factor
View File

@ -10,10 +10,6 @@ SYMBOL: servers
<PRIVATE
: spawn-vars ( quot vars name -- )
>r [ dup get ] H{ } map>assoc [ swap bind ] 2curry r>
spawn drop ;
LOG: accepted-connection NOTICE
: with-client ( client quot -- )
@ -26,8 +22,7 @@ LOG: accepted-connection NOTICE
: accept-loop ( server quot -- )
[
>r accept r> [ with-client ] 2curry
{ log-service servers } "Client" spawn-vars
>r accept r> [ with-client ] 2curry "Client" spawn drop
] 2keep accept-loop ; inline
: server-loop ( addrspec encoding quot -- )

4
extra/sequences/lib/lib-tests.factor
View File

@ -20,8 +20,6 @@ IN: temporary
[ 10 ] [ { 1 2 3 4 } [ + ] reduce* ] unit-test
[ 24 ] [ { 1 2 3 4 } [ * ] reduce* ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
[ -4 ] [ 1 -4 [ abs ] higher ] unit-test
[ 1 ] [ 1 -4 [ abs ] lower ] unit-test
@ -80,4 +78,4 @@ IN: temporary
{ 13 } [ 1 2 { 3 4 } [ + + ] 2 each-withn + ] unit-test
[ { 910 911 912 } ] [ 10 900 3 [ + + ] map-with2 ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 nfirst ] unit-test
[ 1 2 3 4 ] [ { 1 2 3 4 } 4 firstn ] unit-test

13
extra/sequences/lib/lib.factor
View File

@ -18,8 +18,9 @@ IN: sequences.lib
: map-with2 ( obj obj list quot -- newseq ) 2 map-withn ; inline
MACRO: nfirst ( n -- )
[ [ swap nth ] curry [ keep ] curry ] map concat [ drop ] compose ;
MACRO: firstn ( n -- )
[ [ swap nth ] curry
[ keep ] curry ] map concat [ drop ] compose ;
: prepare-index ( seq quot -- seq n quot )
>r dup length r> ; inline
@ -182,6 +183,14 @@ PRIVATE>
: ?first3 ( seq -- 1st/f 2nd/f 3rd/f ) dup ?first2 rot ?third ; inline
: ?first4 ( seq -- 1st/f 2nd/f 3rd/f 4th/f ) dup ?first3 roll ?fourth ; inline
USE: continuations
: ?subseq ( from to seq -- subseq )
>r >r 0 max r> r>
[ length tuck min >r min r> ] keep subseq ;
: ?head* ( seq n -- seq/f ) (head) ?subseq ;
: ?tail* ( seq n -- seq/f ) (tail) ?subseq ;
: accumulator ( quot -- quot vec )
V{ } clone [ [ push ] curry compose ] keep ;

2
extra/ui/tools/listener/listener.factor
View File

@ -133,7 +133,7 @@ M: stack-display tool-scroller
: restart-listener ( listener -- )
dup com-end dup clear-output
[ listener-thread ] curry
[ init-namespaces listener-thread ] curry
"Listener" spawn drop ;
: init-listener ( listener -- )

2
extra/webapps/cgi/cgi.factor Normal file → Executable file
View File

@ -58,7 +58,7 @@ SYMBOL: cgi-root
] with-stream ;
: serve-regular-file ( -- )
cgi-root get "doc-root" [ file-responder ] with-variable ;
cgi-root get doc-root [ file-responder ] with-variable ;
: do-cgi ( name -- )
{

15
extra/webapps/file/file.factor
View File

@ -1,14 +1,15 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar html io io.files kernel math math.parser
http.server.responders http.server.templating namespaces parser
sequences strings assocs hashtables debugger http.mime sorting
html.elements logging io.encodings.binary ;
IN: webapps.file
SYMBOL: doc-root
: serving-path ( filename -- filename )
"" or "doc-root" get swap path+ ;
"" or doc-root get swap path+ ;
: file-http-date ( filename -- string )
file-modified unix-time>timestamp timestamp>http-string ;
@ -61,7 +62,7 @@ SYMBOL: page
\ run-page DEBUG add-input-logging
: include-page ( filename -- )
"doc-root" get swap path+ run-page ;
serving-path run-page ;
: serve-fhtml ( filename -- )
serving-html
@ -115,18 +116,18 @@ SYMBOL: page
] if ;
: file-responder ( -- )
"doc-root" get [
doc-root get [
"argument" get serve-object
] [
"404 doc-root not set" httpd-error
] if ;
global [
! Serves files from a directory stored in the "doc-root"
! Serves files from a directory stored in the doc-root
! variable. You can set the variable in the global
! namespace, or inside the responder.
"file" [ file-responder ] add-simple-responder
! The root directory is served by...
"file" set-default-responder
] bind
] bind

4
extra/webapps/fjsc/fjsc.factor
View File

@ -53,7 +53,7 @@ IN: webapps.fjsc
! the 'fjsc' responder.
"fjsc-resources" [
[
"extra/fjsc/resources/" resource-path "doc-root" set
"extra/fjsc/resources/" resource-path doc-root set
file-responder
] with-scope
] add-simple-responder
@ -62,7 +62,7 @@ IN: webapps.fjsc
! 'termlib'.
"fjsc-repl-resources" [
[
"extra/webapps/fjsc/resources/" resource-path "doc-root" set
"extra/webapps/fjsc/resources/" resource-path doc-root set
file-responder
] with-scope
] add-simple-responder ;

6
extra/webapps/source/source.factor
View File

@ -15,14 +15,16 @@ IN: webapps.source
: source-responder ( path mime-type -- )
drop
serving-html
[ dup utf8 <file-reader> htmlize-stream ] with-html-stream ;
[
dup file-name swap utf8 <file-reader> htmlize-stream
] with-html-stream ;
global [
! Serve up our own source code
"source" [
"argument" get check-source-path [
[
"" resource-path "doc-root" set
"" resource-path doc-root set
[ source-responder ] serve-file-hook set
file-responder
] with-scope

4
vm/Config.windows.nt
View File

@ -1,6 +1,6 @@
LIBS = -lm
EXE_SUFFIX=-nt
DLL_SUFFIX=-nt
EXE_SUFFIX=
DLL_SUFFIX=
PLAF_DLL_OBJS += vm/os-windows-nt.o
PLAF_EXE_OBJS += vm/resources.o
PLAF_EXE_OBJS += vm/main-windows-nt.o

4
vm/os-windows-nt.h
View File

@ -13,8 +13,8 @@ typedef char F_SYMBOL;
#define from_symbol_string from_char_string
#define FACTOR_OS_STRING "winnt"
#define FACTOR_DLL L"factor-nt.dll"
#define FACTOR_DLL_NAME "factor-nt.dll"
#define FACTOR_DLL L"factor.dll"
#define FACTOR_DLL_NAME "factor.dll"
void c_to_factor_toplevel(CELL quot);
long exception_handler(PEXCEPTION_POINTERS pe);