From d56acaab86caf7a45ecdf48163863dd9cc58e08d Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 29 Jan 2008 20:50:15 -0800
Subject: [PATCH 01/52] Fix broken opengl shader words
---
extra/opengl/opengl.factor | 17 +++++++++--------
1 file changed, 9 insertions(+), 8 deletions(-)
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index 4ea91b867b..2c1d4de75c 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -255,7 +255,7 @@ TUPLE: sprite loc dim dim2 dlist texture ;
: c-true? ( int -- ? ) zero? not ; inline
: with-gl-shader-source-ptr ( string quot -- )
- swap >byte-array malloc-byte-array [
+ swap string>char-alien malloc-byte-array [
<void*> swap call
] keep free ; inline
@@ -294,9 +294,8 @@ TUPLE: sprite loc dim dim2 dlist texture ;
GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
: gl-shader-info-log ( shader -- log )
- dup gl-shader-info-log-length
- dup [
- 0 <int> over glGetShaderInfoLog
+ dup gl-shader-info-log-length dup [
+ [ 0 <int> swap glGetShaderInfoLog ] keep
alien>char-string
] with-malloc ;
@@ -330,9 +329,10 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
GL_INFO_LOG_LENGTH gl-program-get-int ; inline
: gl-program-info-log ( program -- log )
- dup gl-program-info-log-length
- dup [ [ 0 <int> swap glGetProgramInfoLog ] keep
- alien>char-string ] with-malloc ;
+ dup gl-program-info-log-length dup [
+ [ 0 <int> swap glGetProgramInfoLog ] keep
+ alien>char-string
+ ] with-malloc ;
: check-gl-program ( program -- program* )
dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
@@ -342,7 +342,8 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
: gl-program-shaders ( program -- shaders )
dup gl-program-shaders-length [
- dup "GLuint" <c-array> 0 <int> over glGetAttachedShaders
+ dup "GLuint" <c-array>
+ [ 0 <int> swap glGetAttachedShaders ] keep
] keep c-uint-array> ;
: delete-gl-program-only ( program -- )
From ae31bc65d25c5a7b662b41c68aed42bda5e1f830 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Tue, 29 Jan 2008 22:01:06 -0800
Subject: [PATCH 02/52] Add with-software-renderer combinator to cocoa.views .
Hack up shader code in line-art to make it display properly with the Apple
software OpenGL implementation
---
extra/cocoa/views/views.factor | 15 ++++++++-
extra/line-art/line-art.factor | 56 +++++++++++++++++-----------------
2 files changed, 42 insertions(+), 29 deletions(-)
diff --git a/extra/cocoa/views/views.factor b/extra/cocoa/views/views.factor
index cc948df55f..7b8de9067c 100644
--- a/extra/cocoa/views/views.factor
+++ b/extra/cocoa/views/views.factor
@@ -1,7 +1,8 @@
! Copyright (C) 2006, 2007 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types arrays kernel math namespaces cocoa
-cocoa.messages cocoa.classes cocoa.types sequences ;
+cocoa.messages cocoa.classes cocoa.types sequences
+continuations ;
IN: cocoa.views
: NSOpenGLPFAAllRenderers 1 ;
@@ -35,11 +36,23 @@ IN: cocoa.views
: NSOpenGLPFAPixelBuffer 90 ;
: NSOpenGLPFAVirtualScreenCount 128 ;
+<PRIVATE
+
+SYMBOL: +software-renderer+
+
+PRIVATE>
+
+: with-software-renderer ( quot -- )
+ t +software-renderer+ set
+ [ f +software-renderer+ set ]
+ [ ] cleanup ; inline
+
: <PixelFormat> ( -- pixelfmt )
NSOpenGLPixelFormat -> alloc [
NSOpenGLPFAWindow ,
NSOpenGLPFADoubleBuffer ,
NSOpenGLPFADepthSize , 16 ,
+ +software-renderer+ get [ NSOpenGLPFARobust , ] when
0 ,
] { } make >c-int-array
-> initWithAttributes:
diff --git a/extra/line-art/line-art.factor b/extra/line-art/line-art.factor
index 1a0ae6993f..9856921a51 100644
--- a/extra/line-art/line-art.factor
+++ b/extra/line-art/line-art.factor
@@ -57,13 +57,7 @@ uniform sampler2D colormap, normalmap, depthmap;
uniform vec4 line_color;
varying vec2 coord;
-const float DEPTH_RATIO_THRESHOLD = 1.001, NORMAL_DOT_THRESHOLD = 1.0, SAMPLE_SPREAD = 1.0/512.0;
-
-bool
-is_normal_border(vec3 norm1, vec3 norm2)
-{
- return dot(norm1, norm2) < NORMAL_DOT_THRESHOLD;
-}
+const float DEPTH_RATIO_THRESHOLD = 1.001, SAMPLE_SPREAD = 1.0/512.0;
float
depth_sample(vec2 c)
@@ -97,33 +91,39 @@ border_factor(vec2 c)
coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD),
coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD);
- vec4 depths = vec4(depth_sample(coord1),
- depth_sample(coord2),
- depth_sample(coord3),
- depth_sample(coord4));
- if (depths == vec4(1, 1, 1, 1))
- return 0.0;
-
- vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww;
-
- if (are_depths_border(ratios1) || are_depths_border(ratios2))
- return 1.0;
-
vec3 normal1 = normal_sample(coord1),
normal2 = normal_sample(coord2),
normal3 = normal_sample(coord3),
normal4 = normal_sample(coord4);
+
+ if (dot(normal1, normal1) < 0.5
+ && dot(normal2, normal2) < 0.5
+ && dot(normal3, normal3) < 0.5
+ && dot(normal4, normal4) < 0.5) {
+ return 0.0;
+ } else {
+ vec4 depths = vec4(depth_sample(coord1),
+ depth_sample(coord2),
+ depth_sample(coord3),
+ depth_sample(coord4));
- float normal_border = 1.0 - min6(
- dot(normal1, normal2),
- dot(normal1, normal3),
- dot(normal1, normal4),
- dot(normal2, normal3),
- dot(normal2, normal4),
- dot(normal3, normal4)
- );
+ vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww;
- return normal_border;
+ if (are_depths_border(ratios1) || are_depths_border(ratios2)) {
+ return 1.0;
+ } else {
+ float normal_border = 1.0 - min6(
+ dot(normal1, normal2),
+ dot(normal1, normal3),
+ dot(normal1, normal4),
+ dot(normal2, normal3),
+ dot(normal2, normal4),
+ dot(normal3, normal4)
+ );
+
+ return normal_border;
+ }
+ }
}
void
From fd4254ca094f0e8d6134e02f87c661899a98145e Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.local>
Date: Thu, 31 Jan 2008 11:34:03 -0600
Subject: [PATCH 03/52] update client to work with more redirects
---
extra/http/client/client.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index 7c385c0bb3..85a8b516ca 100644
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -44,7 +44,7 @@ DEFER: http-get-stream
#! Should this support Location: headers that are
#! relative URLs?
pick 100 /i 3 = [
- stream-close "Location" swap at nip http-get-stream
+ stream-close "location" swap header-single nip http-get-stream
] when ;
: http-get-stream ( url -- code headers stream )
From 7666949e13397dda79dda6ddb6d68d976119ca98 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 31 Jan 2008 20:22:19 -0800
Subject: [PATCH 04/52] byte-length generic word for determining alien buffer
sizes of byte-arrays and float-arrays
---
core/alien/alien-docs.factor | 4 ++++
core/alien/alien.factor | 2 ++
core/byte-arrays/byte-arrays.factor | 3 +++
core/float-arrays/float-arrays-docs.factor | 2 +-
core/float-arrays/float-arrays.factor | 3 ++-
5 files changed, 12 insertions(+), 2 deletions(-)
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 8fee0e8c3e..8ae89ed5b1 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -34,6 +34,10 @@ HELP: <alien>
{ $description "Creates an alien object, wrapping a raw memory address." }
{ $notes "Alien objects are invalidated between image saves and loads." } ;
+HELP: byte-length
+{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
+{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
+
HELP: c-ptr
{ $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ;
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 1c8163e2fa..4b899a15e4 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -28,6 +28,8 @@ PREDICATE: alien pinned-alien
UNION: pinned-c-ptr
pinned-alien POSTPONE: f ;
+GENERIC: byte-length ( seq -- n ) flushable
+
M: f expired? drop t ;
: <alien> ( address -- alien )
diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor
index f82569c270..d65f243d71 100755
--- a/core/byte-arrays/byte-arrays.factor
+++ b/core/byte-arrays/byte-arrays.factor
@@ -15,6 +15,9 @@ M: byte-array new drop <byte-array> ;
M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ;
+M: byte-array byte-length
+ length ;
+
INSTANCE: byte-array sequence
INSTANCE: byte-array simple-c-ptr
INSTANCE: byte-array c-ptr
diff --git a/core/float-arrays/float-arrays-docs.factor b/core/float-arrays/float-arrays-docs.factor
index 70bbfe296f..cb36aade6b 100644
--- a/core/float-arrays/float-arrays-docs.factor
+++ b/core/float-arrays/float-arrays-docs.factor
@@ -32,7 +32,7 @@ HELP: <float-array> ( n initial -- float-array )
HELP: >float-array
{ $values { "seq" "a sequence" } { "float-array" float-array } }
-{ $description "Outputs a freshly-allocated float array whose elements have the same boolean values as a given sequence." }
+{ $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." }
{ $errors "Throws an error if the sequence contains elements other than real numbers." } ;
HELP: 1float-array
diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor
index ba0b2bb61d..42a2db7cd8 100755
--- a/core/float-arrays/float-arrays.factor
+++ b/core/float-arrays/float-arrays.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private alien sequences
+USING: kernel kernel.private alien alien.c-types sequences
sequences.private math math.private ;
IN: float-arrays
@@ -12,6 +12,7 @@ PRIVATE>
M: float-array clone (clone) ;
M: float-array length array-capacity ;
+M: float-array byte-length array-capacity "float" heap-size * ;
M: float-array nth-unsafe
float-array@ alien-double ;
From f3b9e889ff6a41ec68937ab294f1b94b12012270 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Thu, 31 Jan 2008 20:24:08 -0800
Subject: [PATCH 05/52] Start work on making bunny demos use vertex buffers to
draw
---
extra/bunny/bunny.factor | 13 ++++++-
extra/cel-shading/cel-shading.factor | 54 ++++++++++++++++++++--------
extra/line-art/line-art.factor | 5 ++-
extra/opengl/opengl-docs.factor | 6 ++--
extra/opengl/opengl.factor | 28 +++++++++++++--
5 files changed, 83 insertions(+), 23 deletions(-)
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index 3042b87ad6..73a3efc742 100644
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -3,7 +3,8 @@ USING: alien alien.c-types arrays sequences math
math.vectors math.matrices math.parser io io.files kernel opengl
opengl.gl opengl.glu shuffle http.client vectors timers
namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
-combinators tools.time system combinators.lib ;
+combinators tools.time system combinators.lib combinators.cleave
+float-arrays ;
IN: bunny
: numbers ( str -- seq )
@@ -45,6 +46,16 @@ IN: bunny
<file-reader> parse-model [ normals ] 2keep 3array
] time ;
+: make-vertex-buffers ( model -- array element-array )
+ [
+ [ first concat ] [ second concat ] bi
+ append >float-array
+ GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
+ ] [
+ third concat >c-uint-array
+ GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
+ ] bi ;
+
: model-path "bun_zipper.ply" ;
: model-url "http://factorcode.org/bun_zipper.ply" ;
diff --git a/extra/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor
index 64d23275e9..992fd9655d 100644
--- a/extra/cel-shading/cel-shading.factor
+++ b/extra/cel-shading/cel-shading.factor
@@ -4,12 +4,14 @@ USING: arrays bunny combinators.lib io io.files kernel
sequences ui ui.gadgets ui.render ;
IN: cel-shading
-TUPLE: cel-shading-gadget model program ;
+TUPLE: cel-shading-gadget model program vertices elements ;
: <cel-shading-gadget> ( -- cel-shading-gadget )
0.0 0.0 0.375 <demo-gadget>
- maybe-download read-model
- { set-delegate set-cel-shading-gadget-model } cel-shading-gadget construct ;
+ maybe-download read-model {
+ set-delegate
+ set-cel-shading-gadget-model
+ } cel-shading-gadget construct ;
STRING: cel-shading-vertex-shader-source
varying vec3 position, normal;
@@ -53,34 +55,58 @@ main()
;
-: cel-shading-program ( -- program )
+: make-cel-shading-program ( -- program )
cel-shading-vertex-shader-source cel-shading-fragment-shader-source
<simple-gl-program> ;
M: cel-shading-gadget graft* ( gadget -- )
- [ "2.0" { "GL_ARB_shader_objects" } require-gl-version-or-extensions
+ "2.0" {
+ "GL_ARB_shader_objects"
+ "GL_ARB_vertex_buffer_object"
+ } require-gl-version-or-extensions
0.0 0.0 0.0 1.0 glClearColor
GL_CULL_FACE glEnable
GL_DEPTH_TEST glEnable
- cel-shading-program swap set-cel-shading-gadget-program ] [ ] [ :c ] cleanup ;
+ dup cel-shading-gadget-model make-vertex-buffers
+ make-cel-shading-program roll {
+ set-cel-shading-gadget-vertices
+ set-cel-shading-gadget-elements
+ set-cel-shading-gadget-program
+ } set-slots ;
M: cel-shading-gadget ungraft* ( gadget -- )
- cel-shading-gadget-program [ delete-gl-program ] when* ;
+ {
+ [ cel-shading-gadget-program [ delete-gl-program ] when* ]
+ [ cel-shading-gadget-elements [ delete-gl-buffer ] when* ]
+ [ cel-shading-gadget-vertices [ delete-gl-buffer ] when* ]
+ } call-with ;
: cel-shading-draw-setup ( gadget -- gadget )
[ demo-gadget-set-matrices ] keep
- [ cel-shading-gadget-program
- { [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ]
- [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
- [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
- [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ] } call-with
- ] keep ;
+ [ cel-shading-gadget-program {
+ [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ]
+ [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
+ [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
+ [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ]
+ } call-with ] keep ;
M: cel-shading-gadget draw-gadget* ( gadget -- )
dup cel-shading-gadget-program [
cel-shading-draw-setup
0.0 -0.12 0.0 glTranslatef
- cel-shading-gadget-model first3 draw-bunny
+ dup {
+ cel-shading-gadget-vertices
+ cel-shading-gadget-elements
+ } get-slots [
+ GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [
+ GL_FLOAT 0 0 buffer-offset glNormalPointer
+ cel-shading-gadget-model dup
+ first length 3 * 4 * buffer-offset
+ 3 GL_FLOAT 0 roll glVertexPointer
+ third length 3 *
+ GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
+ ] all-enabled-client-state
+ ] with-array-element-buffers
] with-gl-program ;
: cel-shading-window ( -- )
diff --git a/extra/line-art/line-art.factor b/extra/line-art/line-art.factor
index 9856921a51..d78ea8a4ee 100644
--- a/extra/line-art/line-art.factor
+++ b/extra/line-art/line-art.factor
@@ -187,7 +187,7 @@ main()
] if ;
M: line-art-gadget graft* ( gadget -- )
- [ "2.0" { "GL_ARB_draw_buffers"
+ "2.0" { "GL_ARB_draw_buffers"
"GL_ARB_shader_objects"
"GL_ARB_multitexture"
"GL_ARB_texture_float" }
@@ -196,8 +196,7 @@ M: line-art-gadget graft* ( gadget -- )
GL_CULL_FACE glEnable
GL_DEPTH_TEST glEnable
(line-art-step1-program) over set-line-art-gadget-step1-program
- (line-art-step2-program) swap set-line-art-gadget-step2-program
- ] [ ] [ :c ] cleanup ;
+ (line-art-step2-program) swap set-line-art-gadget-step2-program ;
M: line-art-gadget ungraft* ( gadget -- )
dup line-art-gadget-framebuffer [
diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor
index cc8221baa1..63875e91a8 100644
--- a/extra/opengl/opengl-docs.factor
+++ b/extra/opengl/opengl-docs.factor
@@ -65,7 +65,7 @@ HELP: gen-renderbuffer
{ $values { "id" integer } }
{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
-HELP: gen-buffer
+HELP: gen-gl-buffer
{ $values { "id" integer } }
{ $description "Wrapper for " { $link glGenBuffers } " to handle the common case of generating a single buffer ID." } ;
@@ -81,14 +81,14 @@ HELP: delete-renderbuffer
{ $values { "id" integer } }
{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
-HELP: delete-buffer
+HELP: delete-gl-buffer
{ $values { "id" integer } }
{ $description "Wrapper for " { $link glDeleteBuffers } " to handle the common case of deleting a single buffer ID." } ;
{ gen-texture delete-texture } related-words
{ gen-framebuffer delete-framebuffer } related-words
{ gen-renderbuffer delete-renderbuffer } related-words
-{ gen-buffer delete-buffer } related-words
+{ gen-gl-buffer delete-gl-buffer } related-words
HELP: framebuffer-incomplete?
{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index 2c1d4de75c..a6aecf1b77 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -30,6 +30,13 @@ IN: opengl
: do-enabled ( what quot -- )
over glEnable dip glDisable ; inline
+: do-enabled-client-state ( what quot -- )
+ over glEnableClientState dip glDisableClientState ; inline
+
+: all-enabled ( seq quot -- )
+ over [ glEnable ] each dip [ glDisable ] each ; inline
+: all-enabled-client-state ( seq quot -- )
+ over [ glEnableClientState ] each dip [ glDisableClientState ] each ; inline
: do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep
@@ -103,7 +110,7 @@ IN: opengl
[ glGenFramebuffersEXT ] (gen-gl-object) ;
: gen-renderbuffer ( -- id )
[ glGenRenderbuffersEXT ] (gen-gl-object) ;
-: gen-buffer ( -- id )
+: gen-gl-buffer ( -- id )
[ glGenBuffers ] (gen-gl-object) ;
: (delete-gl-object) ( id quot -- )
@@ -114,9 +121,26 @@ IN: opengl
[ glDeleteFramebuffersEXT ] (delete-gl-object) ;
: delete-renderbuffer ( id -- )
[ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
-: delete-buffer ( id -- )
+: delete-gl-buffer ( id -- )
[ glDeleteBuffers ] (delete-gl-object) ;
+: with-gl-buffer ( binding id quot -- )
+ -rot dupd glBindBuffer
+ [ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline
+
+: with-array-element-buffers ( array-buffer element-buffer quot -- )
+ -rot GL_ELEMENT_ARRAY_BUFFER swap [
+ swap GL_ARRAY_BUFFER -rot with-gl-buffer
+ ] with-gl-buffer ; inline
+
+: <gl-buffer> ( target data hint -- id )
+ pick gen-gl-buffer [ [
+ >r dup byte-length swap r> glBufferData
+ ] with-gl-buffer ] keep ;
+
+: buffer-offset ( int -- alien )
+ <alien> ; inline
+
: framebuffer-incomplete? ( -- status/f )
GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
From 71358d3c4aef7bc4946d5655889de2b895152dea Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.(none)>
Date: Fri, 1 Feb 2008 17:43:44 -0600
Subject: [PATCH 06/52] first commit of db stuff
---
extra/db/db.factor | 96 ++++++
extra/db/postgresql/authors.txt | 1 +
extra/db/postgresql/ffi/ffi.factor | 360 ++++++++++++++++++++
extra/db/postgresql/lib/lib.factor | 72 ++++
extra/db/postgresql/postgresql-tests.factor | 54 +++
extra/db/postgresql/postgresql.factor | 87 +++++
extra/db/sqlite/authors.txt | 2 +
extra/db/sqlite/ffi/ffi.factor | 131 +++++++
extra/db/sqlite/lib/lib.factor | 103 ++++++
extra/db/sqlite/sqlite-tests.factor | 99 ++++++
extra/db/sqlite/sqlite.factor | 70 ++++
extra/db/sqlite/test.txt | 3 +
12 files changed, 1078 insertions(+)
create mode 100644 extra/db/db.factor
create mode 100644 extra/db/postgresql/authors.txt
create mode 100644 extra/db/postgresql/ffi/ffi.factor
create mode 100644 extra/db/postgresql/lib/lib.factor
create mode 100644 extra/db/postgresql/postgresql-tests.factor
create mode 100644 extra/db/postgresql/postgresql.factor
create mode 100644 extra/db/sqlite/authors.txt
create mode 100644 extra/db/sqlite/ffi/ffi.factor
create mode 100644 extra/db/sqlite/lib/lib.factor
create mode 100644 extra/db/sqlite/sqlite-tests.factor
create mode 100644 extra/db/sqlite/sqlite.factor
create mode 100644 extra/db/sqlite/test.txt
diff --git a/extra/db/db.factor b/extra/db/db.factor
new file mode 100644
index 0000000000..597ac1f0f3
--- /dev/null
+++ b/extra/db/db.factor
@@ -0,0 +1,96 @@
+! 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 ;
+IN: db
+
+TUPLE: db handle ;
+C: <db> db ( handle -- obj )
+
+! HOOK: db-create db ( str -- )
+! HOOK: db-drop db ( str -- )
+GENERIC: db-open ( db -- )
+GENERIC: db-close ( db -- )
+
+TUPLE: statement sql params handle bound? n max ;
+
+TUPLE: simple-statement ;
+TUPLE: bound-statement ;
+TUPLE: prepared-statement ;
+TUPLE: prepared-bound-statement ;
+
+HOOK: <simple-statement> db ( str -- statement )
+HOOK: <bound-statement> db ( str obj -- statement )
+HOOK: <prepared-statement> db ( str -- statement )
+HOOK: <prepared-bound-statement> db ( str obj -- statement )
+
+! TUPLE: result sql params handle n max ;
+
+GENERIC: #rows ( statement -- n )
+GENERIC: #columns ( statement -- n )
+GENERIC# row-column 1 ( statement n -- obj )
+GENERIC: advance-row ( statement -- ? )
+
+GENERIC: prepare-statement ( statement -- )
+GENERIC: reset-statement ( statement -- )
+GENERIC: bind-statement* ( obj statement -- )
+GENERIC: rebind-statement ( obj statement -- )
+
+: bind-statement ( obj statement -- )
+ 2dup dup statement-bound? [
+ rebind-statement
+ ] [
+ bind-statement*
+ ] if
+ tuck set-statement-params
+ t swap set-statement-bound? ;
+
+: sql-row ( statement -- seq )
+ dup #columns [ row-column ] with map ;
+
+: query-each ( statement quot -- )
+ over advance-row [
+ 2drop
+ ] [
+ [ call ] 2keep query-each
+ ] if ; inline
+
+: 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 ;
+
+: do-statement ( statement -- )
+ [ advance-row drop ] with-disposal ;
+
+: do-query ( query -- rows )
+ [ [ sql-row ] query-map ] with-disposal ;
+
+: do-simple-query ( sql -- rows )
+ <simple-statement> do-query ;
+
+: do-bound-query ( sql obj -- rows )
+ <bound-statement> do-query ;
+
+: do-simple-command ( sql -- )
+ <simple-statement> do-statement ;
+
+: do-bound-command ( sql obj -- )
+ <bound-statement> do-statement ;
+
+SYMBOL: in-transaction
+HOOK: begin-transaction db ( -- )
+HOOK: commit-transaction db ( -- )
+HOOK: rollback-transaction db ( -- )
+
+: in-transaction? ( -- ? ) in-transaction get ;
+
+: with-transaction ( quot -- )
+ t in-transaction [
+ begin-transaction
+ [ ] [ rollback-transaction ] cleanup commit-transaction
+ ] with-variable ;
diff --git a/extra/db/postgresql/authors.txt b/extra/db/postgresql/authors.txt
new file mode 100644
index 0000000000..7c1b2f2279
--- /dev/null
+++ b/extra/db/postgresql/authors.txt
@@ -0,0 +1 @@
+Doug Coleman
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
new file mode 100644
index 0000000000..6d3cdfc468
--- /dev/null
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -0,0 +1,360 @@
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+
+! adapted from libpq-fe.h version 7.4.7
+! tested on debian linux with postgresql 7.4.7
+! Updated to 8.1
+
+USING: alien alien.syntax combinators system ;
+IN: db.postgresql.ffi
+
+<<
+"postgresql" {
+ { [ win32? ] [ "libpq.dll" ] }
+ { [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] }
+ { [ unix? ] [ "libpq.so" ] }
+} cond "cdecl" add-library
+>>
+
+! ConnSatusType
+: CONNECTION_OK HEX: 0 ; inline
+: CONNECTION_BAD HEX: 1 ; inline
+: CONNECTION_STARTED HEX: 2 ; inline
+: CONNECTION_MADE HEX: 3 ; inline
+: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
+: CONNECTION_AUTH_OK HEX: 5 ; inline
+: CONNECTION_SETENV HEX: 6 ; inline
+: CONNECTION_SSL_STARTUP HEX: 7 ; inline
+: CONNECTION_NEEDED HEX: 8 ; inline
+
+! PostgresPollingStatusType
+: PGRES_POLLING_FAILED HEX: 0 ; inline
+: PGRES_POLLING_READING HEX: 1 ; inline
+: PGRES_POLLING_WRITING HEX: 2 ; inline
+: PGRES_POLLING_OK HEX: 3 ; inline
+: PGRES_POLLING_ACTIVE HEX: 4 ; inline
+
+! ExecStatusType;
+: PGRES_EMPTY_QUERY HEX: 0 ; inline
+: PGRES_COMMAND_OK HEX: 1 ; inline
+: PGRES_TUPLES_OK HEX: 2 ; inline
+: PGRES_COPY_OUT HEX: 3 ; inline
+: PGRES_COPY_IN HEX: 4 ; inline
+: PGRES_BAD_RESPONSE HEX: 5 ; inline
+: PGRES_NONFATAL_ERROR HEX: 6 ; inline
+: PGRES_FATAL_ERROR HEX: 7 ; inline
+
+! PGTransactionStatusType;
+: PQTRANS_IDLE HEX: 0 ; inline
+: PQTRANS_ACTIVE HEX: 1 ; inline
+: PQTRANS_INTRANS HEX: 2 ; inline
+: PQTRANS_INERROR HEX: 3 ; inline
+: PQTRANS_UNKNOWN HEX: 4 ; inline
+
+! PGVerbosity;
+: PQERRORS_TERSE HEX: 0 ; inline
+: PQERRORS_DEFAULT HEX: 1 ; inline
+: PQERRORS_VERBOSE HEX: 2 ; inline
+
+
+TYPEDEF: int size_t
+TYPEDEF: int ConnStatusType
+TYPEDEF: int ExecStatusType
+TYPEDEF: int PostgresPollingStatusType
+TYPEDEF: int PGTransactionStatusType
+TYPEDEF: int PGVerbosity
+
+TYPEDEF: void* PGconn*
+TYPEDEF: void* PGresult*
+TYPEDEF: void* PGcancel*
+TYPEDEF: uint Oid
+TYPEDEF: uint* Oid*
+TYPEDEF: char pqbool
+TYPEDEF: void* PQconninfoOption*
+TYPEDEF: void* PGnotify*
+TYPEDEF: void* PQArgBlock*
+TYPEDEF: void* PQprintOpt*
+TYPEDEF: void* FILE*
+TYPEDEF: void* SSL*
+
+LIBRARY: postgresql
+
+
+! Exported functions of libpq
+! === in fe-connect.c ===
+
+! make a new client connection to the backend
+! Asynchronous (non-blocking)
+FUNCTION: PGconn* PQconnectStart ( char* conninfo ) ;
+FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ;
+
+! Synchronous (blocking)
+FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ;
+FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport,
+ char* pgoptions, char* pgtty,
+ char* dbName,
+ char* login, char* pwd ) ;
+
+: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
+ f f PQsetdbLogin ;
+
+! close the current connection and free the PGconn data structure
+FUNCTION: void PQfinish ( PGconn* conn ) ;
+
+! get info about connection options known to PQconnectdb
+FUNCTION: PQconninfoOption* PQconndefaults ( ) ;
+
+! free the data structure returned by PQconndefaults()
+FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
+
+!
+! close the current connection and restablish a new one with the same
+! parameters
+!
+! Asynchronous (non-blocking)
+FUNCTION: int PQresetStart ( PGconn* conn ) ;
+FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
+
+! Synchronous (blocking)
+FUNCTION: void PQreset ( PGconn* conn ) ;
+
+! request a cancel structure
+FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
+
+! free a cancel structure
+FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
+
+! issue a cancel request
+FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
+
+! Accessor functions for PGconn objects
+FUNCTION: char* PQdb ( PGconn* conn ) ;
+FUNCTION: char* PQuser ( PGconn* conn ) ;
+FUNCTION: char* PQpass ( PGconn* conn ) ;
+FUNCTION: char* PQhost ( PGconn* conn ) ;
+FUNCTION: char* PQport ( PGconn* conn ) ;
+FUNCTION: char* PQtty ( PGconn* conn ) ;
+FUNCTION: char* PQoptions ( PGconn* conn ) ;
+FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ;
+FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ;
+FUNCTION: char* PQparameterStatus ( PGconn* conn,
+ char* paramName ) ;
+FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
+! FUNCTION: int PQServerVersion ( PGconn* conn ) ;
+FUNCTION: char* PQerrorMessage ( PGconn* conn ) ;
+FUNCTION: int PQsocket ( PGconn* conn ) ;
+FUNCTION: int PQbackendPID ( PGconn* conn ) ;
+FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
+FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
+
+! May not be compiled into libpq
+! Get the SSL structure associated with a connection
+FUNCTION: SSL* PQgetssl ( PGconn* conn ) ;
+
+! Tell libpq whether it needs to initialize OpenSSL
+FUNCTION: void PQinitSSL ( int do_init ) ;
+
+! Set verbosity for PQerrorMessage and PQresultErrorMessage
+FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
+ PGVerbosity verbosity ) ;
+
+! Enable/disable tracing
+FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
+FUNCTION: void PQuntrace ( PGconn* conn ) ;
+
+! BROKEN
+! Function types for notice-handling callbacks
+! typedef void (*PQnoticeReceiver) (void *arg, PGresult *res);
+! typedef void (*PQnoticeProcessor) (void *arg, char* message);
+! ALIAS: void* PQnoticeReceiver
+! ALIAS: void* PQnoticeProcessor
+
+! Override default notice handling routines
+! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
+ ! PQnoticeReceiver proc,
+ ! void* arg ) ;
+! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
+ ! PQnoticeProcessor proc,
+ ! void* arg ) ;
+! END BROKEN
+
+! === in fe-exec.c ===
+
+! Simple synchronous query
+FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ;
+FUNCTION: PGresult* PQexecParams ( PGconn* conn,
+ char* command,
+ int nParams,
+ Oid* paramTypes,
+ char** paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat ) ;
+FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName,
+ char* query, int nParams,
+ Oid* paramTypes ) ;
+FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
+ char* stmtName,
+ int nParams,
+ char** paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat ) ;
+
+! Interface for multiple-result or asynchronous queries
+FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ;
+FUNCTION: int PQsendQueryParams ( PGconn* conn,
+ char* command,
+ int nParams,
+ Oid* paramTypes,
+ char** paramValues,
+ int* paramLengths,
+ int* paramFormats,
+ int resultFormat ) ;
+FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName,
+ char* query, int nParams,
+ Oid* paramTypes ) ;
+FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
+ char* stmtName,
+ int nParams,
+ char** paramValues,
+ int *paramLengths,
+ int *paramFormats,
+ int resultFormat ) ;
+FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
+
+! Routines for managing an asynchronous query
+FUNCTION: int PQisBusy ( PGconn* conn ) ;
+FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
+
+! LISTEN/NOTIFY support
+FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ;
+
+! Routines for copy in/out
+FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
+FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
+FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
+
+! Deprecated routines for copy in/out
+FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
+FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
+FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
+FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
+FUNCTION: int PQendcopy ( PGconn* conn ) ;
+
+! Set blocking/nonblocking connection to the backend
+FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
+FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
+
+! Force the write buffer to be written (or at least try)
+FUNCTION: int PQflush ( PGconn* conn ) ;
+
+!
+! * "Fast path" interface --- not really recommended for application
+! * use
+!
+FUNCTION: PGresult* PQfn ( PGconn* conn,
+ int fnid,
+ int* result_buf,
+ int* result_len,
+ int result_is_int,
+ PQArgBlock* args,
+ int nargs ) ;
+
+! Accessor functions for PGresult objects
+FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
+FUNCTION: char* PQresStatus ( ExecStatusType status ) ;
+FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ;
+FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ;
+FUNCTION: int PQntuples ( PGresult* res ) ;
+FUNCTION: int PQnfields ( PGresult* res ) ;
+FUNCTION: int PQbinaryTuples ( PGresult* res ) ;
+FUNCTION: char* PQfname ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ;
+FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ;
+FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfformat ( PGresult* res, int field_num ) ;
+FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfsize ( PGresult* res, int field_num ) ;
+FUNCTION: int PQfmod ( PGresult* res, int field_num ) ;
+FUNCTION: char* PQcmdStatus ( PGresult* res ) ;
+FUNCTION: char* PQoidStatus ( PGresult* res ) ;
+FUNCTION: Oid PQoidValue ( PGresult* res ) ;
+FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
+FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
+FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
+
+! Delete a PGresult
+FUNCTION: void PQclear ( PGresult* res ) ;
+
+! For freeing other alloc'd results, such as PGnotify structs
+FUNCTION: void PQfreemem ( void* ptr ) ;
+
+! Exists for backward compatibility.
+: PQfreeNotify PQfreemem ;
+
+!
+! Make an empty PGresult with given status (some apps find this
+! useful). If conn is not NULL and status indicates an error, the
+! conn's errorMessage is copied.
+!
+FUNCTION: PGresult* PQmakeEmptyPGresult ( PGconn* conn, ExecStatusType status ) ;
+
+! Quoting strings before inclusion in queries.
+FUNCTION: size_t PQescapeStringConn ( PGconn* conn,
+ char* to, char* from, size_t length,
+ int* error ) ;
+FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn,
+ char* from, size_t length,
+ size_t* to_length ) ;
+FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
+ size_t* retbuflen ) ;
+! These forms are deprecated!
+FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
+FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
+ size_t* bytealen ) ;
+
+! === in fe-print.c ===
+
+FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ;
+
+! really old printing routines
+FUNCTION: void PQdisplayTuples ( PGresult* res,
+ FILE* fp,
+ int fillAlign,
+ char* fieldSep,
+ int printHeader,
+ int quiet ) ;
+
+FUNCTION: void PQprintTuples ( PGresult* res,
+ FILE* fout,
+ int printAttName,
+ int terseOutput,
+ int width ) ;
+
+! === in fe-lobj.c ===
+
+! Large-object access routines
+FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
+FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
+FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
+FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
+FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
+FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
+! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
+FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
+FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
+FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
+FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
+
+! === in fe-misc.c ===
+
+! Determine length of multibyte encoded char at *s
+FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
+
+! Determine display length of multibyte encoded char at *s
+FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
+
+! Get encoding id from environment variable PGCLIENTENCODING
+FUNCTION: int PQenv2encoding ( ) ;
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
new file mode 100644
index 0000000000..4b362f9931
--- /dev/null
+++ b/extra/db/postgresql/lib/lib.factor
@@ -0,0 +1,72 @@
+USING: arrays continuations db io kernel math namespaces
+quotations sequences db.postgresql.ffi ;
+IN: db.postgresql.lib
+
+SYMBOL: query-res
+
+: connect-postgres ( host port pgopts pgtty db user pass -- conn )
+ PQsetdbLogin
+ dup PQstatus zero? [ "couldn't connect to database" throw ] unless ;
+
+: postgresql-result-error-message ( res -- str/f )
+ dup zero? [
+ drop f
+ ] [
+ PQresultErrorMessage [ CHAR: \n = ] right-trim
+ ] if ;
+
+: postgres-result-error ( res -- )
+ postgresql-result-error-message [ throw ] when* ;
+
+: postgresql-error-message ( -- str )
+ db get db-handle PQerrorMessage [ CHAR: \n = ] right-trim ;
+
+: postgresql-error ( res -- res )
+ dup [ postgresql-error-message throw ] unless ;
+
+: postgresql-result-ok? ( n -- ? )
+ PQresultStatus
+ PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
+
+: do-postgresql-statement ( statement -- res )
+ db get db-handle swap statement-sql PQexec dup postgresql-result-ok? [
+ dup postgresql-result-error-message swap PQclear throw
+ ] unless ;
+
+! : do-command ( str -- )
+ ! 1quotation \ (do-command) add db get swap call ;
+
+! : prepare ( str quot word -- conn quot )
+ ! rot 1quotation swap append swap append db get swap ;
+
+! : do-query ( str quot -- )
+ ! [ (do-query) query-res set ] prepare catch
+ ! [ rethrow ] [ query-res get PQclear ] if* ;
+
+! : result>seq ( -- seq )
+ ! query-res get [ PQnfields ] keep PQntuples
+ ! [ swap [ query-res get -rot PQgetvalue ] with map ] with map ;
+!
+! : print-table ( seq -- )
+ ! [ [ write bl ] each "\n" write ] each ;
+
+
+
+! select * from animal where name = 'Simba'
+! select * from animal where name = $1
+
+! : (do-query) ( PGconn query -- PGresult* )
+ ! ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK
+ ! ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
+ ! PQexec dup postgresql-result-ok? [
+ ! dup postgresql-error-message swap PQclear throw
+ ! ] unless ;
+
+! : (do-command) ( PGconn query -- PGresult* )
+ ! [ (do-query) ] catch
+ ! [
+ ! swap
+ ! "non-fatal error: " print
+ ! "\tQuery: " write "'" write write "'" print
+ ! "\t" write print
+ ! ] when* drop ;
diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor
new file mode 100644
index 0000000000..438a80e2d8
--- /dev/null
+++ b/extra/db/postgresql/postgresql-tests.factor
@@ -0,0 +1,54 @@
+! 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 ;
+IN: temporary
+
+: test-connection ( host port pgopts pgtty db user pass -- bool )
+ [ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ;
+
+[ ] [ "localhost" "" "" "" "factor-test" "postgres" "" test-connection ] unit-test
+
+[ ] [ "localhost" "postgres" "" "factor-test" <postgresql-db> [ ] with-db ] unit-test
+
+! just a basic demo
+
+"localhost" "postgres" "" "factor-test" <postgresql-db> [
+ [ ] [ "drop table animal" do-command ] unit-test
+
+ [ ] [ "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command ] unit-test
+
+ [ ] [ "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)"
+ do-command ] unit-test
+
+ [ ] [ "select * from animal where name = 'Mufasa'" [ ] do-query ] unit-test
+ [ ] [ "select * from animal where name = 'Mufasa'" [
+ result>seq length 1 = [
+ "...there can only be one Mufasa..." throw
+ ] unless
+ ] do-query
+ ] unit-test
+
+ [ ] [ "insert into animal (species, name, age) values ('lion', 'Simba', 1)"
+ do-command ] unit-test
+
+ [ ] [
+ "select * from animal"
+ [
+ "Animal table:" print
+ result>seq print-table
+ ] do-query
+ ] unit-test
+
+ ! intentional errors
+ ! [ "select asdf from animal"
+ ! [ ] do-query ] catch [ "caught: " write print ] when*
+ ! "select asdf from animal" [ ] do-query
+ ! "aofijweafew" do-command
+] with-db
+
+
+"localhost" "postgres" "" "factor-test" <postgresql-db> [
+ [ ] [ "drop table animal" do-command ] unit-test
+] with-db
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
new file mode 100644
index 0000000000..cd2c34682e
--- /dev/null
+++ b/extra/db/postgresql/postgresql.factor
@@ -0,0 +1,87 @@
+! Copyright (C) 2007 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+! adapted from libpq-fe.h version 7.4.7
+! tested on debian linux with postgresql 7.4.7
+
+USING: arrays assocs alien alien.syntax continuations io
+kernel math namespaces prettyprint quotations
+sequences debugger db db.postgresql.lib db.postgresql.ffi ;
+IN: db.postgresql
+
+TUPLE: postgresql-db host port pgopts pgtty db user pass ;
+TUPLE: postgresql-statement ;
+: <postgresql-statement> ( statement -- postgresql-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 db-open ( db -- )
+ dup {
+ postgresql-db-host
+ postgresql-db-port
+ postgresql-db-pgopts
+ postgresql-db-pgtty
+ postgresql-db-db
+ postgresql-db-user
+ postgresql-db-pass
+ } get-slots connect-postgres <db> swap set-delegate ;
+
+M: postgresql-db dispose ( db -- )
+ db-handle PQfinish ;
+
+: with-postgresql ( host ust pass db quot -- )
+ >r <postgresql-db> r> with-disposal ;
+
+M: postgresql-statement #rows ( statement -- n )
+ statement-handle PQntuples ;
+
+M: postgresql-statement #columns ( statement -- n )
+ statement-handle PQnfields ;
+
+M: postgresql-statement row-column ( statement n -- obj )
+ >r dup statement-handle swap statement-n r> PQgetvalue ;
+
+: init-statement ( statement -- )
+ dup statement-max [
+ dup do-postgresql-statement over set-statement-handle
+ dup #rows over set-statement-max
+ -1 over set-statement-n
+ ] unless drop ;
+
+: increment-n ( statement -- n )
+ dup statement-n 1+ dup rot set-statement-n ;
+
+M: postgresql-statement advance-row ( statement -- ? )
+ dup init-statement
+ dup increment-n swap statement-max >= ;
+
+M: postgresql-statement dispose ( query -- )
+ dup statement-handle PQclear
+ 0 0 rot { set-statement-n set-statement-max } set-slots ;
+
+M: postgresql-statement prepare-statement ( statement -- )
+ [
+ >r db get db-handle "" r>
+ dup statement-sql swap statement-params
+ dup assoc-size swap PQprepare postgresql-error
+ ] keep set-statement-handle ;
+
+M: postgresql-db <simple-statement> ( sql -- statement )
+ { set-statement-sql } statement construct
+ <postgresql-statement> ;
+
+M: postgresql-db <bound-statement> ( sql array -- statement )
+ { set-statement-sql set-statement-params } statement construct
+ <postgresql-statement> ;
+
+M: postgresql-db <prepared-statement> ( sql -- statement )
+ ;
+
+M: postgresql-db <prepared-bound-statement> ( sql seq -- statement )
+ ;
diff --git a/extra/db/sqlite/authors.txt b/extra/db/sqlite/authors.txt
new file mode 100644
index 0000000000..26093b451b
--- /dev/null
+++ b/extra/db/sqlite/authors.txt
@@ -0,0 +1,2 @@
+Chris Double
+Doug Coleman
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
new file mode 100644
index 0000000000..77a86a8a2d
--- /dev/null
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -0,0 +1,131 @@
+! Copyright (C) 2005 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+!
+! An interface to the sqlite database. Tested against sqlite v3.1.3.
+
+! Not all functions have been wrapped yet. Only those directly involving
+! executing SQL calls and obtaining results.
+
+USING: alien compiler kernel math namespaces sequences strings alien.syntax
+ system combinators ;
+IN: db.sqlite.ffi
+
+<<
+ "sqlite" {
+ { [ winnt? ] [ "sqlite3.dll" ] }
+ { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
+ { [ unix? ] [ "libsqlite3.so" ] }
+ } cond "cdecl" add-library >>
+
+! Return values from sqlite functions
+: SQLITE_OK 0 ; inline ! Successful result
+: SQLITE_ERROR 1 ; inline ! SQL error or missing database
+: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
+: SQLITE_PERM 3 ; inline ! Access permission denied
+: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
+: SQLITE_BUSY 5 ; inline ! The database file is locked
+: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
+: SQLITE_NOMEM 7 ; inline ! A malloc() failed
+: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
+: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
+: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
+: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
+: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
+: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
+: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
+: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
+: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
+: SQLITE_SCHEMA 17 ; inline ! The database schema changed
+: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
+: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
+: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
+: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
+: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
+: SQLITE_AUTH 23 ; inline ! Authorization denied
+: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
+: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
+: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
+
+: sqlite-error-messages ( -- seq ) {
+ "Successful result"
+ "SQL error or missing database"
+ "An internal logic error in SQLite"
+ "Access permission denied"
+ "Callback routine requested an abort"
+ "The database file is locked"
+ "A table in the database is locked"
+ "A malloc() failed"
+ "Attempt to write a readonly database"
+ "Operation terminated by sqlite_interrupt()"
+ "Some kind of disk I/O error occurred"
+ "The database disk image is malformed"
+ "(Internal Only) Table or record not found"
+ "Insertion failed because database is full"
+ "Unable to open the database file"
+ "Database lock protocol error"
+ "(Internal Only) Database table is empty"
+ "The database schema changed"
+ "Too much data for one row of a table"
+ "Abort due to contraint violation"
+ "Data type mismatch"
+ "Library used incorrectly"
+ "Uses OS features not supported on host"
+ "Authorization denied"
+ "Auxiliary database format error"
+ "2nd parameter to sqlite3_bind out of range"
+ "File opened that is not a database file"
+} ;
+
+: SQLITE_ROW 100 ; inline ! sqlite_step() has another row ready
+: SQLITE_DONE 101 ; inline ! sqlite_step() has finished executing
+
+! Return values from the sqlite3_column_type function
+: SQLITE_INTEGER 1 ; inline
+: SQLITE_FLOAT 2 ; inline
+: SQLITE_TEXT 3 ; inline
+: SQLITE_BLOB 4 ; inline
+: SQLITE_NULL 5 ; inline
+
+! Values for the 'destructor' parameter of the 'bind' routines.
+: SQLITE_STATIC 0 ; inline
+: SQLITE_TRANSIENT -1 ; inline
+
+: SQLITE_OPEN_READONLY HEX: 00000001 ; inline
+: SQLITE_OPEN_READWRITE HEX: 00000002 ; inline
+: SQLITE_OPEN_CREATE HEX: 00000004 ; inline
+: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008 ; inline
+: SQLITE_OPEN_EXCLUSIVE HEX: 00000010 ; inline
+: SQLITE_OPEN_MAIN_DB HEX: 00000100 ; inline
+: SQLITE_OPEN_TEMP_DB HEX: 00000200 ; inline
+: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400 ; inline
+: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800 ; inline
+: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000 ; inline
+: SQLITE_OPEN_SUBJOURNAL HEX: 00002000 ; inline
+: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000 ; inline
+
+
+TYPEDEF: void sqlite3
+TYPEDEF: void sqlite3_stmt
+
+LIBRARY: sqlite
+FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
+FUNCTION: int sqlite3_open_v2 ( char* filename, void* ppDb, int flags, char* zVfs ) ;
+FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
+FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
+FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
+FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
+FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
+FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
+FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
+FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
+FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
+FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
+FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
new file mode 100644
index 0000000000..99cd9c1b9f
--- /dev/null
+++ b/extra/db/sqlite/lib/lib.factor
@@ -0,0 +1,103 @@
+USING: alien.c-types assocs kernel math math.parser sequences
+db.sqlite.ffi ;
+IN: db.sqlite.lib
+
+TUPLE: sqlite-error n message ;
+
+: sqlite-check-result ( result -- )
+ dup SQLITE_OK = [
+ drop
+ ] [
+ dup sqlite-error-messages nth
+ sqlite-error construct-boa throw
+ ] if ;
+
+: sqlite-open ( filename -- db )
+ "void*" <c-object>
+ [ sqlite3_open sqlite-check-result ] keep *void* ;
+
+: sqlite-close ( db -- )
+ sqlite3_close sqlite-check-result ;
+
+: sqlite-last-insert-rowid ( db -- rowid )
+ sqlite3_last_insert_rowid ;
+
+: sqlite-prepare ( db sql -- statement )
+ #! TODO: Support multiple statements in the SQL string.
+ dup length "void*" <c-object> "void*" <c-object>
+ [ sqlite3_prepare sqlite-check-result ] 2keep
+ drop *void* ;
+
+: sqlite-bind-text ( statement index text -- )
+ dup number? [ number>string ] when
+ dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ;
+
+: sqlite-bind-parameter-index ( statement name -- index )
+ sqlite3_bind_parameter_index ;
+
+: sqlite-bind-text-by-name ( statement name text -- )
+ >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
+
+: sqlite-bind-assoc ( statement assoc -- )
+ swap [
+ -rot sqlite-bind-text-by-name
+ ] curry assoc-each ;
+
+: sqlite-finalize ( statement -- )
+ sqlite3_finalize sqlite-check-result ;
+
+: sqlite-reset ( statement -- )
+ sqlite3_reset sqlite-check-result ;
+
+: sqlite-#columns ( query -- int )
+ sqlite3_column_count ;
+
+: sqlite-column ( statement index -- string )
+ sqlite3_column_text ;
+
+: sqlite-row ( statement -- seq )
+ dup sqlite-#columns [ sqlite-column ] with map ;
+
+! 2dup sqlite3_column_type .
+! SQLITE_INTEGER 1
+! SQLITE_FLOAT 2
+! SQLITE_TEXT 3
+! SQLITE_BLOB 4
+! SQLITE_NULL 5
+
+
+: step-complete? ( step-result -- bool )
+ dup SQLITE_ROW = [
+ drop f
+ ] [
+ dup SQLITE_DONE = [ drop t ] [ sqlite-check-result t ] if
+ ] if ;
+
+: sqlite-step ( prepared -- )
+ dup sqlite3_step step-complete? [
+ drop
+ ] [
+ sqlite-step
+ ] if ;
+
+: sqlite-next ( prepared -- )
+ sqlite3_step step-complete? ;
+
+: sqlite-each ( statement quot -- )
+ over sqlite3_step step-complete? [
+ 2drop
+ ] [
+ [ call ] 2keep sqlite-each
+ ] if ; inline
+
+DEFER: (sqlite-map)
+
+: (sqlite-map) ( statement quot seq -- )
+ pick sqlite3_step step-complete? [
+ 2nip
+ ] [
+ >r 2dup call r> swap add (sqlite-map)
+ ] if ;
+
+: sqlite-map ( statement quot -- seq )
+ { } (sqlite-map) ;
diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor
new file mode 100644
index 0000000000..79e967de24
--- /dev/null
+++ b/extra/db/sqlite/sqlite-tests.factor
@@ -0,0 +1,99 @@
+USING: io io.files io.launcher kernel namespaces
+prettyprint tools.test db.sqlite db db.sql sequences
+continuations ;
+IN: temporary
+
+! "sqlite3 -init test.txt test.db"
+
+: test.db "extra/db/sqlite/test.db" resource-path ;
+
+: (create-db) ( -- str )
+ [
+ "sqlite3 -init " %
+ "extra/db/sqlite/test.txt" resource-path %
+ " " %
+ test.db %
+ ] "" make ;
+
+: create-db ( -- ) (create-db) run-process drop ;
+
+[ ] [ test.db delete-file ] unit-test
+
+[ ] [ create-db ] unit-test
+
+[
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ }
+] [ test.db [ "select * from person" do-simple-query ] with-sqlite ] unit-test
+
+[
+ { { "John" "America" } }
+] [
+ test.db [
+ "select * from person where name = :name and country = :country"
+ { { ":name" "Jane" } { ":country" "New Zealand" } }
+ <bound-statement> dup [ sql-row ] query-map
+
+ { { "Jane" "New Zealand" } } = [ "test fails" throw ] unless
+ { { ":name" "John" } { ":country" "America" } } over bind-statement
+
+ dup [ sql-row ] query-map swap dispose
+ ] with-sqlite
+] unit-test
+
+[
+ {
+ { "1" "John" "America" }
+ { "2" "Jane" "New Zealand" }
+ }
+] [ test.db [ "select rowid, * from person" do-simple-query ] with-sqlite ] unit-test
+
+[
+] [
+ "extra/db/sqlite/test.db" resource-path [
+ "insert into person(name, country) values('Jimmy', 'Canada')"
+ do-simple-command
+ ] with-sqlite
+] unit-test
+
+[
+ {
+ { "1" "John" "America" }
+ { "2" "Jane" "New Zealand" }
+ { "3" "Jimmy" "Canada" }
+ }
+] [ test.db [ "select rowid, * from person" do-simple-query ] with-sqlite ] unit-test
+
+[
+ "extra/db/sqlite/test.db" resource-path [
+ [
+ "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command
+ "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command
+ "oops" throw
+ ] with-transaction
+ ] with-sqlite
+] unit-test-fails
+
+[ 3 ] [
+ "extra/db/sqlite/test.db" resource-path [
+ "select * from person" do-simple-query length
+ ] with-sqlite
+] unit-test
+
+[
+] [
+ "extra/db/sqlite/test.db" resource-path [
+ [
+ "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command
+ "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command
+ ] with-transaction
+ ] with-sqlite
+] unit-test
+
+[ 5 ] [
+ "extra/db/sqlite/test.db" resource-path [
+ "select * from person" do-simple-query length
+ ] with-sqlite
+] unit-test
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
new file mode 100644
index 0000000000..c5964ed599
--- /dev/null
+++ b/extra/db/sqlite/sqlite.factor
@@ -0,0 +1,70 @@
+! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien arrays assocs classes compiler db db.sql hashtables
+io.files kernel math math.parser namespaces prettyprint sequences
+strings sqlite.lib tuples alien.c-types continuations
+db.sqlite.lib db.sqlite.ffi ;
+IN: db.sqlite
+
+TUPLE: sqlite-db path ;
+C: <sqlite-db> sqlite-db
+
+M: sqlite-db db-open ( db -- )
+ dup sqlite-db-path sqlite-open <db>
+ swap set-delegate ;
+
+M: sqlite-db dispose ( obj -- )
+ dup db-handle sqlite-close
+ f over set-db-handle
+ f swap set-delegate ;
+
+: with-sqlite ( path quot -- )
+ >r <sqlite-db> r> with-db ; inline
+
+TUPLE: sqlite-statement ;
+C: <sqlite-statement> sqlite-statement
+
+M: sqlite-db <simple-statement> ( str -- obj )
+ <prepared-statement> ;
+
+M: sqlite-db <bound-statement> ( str -- obj )
+ <prepared-bound-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 ;
+
+M: sqlite-db <prepared-bound-statement> ( str assoc -- obj )
+ swap <prepared-statement> tuck bind-statement ;
+
+M: sqlite-statement dispose ( statement -- )
+ statement-handle sqlite-finalize ;
+
+M: sqlite-statement bind-statement* ( assoc statement -- )
+ statement-handle swap sqlite-bind-assoc ;
+
+M: sqlite-statement rebind-statement ( assoc statement -- )
+ dup reset-statement
+ statement-handle swap sqlite-bind-assoc ;
+
+M: sqlite-statement #columns ( statement -- n )
+ statement-handle sqlite-#columns ;
+
+M: sqlite-statement row-column ( statement n -- obj )
+ >r statement-handle r> sqlite-column ;
+
+M: sqlite-statement advance-row ( statement -- ? )
+ statement-handle sqlite-next ;
+
+M: sqlite-statement reset-statement ( statement -- )
+ statement-handle sqlite-reset ;
+
+M: sqlite-db begin-transaction ( -- )
+ "BEGIN" do-simple-command ;
+
+M: sqlite-db commit-transaction ( -- )
+ "COMMIT" do-simple-command ;
+
+M: sqlite-db rollback-transaction ( -- )
+ "ROLLBACK" do-simple-command ;
diff --git a/extra/db/sqlite/test.txt b/extra/db/sqlite/test.txt
new file mode 100644
index 0000000000..e4487d30f9
--- /dev/null
+++ b/extra/db/sqlite/test.txt
@@ -0,0 +1,3 @@
+create table person (name varchar(30), country varchar(30));
+insert into person values('John', 'America');
+insert into person values('Jane', 'New Zealand');
From 822e859f9430cd5bc63263fe9630e156ed88b884 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.(none)>
Date: Fri, 1 Feb 2008 17:44:15 -0600
Subject: [PATCH 07/52] remove old postgresql
---
extra/postgresql/authors.txt | 1 -
extra/postgresql/libpq/libpq.factor | 361 -----------------------
extra/postgresql/postgresql-tests.factor | 42 ---
extra/postgresql/postgresql.factor | 61 ----
4 files changed, 465 deletions(-)
delete mode 100644 extra/postgresql/authors.txt
delete mode 100644 extra/postgresql/libpq/libpq.factor
delete mode 100644 extra/postgresql/postgresql-tests.factor
delete mode 100644 extra/postgresql/postgresql.factor
diff --git a/extra/postgresql/authors.txt b/extra/postgresql/authors.txt
deleted file mode 100644
index 7c1b2f2279..0000000000
--- a/extra/postgresql/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Doug Coleman
diff --git a/extra/postgresql/libpq/libpq.factor b/extra/postgresql/libpq/libpq.factor
deleted file mode 100644
index 3b21fd8203..0000000000
--- a/extra/postgresql/libpq/libpq.factor
+++ /dev/null
@@ -1,361 +0,0 @@
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-
-! adapted from libpq-fe.h version 7.4.7
-! tested on debian linux with postgresql 7.4.7
-! Updated to 8.1
-
-USING: alien alien.syntax combinators system ;
-IN: postgresql.libpq
-
-<<
-"postgresql" {
- { [ win32? ] [ "libpq.dll" ] }
- { [ macosx? ] [ "/opt/local/lib/postgresql81/libpq.dylib" ] }
- { [ unix? ] [ "libpq.so" ] }
-} cond "cdecl" add-library
->>
-
-! ConnSatusType
-: CONNECTION_OK HEX: 0 ; inline
-: CONNECTION_BAD HEX: 1 ; inline
-: CONNECTION_STARTED HEX: 2 ; inline
-: CONNECTION_MADE HEX: 3 ; inline
-: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
-: CONNECTION_AUTH_OK HEX: 5 ; inline
-: CONNECTION_SETENV HEX: 6 ; inline
-: CONNECTION_SSL_STARTUP HEX: 7 ; inline
-: CONNECTION_NEEDED HEX: 8 ; inline
-
-! PostgresPollingStatusType
-: PGRES_POLLING_FAILED HEX: 0 ; inline
-: PGRES_POLLING_READING HEX: 1 ; inline
-: PGRES_POLLING_WRITING HEX: 2 ; inline
-: PGRES_POLLING_OK HEX: 3 ; inline
-: PGRES_POLLING_ACTIVE HEX: 4 ; inline
-
-! ExecStatusType;
-: PGRES_EMPTY_QUERY HEX: 0 ; inline
-: PGRES_COMMAND_OK HEX: 1 ; inline
-: PGRES_TUPLES_OK HEX: 2 ; inline
-: PGRES_COPY_OUT HEX: 3 ; inline
-: PGRES_COPY_IN HEX: 4 ; inline
-: PGRES_BAD_RESPONSE HEX: 5 ; inline
-: PGRES_NONFATAL_ERROR HEX: 6 ; inline
-: PGRES_FATAL_ERROR HEX: 7 ; inline
-
-! PGTransactionStatusType;
-: PQTRANS_IDLE HEX: 0 ; inline
-: PQTRANS_ACTIVE HEX: 1 ; inline
-: PQTRANS_INTRANS HEX: 2 ; inline
-: PQTRANS_INERROR HEX: 3 ; inline
-: PQTRANS_UNKNOWN HEX: 4 ; inline
-
-! PGVerbosity;
-: PQERRORS_TERSE HEX: 0 ; inline
-: PQERRORS_DEFAULT HEX: 1 ; inline
-: PQERRORS_VERBOSE HEX: 2 ; inline
-
-
-TYPEDEF: int size_t
-TYPEDEF: int ConnStatusType
-TYPEDEF: int ExecStatusType
-TYPEDEF: int PostgresPollingStatusType
-TYPEDEF: int PGTransactionStatusType
-TYPEDEF: int PGVerbosity
-
-TYPEDEF: void* PGconn*
-TYPEDEF: void* PGresult*
-TYPEDEF: void* PGcancel*
-TYPEDEF: uint Oid
-TYPEDEF: uint* Oid*
-TYPEDEF: char pqbool
-TYPEDEF: void* PQconninfoOption*
-TYPEDEF: void* PGnotify*
-TYPEDEF: void* PQArgBlock*
-TYPEDEF: void* PQprintOpt*
-TYPEDEF: void* FILE*
-TYPEDEF: void* SSL*
-
-LIBRARY: postgresql
-
-
-! Exported functions of libpq
-! === in fe-connect.c ===
-
-! make a new client connection to the backend
-! Asynchronous (non-blocking)
-FUNCTION: PGconn* PQconnectStart ( char* conninfo ) ;
-FUNCTION: PostgresPollingStatusType PQconnectPoll ( PGconn* conn ) ;
-
-! Synchronous (blocking)
-FUNCTION: PGconn* PQconnectdb ( char* conninfo ) ;
-FUNCTION: PGconn* PQsetdbLogin ( char* pghost, char* pgport,
- char* pgoptions, char* pgtty,
- char* dbName,
- char* login, char* pwd ) ;
-
-: PQsetdb ( M_PGHOST M_PGPORT M_PGOPT M_PGTTY M_DBNAME -- PGconn* )
- f f PQsetdbLogin ;
-
-! close the current connection and free the PGconn data structure
-FUNCTION: void PQfinish ( PGconn* conn ) ;
-
-! get info about connection options known to PQconnectdb
-FUNCTION: PQconninfoOption* PQconndefaults ( ) ;
-
-! free the data structure returned by PQconndefaults()
-FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
-
-!
-! close the current connection and restablish a new one with the same
-! parameters
-!
-! Asynchronous (non-blocking)
-FUNCTION: int PQresetStart ( PGconn* conn ) ;
-FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
-
-! Synchronous (blocking)
-FUNCTION: void PQreset ( PGconn* conn ) ;
-
-! request a cancel structure
-FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
-
-! free a cancel structure
-FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
-
-! issue a cancel request
-FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
-
-! Accessor functions for PGconn objects
-FUNCTION: char* PQdb ( PGconn* conn ) ;
-FUNCTION: char* PQuser ( PGconn* conn ) ;
-FUNCTION: char* PQpass ( PGconn* conn ) ;
-FUNCTION: char* PQhost ( PGconn* conn ) ;
-FUNCTION: char* PQport ( PGconn* conn ) ;
-FUNCTION: char* PQtty ( PGconn* conn ) ;
-FUNCTION: char* PQoptions ( PGconn* conn ) ;
-FUNCTION: ConnStatusType PQstatus ( PGconn* conn ) ;
-FUNCTION: PGTransactionStatusType PQtransactionStatus ( PGconn* conn ) ;
-FUNCTION: char* PQparameterStatus ( PGconn* conn,
- char* paramName ) ;
-FUNCTION: int PQprotocolVersion ( PGconn* conn ) ;
-FUNCTION: int PQServerVersion ( PGconn* conn ) ;
-FUNCTION: char* PQerrorMessage ( PGconn* conn ) ;
-FUNCTION: int PQsocket ( PGconn* conn ) ;
-FUNCTION: int PQbackendPID ( PGconn* conn ) ;
-FUNCTION: int PQclientEncoding ( PGconn* conn ) ;
-FUNCTION: int PQsetClientEncoding ( PGconn* conn, char* encoding ) ;
-
-! May not be compiled into libpq
-! Get the SSL structure associated with a connection
-FUNCTION: SSL* PQgetssl ( PGconn* conn ) ;
-
-! Tell libpq whether it needs to initialize OpenSSL
-FUNCTION: void PQinitSSL ( int do_init ) ;
-
-! Set verbosity for PQerrorMessage and PQresultErrorMessage
-FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
- PGVerbosity verbosity ) ;
-
-! Enable/disable tracing
-FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
-FUNCTION: void PQuntrace ( PGconn* conn ) ;
-
-! BROKEN
-! Function types for notice-handling callbacks
-! typedef void (*PQnoticeReceiver) (void *arg, PGresult *res);
-! typedef void (*PQnoticeProcessor) (void *arg, char* message);
-! ALIAS: void* PQnoticeReceiver
-! ALIAS: void* PQnoticeProcessor
-
-! Override default notice handling routines
-! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
- ! PQnoticeReceiver proc,
- ! void* arg ) ;
-! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
- ! PQnoticeProcessor proc,
- ! void* arg ) ;
-! END BROKEN
-
-! === in fe-exec.c ===
-
-! Simple synchronous query
-FUNCTION: PGresult* PQexec ( PGconn* conn, char* query ) ;
-FUNCTION: PGresult* PQexecParams ( PGconn* conn,
- char* command,
- int nParams,
- Oid* paramTypes,
- char** paramValues,
- int* paramLengths,
- int* paramFormats,
- int resultFormat ) ;
-FUNCTION: PGresult* PQprepare ( PGconn* conn, char* stmtName,
- char* query, int nParams,
- Oid* paramTypes ) ;
-FUNCTION: PGresult* PQexecPrepared ( PGconn* conn,
- char* stmtName,
- int nParams,
- char** paramValues,
- int* paramLengths,
- int* paramFormats,
- int resultFormat ) ;
-
-! Interface for multiple-result or asynchronous queries
-FUNCTION: int PQsendQuery ( PGconn* conn, char* query ) ;
-FUNCTION: int PQsendQueryParams ( PGconn* conn,
- char* command,
- int nParams,
- Oid* paramTypes,
- char** paramValues,
- int* paramLengths,
- int* paramFormats,
- int resultFormat ) ;
-FUNCTION: PGresult* PQsendPrepare ( PGconn* conn, char* stmtName,
- char* query, int nParams,
- Oid* paramTypes ) ;
-FUNCTION: int PQsendQueryPrepared ( PGconn* conn,
- char* stmtName,
- int nParams,
- char** paramValues,
- int *paramLengths,
- int *paramFormats,
- int resultFormat ) ;
-FUNCTION: PGresult* PQgetResult ( PGconn* conn ) ;
-
-! Routines for managing an asynchronous query
-FUNCTION: int PQisBusy ( PGconn* conn ) ;
-FUNCTION: int PQconsumeInput ( PGconn* conn ) ;
-
-! LISTEN/NOTIFY support
-FUNCTION: PGnotify* PQnotifies ( PGconn* conn ) ;
-
-! Routines for copy in/out
-FUNCTION: int PQputCopyData ( PGconn* conn, char* buffer, int nbytes ) ;
-FUNCTION: int PQputCopyEnd ( PGconn* conn, char* errormsg ) ;
-FUNCTION: int PQgetCopyData ( PGconn* conn, char** buffer, int async ) ;
-
-! Deprecated routines for copy in/out
-FUNCTION: int PQgetline ( PGconn* conn, char* string, int length ) ;
-FUNCTION: int PQputline ( PGconn* conn, char* string ) ;
-FUNCTION: int PQgetlineAsync ( PGconn* conn, char* buffer, int bufsize ) ;
-FUNCTION: int PQputnbytes ( PGconn* conn, char* buffer, int nbytes ) ;
-FUNCTION: int PQendcopy ( PGconn* conn ) ;
-
-! Set blocking/nonblocking connection to the backend
-FUNCTION: int PQsetnonblocking ( PGconn* conn, int arg ) ;
-FUNCTION: int PQisnonblocking ( PGconn* conn ) ;
-
-! Force the write buffer to be written (or at least try)
-FUNCTION: int PQflush ( PGconn* conn ) ;
-
-!
-! * "Fast path" interface --- not really recommended for application
-! * use
-!
-FUNCTION: PGresult* PQfn ( PGconn* conn,
- int fnid,
- int* result_buf,
- int* result_len,
- int result_is_int,
- PQArgBlock* args,
- int nargs ) ;
-
-! Accessor functions for PGresult objects
-FUNCTION: ExecStatusType PQresultStatus ( PGresult* res ) ;
-FUNCTION: char* PQresStatus ( ExecStatusType status ) ;
-FUNCTION: char* PQresultErrorMessage ( PGresult* res ) ;
-FUNCTION: char* PQresultErrorField ( PGresult* res, int fieldcode ) ;
-FUNCTION: int PQntuples ( PGresult* res ) ;
-FUNCTION: int PQnfields ( PGresult* res ) ;
-FUNCTION: int PQbinaryTuples ( PGresult* res ) ;
-FUNCTION: char* PQfname ( PGresult* res, int field_num ) ;
-FUNCTION: int PQfnumber ( PGresult* res, char* field_name ) ;
-FUNCTION: Oid PQftable ( PGresult* res, int field_num ) ;
-FUNCTION: int PQftablecol ( PGresult* res, int field_num ) ;
-FUNCTION: int PQfformat ( PGresult* res, int field_num ) ;
-FUNCTION: Oid PQftype ( PGresult* res, int field_num ) ;
-FUNCTION: int PQfsize ( PGresult* res, int field_num ) ;
-FUNCTION: int PQfmod ( PGresult* res, int field_num ) ;
-FUNCTION: char* PQcmdStatus ( PGresult* res ) ;
-FUNCTION: char* PQoidStatus ( PGresult* res ) ;
-FUNCTION: Oid PQoidValue ( PGresult* res ) ;
-FUNCTION: char* PQcmdTuples ( PGresult* res ) ;
-FUNCTION: char* PQgetvalue ( PGresult* res, int tup_num, int field_num ) ;
-FUNCTION: int PQgetlength ( PGresult* res, int tup_num, int field_num ) ;
-FUNCTION: int PQgetisnull ( PGresult* res, int tup_num, int field_num ) ;
-
-! Delete a PGresult
-FUNCTION: void PQclear ( PGresult* res ) ;
-
-! For freeing other alloc'd results, such as PGnotify structs
-FUNCTION: void PQfreemem ( void* ptr ) ;
-
-! Exists for backward compatibility.
-: PQfreeNotify PQfreemem ;
-
-!
-! Make an empty PGresult with given status (some apps find this
-! useful). If conn is not NULL and status indicates an error, the
-! conn's errorMessage is copied.
-!
-FUNCTION: PGresult* PQmakeEmptyPGresult ( PGconn* conn, ExecStatusType status ) ;
-
-! Quoting strings before inclusion in queries.
-FUNCTION: size_t PQescapeStringConn ( PGconn* conn,
- char* to, char* from, size_t length,
- int* error ) ;
-FUNCTION: uchar* PQescapeByteaConn ( PGconn* conn,
- char* from, size_t length,
- size_t* to_length ) ;
-FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
- size_t* retbuflen ) ;
-! These forms are deprecated!
-FUNCTION: size_t PQescapeString ( void* to, char* from, size_t length ) ;
-FUNCTION: uchar* PQescapeBytea ( uchar* bintext, size_t binlen,
- size_t* bytealen ) ;
-
-! === in fe-print.c ===
-
-FUNCTION: void PQprint ( FILE* fout, PGresult* res, PQprintOpt* ps ) ;
-
-! really old printing routines
-FUNCTION: void PQdisplayTuples ( PGresult* res,
- FILE* fp,
- int fillAlign,
- char* fieldSep,
- int printHeader,
- int quiet ) ;
-
-FUNCTION: void PQprintTuples ( PGresult* res,
- FILE* fout,
- int printAttName,
- int terseOutput,
- int width ) ;
-
-! === in fe-lobj.c ===
-
-! Large-object access routines
-FUNCTION: int lo_open ( PGconn* conn, Oid lobjId, int mode ) ;
-FUNCTION: int lo_close ( PGconn* conn, int fd ) ;
-FUNCTION: int lo_read ( PGconn* conn, int fd, char* buf, size_t len ) ;
-FUNCTION: int lo_write ( PGconn* conn, int fd, char* buf, size_t len ) ;
-FUNCTION: int lo_lseek ( PGconn* conn, int fd, int offset, int whence ) ;
-FUNCTION: Oid lo_creat ( PGconn* conn, int mode ) ;
-! FUNCTION: Oid lo_creat ( PGconn* conn, Oid lobjId ) ;
-FUNCTION: int lo_tell ( PGconn* conn, int fd ) ;
-FUNCTION: int lo_unlink ( PGconn* conn, Oid lobjId ) ;
-FUNCTION: Oid lo_import ( PGconn* conn, char* filename ) ;
-FUNCTION: int lo_export ( PGconn* conn, Oid lobjId, char* filename ) ;
-
-! === in fe-misc.c ===
-
-! Determine length of multibyte encoded char at *s
-FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
-
-! Determine display length of multibyte encoded char at *s
-FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
-
-! Get encoding id from environment variable PGCLIENTENCODING
-FUNCTION: int PQenv2encoding ( ) ;
-
diff --git a/extra/postgresql/postgresql-tests.factor b/extra/postgresql/postgresql-tests.factor
deleted file mode 100644
index c725882b67..0000000000
--- a/extra/postgresql/postgresql-tests.factor
+++ /dev/null
@@ -1,42 +0,0 @@
-! You will need to run 'createdb factor-test' to create the database.
-! Set username and password in the 'connect' word.
-
-IN: postgresql-test
-USING: kernel postgresql alien continuations io prettyprint
-sequences namespaces ;
-
-
-: test-connection ( host port pgopts pgtty db user pass -- bool )
- [ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ;
-
-! just a basic demo
-
-"localhost" "" "" "" "test" "postgres" "" [
- "drop table animal" do-command
-
- "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command
- "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)"
- do-command
-
- "select * from animal where name = 'Mufasa'" [ ] do-query
- "select * from animal where name = 'Mufasa'"
- [
- result>seq length 1 = [ "...there can only be one Mufasa..." throw ] unless
- ] do-query
-
- "insert into animal (species, name, age) values ('lion', 'Simba', 1)"
- do-command
-
- "select * from animal"
- [
- "Animal table:" print
- result>seq print-table
- ] do-query
-
- ! intentional errors
- ! [ "select asdf from animal"
- ! [ ] do-query ] catch [ "caught: " write print ] when*
- ! "select asdf from animal" [ ] do-query
- ! "aofijweafew" do-command
-] with-postgres
-
diff --git a/extra/postgresql/postgresql.factor b/extra/postgresql/postgresql.factor
deleted file mode 100644
index 9d85b6a77e..0000000000
--- a/extra/postgresql/postgresql.factor
+++ /dev/null
@@ -1,61 +0,0 @@
-! Copyright (C) 2007 Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-
-! adapted from libpq-fe.h version 7.4.7
-! tested on debian linux with postgresql 7.4.7
-
-USING: arrays alien alien.syntax continuations io
-kernel math namespaces postgresql.libpq prettyprint
-quotations sequences debugger ;
-IN: postgresql
-
-SYMBOL: db
-SYMBOL: query-res
-
-: connect-postgres ( host port pgopts pgtty db user pass -- conn )
- PQsetdbLogin
- dup PQstatus zero? [ "couldn't connect to database" throw ] unless ;
-
-: with-postgres ( host port pgopts pgtty db user pass quot -- )
- [ >r connect-postgres db set r>
- [ db get PQfinish ] [ ] cleanup ] with-scope ; inline
-
-: postgres-error ( ret -- ret )
- dup zero? [ PQresultErrorMessage throw ] when ;
-
-: (do-query) ( PGconn query -- PGresult* )
- ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK
- ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
- PQexec
- dup PQresultStatus PGRES_COMMAND_OK =
- over PQresultStatus PGRES_TUPLES_OK =
- or [
- [ PQresultErrorMessage CHAR: \n swap remove ] keep PQclear throw
- ] unless ;
-
-: (do-command) ( PGconn query -- PGresult* )
- [ (do-query) ] catch
- [
- swap
- "non-fatal error: " print
- "\tQuery: " write "'" write write "'" print
- "\t" write print
- ] when* drop ;
-
-: do-command ( str -- )
- 1quotation \ (do-command) add db get swap call ;
-
-: prepare ( str quot word -- conn quot )
- rot 1quotation swap append swap append db get swap ;
-
-: do-query ( str quot -- )
- [ (do-query) query-res set ] prepare catch
- [ rethrow ] [ query-res get PQclear ] if* ;
-
-: result>seq ( -- seq )
- query-res get [ PQnfields ] keep PQntuples
- [ swap [ query-res get -rot PQgetvalue ] with map ] with map ;
-
-: print-table ( seq -- )
- [ [ write bl ] each "\n" write ] each ;
-
From 161c3ec1560dbcc32f3006bac38b49a8a62a0338 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.(none)>
Date: Fri, 1 Feb 2008 17:45:34 -0600
Subject: [PATCH 08/52] remove sqlite and tupledb for now
---
extra/sqlite/authors.txt | 1 -
extra/sqlite/lib/authors.txt | 1 -
extra/sqlite/lib/lib.factor | 120 ---------
extra/sqlite/sqlite-docs.factor | 87 -------
extra/sqlite/sqlite-tests.factor | 69 -----
extra/sqlite/sqlite.factor | 127 ---------
extra/sqlite/test.txt | 3 -
extra/sqlite/tuple-db/authors.txt | 1 -
extra/sqlite/tuple-db/tuple-db-docs.factor | 131 ----------
extra/sqlite/tuple-db/tuple-db-tests.factor | 39 ---
extra/sqlite/tuple-db/tuple-db.factor | 270 --------------------
11 files changed, 849 deletions(-)
delete mode 100755 extra/sqlite/authors.txt
delete mode 100755 extra/sqlite/lib/authors.txt
delete mode 100644 extra/sqlite/lib/lib.factor
delete mode 100644 extra/sqlite/sqlite-docs.factor
delete mode 100644 extra/sqlite/sqlite-tests.factor
delete mode 100644 extra/sqlite/sqlite.factor
delete mode 100644 extra/sqlite/test.txt
delete mode 100755 extra/sqlite/tuple-db/authors.txt
delete mode 100644 extra/sqlite/tuple-db/tuple-db-docs.factor
delete mode 100644 extra/sqlite/tuple-db/tuple-db-tests.factor
delete mode 100644 extra/sqlite/tuple-db/tuple-db.factor
diff --git a/extra/sqlite/authors.txt b/extra/sqlite/authors.txt
deleted file mode 100755
index 44b06f94bc..0000000000
--- a/extra/sqlite/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Chris Double
diff --git a/extra/sqlite/lib/authors.txt b/extra/sqlite/lib/authors.txt
deleted file mode 100755
index 44b06f94bc..0000000000
--- a/extra/sqlite/lib/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Chris Double
diff --git a/extra/sqlite/lib/lib.factor b/extra/sqlite/lib/lib.factor
deleted file mode 100644
index 438f22a80f..0000000000
--- a/extra/sqlite/lib/lib.factor
+++ /dev/null
@@ -1,120 +0,0 @@
-! Copyright (C) 2005 Chris Double, Doug Coleman.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! An interface to the sqlite database. Tested against sqlite v3.1.3.
-! Remeber to pass the following to factor:
-! -libraries:sqlite=libsqlite3.so
-!
-! Not all functions have been wrapped yet. Only those directly involving
-! executing SQL calls and obtaining results.
-!
-IN: sqlite.lib
-USING: alien compiler kernel math namespaces sequences strings alien.syntax
- system combinators ;
-
-<<
-"sqlite" {
- { [ win32? ] [ "sqlite3.dll" ] }
- { [ macosx? ] [ "/usr/lib/libsqlite3.dylib" ] }
- { [ unix? ] [ "libsqlite3.so" ] }
-} cond "cdecl" add-library
->>
-
-! Return values from sqlite functions
-: SQLITE_OK 0 ; inline ! Successful result
-: SQLITE_ERROR 1 ; inline ! SQL error or missing database
-: SQLITE_INTERNAL 2 ; inline ! An internal logic error in SQLite
-: SQLITE_PERM 3 ; inline ! Access permission denied
-: SQLITE_ABORT 4 ; inline ! Callback routine requested an abort
-: SQLITE_BUSY 5 ; inline ! The database file is locked
-: SQLITE_LOCKED 6 ; inline ! A table in the database is locked
-: SQLITE_NOMEM 7 ; inline ! A malloc() failed
-: SQLITE_READONLY 8 ; inline ! Attempt to write a readonly database
-: SQLITE_INTERRUPT 9 ; inline ! Operation terminated by sqlite_interrupt()
-: SQLITE_IOERR 10 ; inline ! Some kind of disk I/O error occurred
-: SQLITE_CORRUPT 11 ; inline ! The database disk image is malformed
-: SQLITE_NOTFOUND 12 ; inline ! (Internal Only) Table or record not found
-: SQLITE_FULL 13 ; inline ! Insertion failed because database is full
-: SQLITE_CANTOPEN 14 ; inline ! Unable to open the database file
-: SQLITE_PROTOCOL 15 ; inline ! Database lock protocol error
-: SQLITE_EMPTY 16 ; inline ! (Internal Only) Database table is empty
-: SQLITE_SCHEMA 17 ; inline ! The database schema changed
-: SQLITE_TOOBIG 18 ; inline ! Too much data for one row of a table
-: SQLITE_CONSTRAINT 19 ; inline ! Abort due to contraint violation
-: SQLITE_MISMATCH 20 ; inline ! Data type mismatch
-: SQLITE_MISUSE 21 ; inline ! Library used incorrectly
-: SQLITE_NOLFS 22 ; inline ! Uses OS features not supported on host
-: SQLITE_AUTH 23 ; inline ! Authorization denied
-: SQLITE_FORMAT 24 ; inline ! Auxiliary database format error
-: SQLITE_RANGE 25 ; inline ! 2nd parameter to sqlite3_bind out of range
-: SQLITE_NOTADB 26 ; inline ! File opened that is not a database file
-
-: sqlite-error-messages ( -- seq ) {
- "Successful result"
- "SQL error or missing database"
- "An internal logic error in SQLite"
- "Access permission denied"
- "Callback routine requested an abort"
- "The database file is locked"
- "A table in the database is locked"
- "A malloc() failed"
- "Attempt to write a readonly database"
- "Operation terminated by sqlite_interrupt()"
- "Some kind of disk I/O error occurred"
- "The database disk image is malformed"
- "(Internal Only) Table or record not found"
- "Insertion failed because database is full"
- "Unable to open the database file"
- "Database lock protocol error"
- "(Internal Only) Database table is empty"
- "The database schema changed"
- "Too much data for one row of a table"
- "Abort due to contraint violation"
- "Data type mismatch"
- "Library used incorrectly"
- "Uses OS features not supported on host"
- "Authorization denied"
- "Auxiliary database format error"
- "2nd parameter to sqlite3_bind out of range"
- "File opened that is not a database file"
-} ;
-
-: SQLITE_ROW 100 ; inline ! sqlite_step() has another row ready
-: SQLITE_DONE 101 ; inline ! sqlite_step() has finished executing
-
-! Return values from the sqlite3_column_type function
-: SQLITE_INTEGER 1 ; inline
-: SQLITE_FLOAT 2 ; inline
-: SQLITE_TEXT 3 ; inline
-: SQLITE_BLOB 4 ; inline
-: SQLITE_NULL 5 ; inline
-
-! Values for the 'destructor' parameter of the 'bind' routines.
-: SQLITE_STATIC 0 ; inline
-: SQLITE_TRANSIENT -1 ; inline
-
-TYPEDEF: void sqlite3
-TYPEDEF: void sqlite3_stmt
-
-LIBRARY: sqlite
-FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
-FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
-FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
-FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
-FUNCTION: int sqlite3_reset ( sqlite3_stmt* pStmt ) ;
-FUNCTION: int sqlite3_step ( sqlite3_stmt* pStmt ) ;
-FUNCTION: int sqlite3_last_insert_rowid ( sqlite3* pStmt ) ;
-FUNCTION: int sqlite3_bind_blob ( sqlite3_stmt* pStmt, int index, void* ptr, int len, int destructor ) ;
-FUNCTION: int sqlite3_bind_int ( sqlite3_stmt* pStmt, int index, int n ) ;
-FUNCTION: int sqlite3_bind_null ( sqlite3_stmt* pStmt, int n ) ;
-FUNCTION: int sqlite3_bind_text ( sqlite3_stmt* pStmt, int index, char* text, int len, int destructor ) ;
-FUNCTION: int sqlite3_bind_parameter_index ( sqlite3_stmt* pStmt, char* name ) ;
-FUNCTION: int sqlite3_column_count ( sqlite3_stmt* pStmt ) ;
-FUNCTION: void* sqlite3_column_blob ( sqlite3_stmt* pStmt, int col ) ;
-FUNCTION: int sqlite3_column_bytes ( sqlite3_stmt* pStmt, int col ) ;
-FUNCTION: char* sqlite3_column_decltype ( sqlite3_stmt* pStmt, int col ) ;
-FUNCTION: int sqlite3_column_int ( sqlite3_stmt* pStmt, int col ) ;
-FUNCTION: int sqlite3_column_name ( sqlite3_stmt* pStmt, int col ) ;
-FUNCTION: char* sqlite3_column_text ( sqlite3_stmt* pStmt, int col ) ;
-FUNCTION: int sqlite3_column_type ( sqlite3_stmt* pStmt, int col ) ;
-
diff --git a/extra/sqlite/sqlite-docs.factor b/extra/sqlite/sqlite-docs.factor
deleted file mode 100644
index d58b553f11..0000000000
--- a/extra/sqlite/sqlite-docs.factor
+++ /dev/null
@@ -1,87 +0,0 @@
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help help.syntax help.markup ;
-IN: sqlite
-
-HELP: sqlite-open
-{ $values { "filename" "path to sqlite database" }
- { "db" "the database object" }
-}
-{ $description "Opens the sqlite3 database." }
-{ $see-also sqlite-close sqlite-last-insert-rowid } ;
-
-HELP: sqlite-close
-{ $values { "db" "the database object" }
-}
-{ $description "Closes the sqlite3 database." }
-{ $see-also sqlite-open sqlite-last-insert-rowid } ;
-
-HELP: sqlite-last-insert-rowid
-{ $values { "db" "the database object" }
- { "rowid" "the row number of the last insert" }
-}
-{ $description "Returns the number of the row of the last statement inserted into the database." }
-{ $see-also sqlite-open sqlite-close } ;
-
-HELP: sqlite-prepare
-{ $values { "db" "the database object" }
- { "sql" "the SQL statement as a string" }
- { "statement" "the prepared SQL statement" }
-}
-{ $description "Internally compiles the SQL statement ready to be run by sqlite. The statement is executed and the results iterated over using " { $link sqlite-each } " and " { $link sqlite-map } ". The SQL statement can use named parameters which are later bound to values using " { $link sqlite-bind-text } " and " { $link sqlite-bind-text-by-name } "." }
-{ $see-also sqlite-open sqlite-close } ;
-
-HELP: sqlite-bind-text
-{ $values { "statement" "a prepared SQL statement" }
- { "index" "the index of the bound parameter in the SQL statement" }
- { "text" "the string value to bind to that column" }
-
-}
-{ $description "Binds the text to a parameter in the SQL statement. The parameter to be bound is identified by the index given and the indexes start from one." }
-{ $examples { $code "\"people.db\" sqlite-open\n\"select * from people where name=?\" sqlite-prepare\n1 \"chris\" sqlite-bind-text" } }
-{ $see-also sqlite-bind-text-by-name } ;
-
-HELP: sqlite-bind-text-by-name
-{ $values { "statement" "a prepared SQL statement" }
- { "name" "the name of the bound parameter in the SQL statement" }
- { "text" "the string value to bind to that column" }
-
-}
-{ $description "Binds the text to a parameter in the SQL statement. The parameter to be bound is identified by the given name." }
-{ $examples { $code "\"people.db\" sqlite-open\n\"select * from people where name=:name\" sqlite-prepare\n\"name\" \"chris\" sqlite-bind-text" } }
-{ $see-also sqlite-bind-text } ;
-
-HELP: sqlite-finalize
-{ $values { "statement" "a prepared SQL statement" }
-}
-{ $description "Clean up all resources related to a statement. Once called the statement cannot be used again. All statements must be finalized before closing the database." }
-{ $see-also sqlite-close sqlite-prepare } ;
-
-HELP: sqlite-reset
-{ $values { "statement" "a prepared SQL statement" }
-}
-{ $description "Reset a statement so it can be called again, possibly with different bound parameters." }
-{ $see-also sqlite-bind-text sqlite-bind-text-by-name } ;
-
-HELP: column-count
-{ $values { "statement" "a prepared SQL statement" } { "int" "the number of columns" } }
-{ $description "Return the number of columns in each row of the result set of the given statement." }
-{ $see-also column-text sqlite-each sqlite-map } ;
-
-HELP: column-text
-{ $values { "statement" "a prepared SQL statement" } { "index" "column number indexed from zero" } { "string" "column value" }
-}
-{ $description "Return the value of the given column, indexed from zero, as a string." }
-{ $see-also column-count sqlite-each sqlite-map } ;
-
-HELP: sqlite-each
-{ $values { "statement" "a prepared SQL statement" } { "quot" "A quotation with stack effect ( statement -- )" }
-}
-{ $description "Executes the SQL statement and for each returned row calls the qutotation passing the statement on the stack. The quotation can use " { $link column-text } " to get result values for that row." }
-{ $see-also column-count column-text sqlite-map } ;
-
-HELP: sqlite-map
-{ $values { "statement" "a prepared SQL statement" } { "quot" "A quotation with stack effect ( statement -- value )" } { "seq" "a new sequence" }
-}
-{ $description "Executes the SQL statement and for each returned row calls the qutotation passing the statement on the stack. The quotation can use " { $link column-text } " to get result values for that row. The quotation should leave a value on the stack which gets collected and returned in the resulting sequence." }
-{ $see-also column-count column-text sqlite-each } ;
diff --git a/extra/sqlite/sqlite-tests.factor b/extra/sqlite/sqlite-tests.factor
deleted file mode 100644
index 5eecbec369..0000000000
--- a/extra/sqlite/sqlite-tests.factor
+++ /dev/null
@@ -1,69 +0,0 @@
-! Copyright (C) 2005 Chris Double.
-!
-! Redistribution and use in source and binary forms, with or without
-! modification, are permitted provided that the following conditions are met:
-!
-! 1. Redistributions of source code must retain the above copyright notice,
-! this list of conditions and the following disclaimer.
-!
-! 2. Redistributions in binary form must reproduce the above copyright notice,
-! this list of conditions and the following disclaimer in the documentation
-! and/or other materials provided with the distribution.
-!
-! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
-! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
-! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
-! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
-! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
-! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
-! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
-! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
-! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
-! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
-!
-! Test the sqlite interface
-!
-! Create a test database like follows:
-!
-! sqlite3 test.db < test.txt
-!
-! Then run this file.
-USE: sqlite
-USE: kernel
-USE: io
-USE: io.files
-USE: prettyprint
-
-: test.db "libs/sqlite/test.db" resource-path ;
-
-: show-people ( statement -- )
- dup 0 column-text write " from " write 1 column-text . ;
-
-: run-test ( -- )
- test.db sqlite-open
- dup "select * from test" sqlite-prepare
- dup [ show-people ] sqlite-each
- sqlite-finalize
- sqlite-close ;
-
-: find-person ( name -- )
- test.db sqlite-open ! name db
- dup "select * from test where name=?" sqlite-prepare ! name db stmt
- [ rot 1 swap sqlite-bind-text ] keep ! db stmt
- [ [ 1 column-text . ] sqlite-each ] keep
- sqlite-finalize
- sqlite-close ;
-
-: find-all ( -- )
- test.db sqlite-open ! db
- dup "select * from test" sqlite-prepare ! db stmt
- [ [ [ 0 column-text ] keep 1 column-text curry ] sqlite-map ] keep
- sqlite-finalize
- swap sqlite-close ;
-
-: run-test2 ( -- )
- test.db sqlite-open
- dup "select * from test" sqlite-prepare
- dup [ show-people ] ;
-
-run-test
diff --git a/extra/sqlite/sqlite.factor b/extra/sqlite/sqlite.factor
deleted file mode 100644
index d651ad916c..0000000000
--- a/extra/sqlite/sqlite.factor
+++ /dev/null
@@ -1,127 +0,0 @@
-! Copyright (C) 2005 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-!
-! An interface to the sqlite database. Tested against sqlite v3.0.8.
-!
-! Not all functions have been wrapped yet. Only those directly involving
-! executing SQL calls and obtaining results.
-!
-IN: sqlite
-USING: alien compiler kernel namespaces sequences strings sqlite.lib
- alien.c-types continuations ;
-
-TUPLE: sqlite-error n message ;
-SYMBOL: db
-
-! High level sqlite routines
-: sqlite-check-result ( result -- )
- #! Check the result from a sqlite call is ok. If it is
- #! return, otherwise throw an error.
- dup SQLITE_OK = [
- drop
- ] [
- dup sqlite-error-messages nth
- \ sqlite-error construct-boa throw
- ] if ;
-
-: sqlite-open ( filename -- db )
- #! Open the database referenced by the filename and return
- #! a handle to that database. An error is thrown if the database
- #! failed to open.
- "void*" <c-object> [ sqlite3_open sqlite-check-result ] keep *void* ;
-
-: sqlite-close ( db -- )
- #! Close the given database
- sqlite3_close sqlite-check-result ;
-
-: sqlite-last-insert-rowid ( db -- rowid )
- #! Return the rowid of the last insert
- sqlite3_last_insert_rowid ;
-
-: sqlite-prepare ( db sql -- statement )
- #! Prepare a SQL statement. Returns the statement which
- #! can have values bound to parameters or simply executed.
- #! TODO: Support multiple statements in the SQL string.
- dup length "void*" <c-object> "void*" <c-object>
- [ sqlite3_prepare sqlite-check-result ] 2keep
- drop *void* ;
-
-: sqlite-bind-text ( statement index text -- )
- #! Bind the text to the parameterized value in the statement.
- dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ;
-
-: sqlite-bind-parameter-index ( statement name -- index )
- sqlite3_bind_parameter_index ;
-
-: sqlite-bind-text-by-name ( statement name text -- )
- >r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
-
-: sqlite-finalize ( statement -- )
- #! Clean up all resources related to a statement. Once called
- #! the statement cannot be used. All statements must be finalized
- #! before closing the database.
- sqlite3_finalize sqlite-check-result ;
-
-: sqlite-reset ( statement -- )
- #! Reset a statement so it can be called again, possibly with
- #! different parameters.
- sqlite3_reset sqlite-check-result ;
-
-: column-count ( statement -- int )
- #! Given a prepared statement, return the number of
- #! columns in each row of the result set of that statement.
- sqlite3_column_count ;
-
-: column-text ( statement index -- string )
- #! Return the value of the given column, indexed
- #! from zero, as a string.
- sqlite3_column_text ;
-
-: step-complete? ( step-result -- bool )
- #! Return true if the result of a sqlite3_step is
- #! such that the iteration has completed (ie. it is
- #! SQLITE_DONE). Throw an error if an error occurs.
- dup SQLITE_ROW = [
- drop f
- ] [
- dup SQLITE_DONE = [
- drop t
- ] [
- sqlite-check-result t
- ] if
- ] if ;
-
-: sqlite-each ( statement quot -- )
- #! Execute the SQL statement, and call the quotation for
- #! each row returned from executing the statement with the
- #! statement on the top of the stack.
- over sqlite3_step step-complete? [
- 2drop
- ] [
- [ call ] 2keep sqlite-each
- ] if ; inline
-
-! For comparison, here is the linrec implementation of sqlite-each
-! [ drop sqlite3_step step-complete? ]
-! [ 2drop ]
-! [ 2dup 2slip ]
-! [ ] linrec ;
-
-DEFER: (sqlite-map)
-
-: (sqlite-map) ( statement quot seq -- )
- pick sqlite3_step step-complete? [
- 2nip
- ] [
- >r 2dup call r> swap add (sqlite-map)
- ] if ;
-
-: sqlite-map ( statement quot -- seq )
- { } (sqlite-map) ;
-
-: with-sqlite ( path quot -- )
- [
- >r sqlite-open db set r>
- [ db get sqlite-close ] [ ] cleanup
- ] with-scope ;
-
diff --git a/extra/sqlite/test.txt b/extra/sqlite/test.txt
deleted file mode 100644
index 5c7ae2b52a..0000000000
--- a/extra/sqlite/test.txt
+++ /dev/null
@@ -1,3 +0,0 @@
-create table test (name varchar(30), address varchar(30));
-insert into test values('John', 'America');
-insert into test values('Jane', 'New Zealand');
diff --git a/extra/sqlite/tuple-db/authors.txt b/extra/sqlite/tuple-db/authors.txt
deleted file mode 100755
index 44b06f94bc..0000000000
--- a/extra/sqlite/tuple-db/authors.txt
+++ /dev/null
@@ -1 +0,0 @@
-Chris Double
diff --git a/extra/sqlite/tuple-db/tuple-db-docs.factor b/extra/sqlite/tuple-db/tuple-db-docs.factor
deleted file mode 100644
index 3c6df0eaa6..0000000000
--- a/extra/sqlite/tuple-db/tuple-db-docs.factor
+++ /dev/null
@@ -1,131 +0,0 @@
-! Copyright (C) 2006 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-USING: help sqlite help.syntax help.markup ;
-IN: sqlite.tuple-db
-
-ARTICLE: { "sqlite" "tuple-db-loading" } "Loading"
-"The quickest way to get up and running with this library is to use the vocabulary:"
-{ $code "USING: sqlite sqlite.tuple-db ;\n" }
-"Some simple tests can be run to check that everything is working ok:"
-{ $code "\"libs/sqlite\" test-module" } ;
-
-ARTICLE: { "sqlite" "tuple-db-usage" } "Basic Usage"
-"This library can be used for storing simple Factor tuples in a sqlite database. In its current form the tuples must not contain references to other tuples and should not have a delegate set."
-$nl
-"This document will use the following tuple for demonstration purposes:"
-{ $code "TUPLE: person name surname phone ;" }
-"The sqlite database to store tuples must be created, or an existing one opened. This is done using the " { $link sqlite-open } " word. If the database does not exist then it is created. The examples in this document store the database pointer in a variable called 'db':"
-{ $code "SYMBOL: db\n\"example.db\" sqlite-open db set-global" } ;
-
-ARTICLE: { "sqlite" "tuple-db-mappings" } "Tuple Mappings"
-"Each tuple has a 'mapping' tuple associated with it. The 'mapping' stores information about what table the tuple will be stored in, the datatypes of the tuple slots, etc. A mapping must be created before a tuple can be stored in a database. A default mapping is easily created using " { $link default-mapping } ". Given the tuple class, this will use reflection to get the slots of it, assume that all slots are of database type 'text', and store the tuple objects in a table with the same name as the tuple."
-$nl
-"The following shows how to create the default mapping for the 'person' tuple, and how to register that mapping so the 'tuple-db' system can know how to handle 'person' instances:"
-{ $code "person default-mapping set-mapping" } ;
-
-ARTICLE: { "sqlite" "tuple-db-create" } "Creating the table"
-"The table used to store tuple instances may need to be created. This can be done manually using the external sqlite program or via " { $link create-tuple-table } ":"
-{ $code "db get person create-tuple-table" }
-"The SQL used to create the table is produced internally by " { $link create-sql } ". This is a generic word dispatched on the mapping object, and could be specialised if needed. If you wish to see the SQL used to create the table, use the following code:"
-{ $code "person get-mapping create-sql .\n => \"create table person (name text,surname text,phone text);\"" } ;
-
-ARTICLE: { "sqlite" "tuple-db-insert" } "Inserting instances"
-"The " { $link insert-tuple } " word will store instances of a tuple into the database table defined by its mapping object:"
-{ $code "db get \"John\" \"Smith\" \"123-456-789\" <person> insert-tuple" }
-{ $link insert-tuple } " internally uses the " { $link insert-sql } " word to produce the SQL used to store the tuple. Like " { $link create-sql } ", it is a generic word specialized on the mapping object. You can call it directly to see what SQL is generated:"
-{ $code "person get-mapping insert-sql .\n => \"insert into person values(:name,:surname,:phone);\"" }
-"Notice that the SQL uses named parameters. These parameters are bound to the values stored in the tuple object when the SQL is compiled. This helps prevent SQL injection techniques."
-$nl
-"When " { $link insert-sql } " is run, it adds a delegate to the tuple being stored. The delegate is of type 'persistent' and holds the row id of the tuple in its 'key' slot. This way the exact record can be updated or retrieved later. The following demonstates this fact:"
-{ $code "\"Mandy\" \"Jones\" \"987-654-321\" <person> dup .\n => T{ person f \"Mandy\" \"Jones\" \"987-654-321\" }\ndb get over insert-tuple .\n => T{ person T{ persistent ... 2 } \"Mandy\" \"Jones\" \"987-654-321\" }" }
-"The '2' in the above example is the row id of the record inserted. We can go into the 'sqlite' command and view this record:"
-{ $code " $ sqlite3 example.db\n SQLite version 3.0.8\n Enter \".help\" for instructions\n sqlite> select ROWID,* from person;\n 1|John|Smith|123-456-789\n 2|Mandy|Jones|987-654-321\n sqlite>" } ;
-
-ARTICLE: { "sqlite" "tuple-db-finding" } "Finding instances"
-"The " { $link find-tuples } " word is used to return tuples populated with data already existing in the database. As well as the database objcet, it takes a tuple that should be populated only with the fields that should be matched in the database. All fields you do not wish to match against should be set to 'f':"
-{ $code "db get f \"Smith\" f <person> find-tuples .\n => { T{ person # \"John\" \"Smith\" \"123-456-789\" } }\ndb get \"Mandy\" f f <person> find-tuples .\n => { T{ person # \"Mandy\" \"Jones\" \"987-654-321\" } }\ndb get \"Joe\" f f <person> find-tuples .\n => { }" }
-"Notice that if no matching tuples are found then an empty sequence is returned. The returned tuples also have their delegate set to 'persistent' with the correct row id set as the key. This can be used to later update the tuples with new information and store them in the database." ;
-
-ARTICLE: { "sqlite" "tuple-db-updating" } "Updating instances"
-"Given a tuple that has the 'persistent' delegate with the row id set as the key, you can update this specific record using " { $link update-tuple } ":"
-{ $code "db get f \"Smith\" f <person> find-tuples dup .\n => { T{ person # \"John\" \"Smith\" \"123-456-789\" } }\nfirst { \"999-999-999\" swap set-person-phone ] keep dup .\n => T{ person T{ persistent f # \"1\" } \"John\" \"Smith\" \"999-999-999\" ...\n db get swap update-tuple" }
-"Using the 'sqlite' command from the system shell you can see the record was updated:"
-{ $code " $ sqlite3 example.db\n SQLite version 3.0.8\n Enter \".help\" for instructions\n sqlite> select ROWID,* from person;\n 1|John|Smith|999-999-999\n 2|Mandy|Jones|987-654-321\n sqlite>" } ;
-
-ARTICLE: { "sqlite" "tuple-db-inserting-or-updating" } "Inserting or Updating instances"
-"The " { $link save-tuple } " word can be used to insert a tuple if it has not already been stored in the database, or update it if it already exists. Whether to insert or update is decided by the existance of the 'persistent' delegate:"
-{ $code "\"Mary\" \"Smith\" \"111-111-111\" <person> dup .\n => T{ person f \"Mary\" \"Smith\" \"111-111-111\" }\n! This will insert the tuple\ndb get over save-tuple dup .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"111-111-111\" ...\n[ \"222-222-222\" swap set-person-phone ] keep dup .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"222-222-222\" ...\n! This will update the tuple\ndb get over save-tuple .\n => T{ person T{ persistent f # \"3\" } \"Mary\" \"Smith\" \"222-222-222\" ..." } ;
-
-ARTICLE: { "sqlite" "tuple-db-deleting" } "Deleting instances"
-"Given a tuple with the delegate set to 'persistent' (ie. One already stored in the database) you can delete it from the database with " { $link delete-tuple } ":"
-{ $code "db get f \"Smith\" f <person> find-tuples [ db get swap delete-tuple ] each" } ;
-
-ARTICLE: { "sqlite" "tuple-db-closing" } "Closing the database"
-"It's important to close the sqlite database when you've finished using it. The word for this is " { $link sqlite-close } ":"
-{ $code "db get sqlite-close" } ;
-
-ARTICLE: { "sqlite" "tuple-db" } "Tuple Database Library"
-"The version of sqlite required by this library is version 3 or greater. This library allows storing Factor tuples in a sqlite database. It provides words to create, read update and delete these entries as well as simple searching."
-$nl
-"The library is in a very early state and is likely to change quite a bit in the near future. Its most notable omission is it cannot currently handle relationships between tuples."
-{ $subsection { "sqlite" "tuple-db-loading" } }
-{ $subsection { "sqlite" "tuple-db-usage" } }
-{ $subsection { "sqlite" "tuple-db-mappings" } }
-{ $subsection { "sqlite" "tuple-db-create" } }
-{ $subsection { "sqlite" "tuple-db-insert" } }
-{ $subsection { "sqlite" "tuple-db-finding" } }
-{ $subsection { "sqlite" "tuple-db-updating" } }
-{ $subsection { "sqlite" "tuple-db-inserting-or-updating" } }
-{ $subsection { "sqlite" "tuple-db-deleting" } }
-{ $subsection { "sqlite" "tuple-db-closing" } }
-;
-
-HELP: default-mapping
-{ $values { "class" "symbol for the tuple class" }
- { "mapping" "a mapping object" }
-}
-{ $description "Given a tuple class, create a default mappings object. This is used to associate field names in the tuple with SQL statement field names, etc." }
-{ $see-also { "sqlite" "tuple-db" } set-mapping } ;
-
-HELP: set-mapping
-{ $values { "mapping" "a mapping object" }
-}
-{ $description "Store a database mapping so that the tuple-db system knows how to store instances of the tuple in the database." }
-{ $see-also { "sqlite" "tuple-db" } default-mapping } ;
-
-HELP: create-tuple-table
-{ $values { "db" "a database object" } { "class" "symbol for the tuple class" }
-}
-{ $description "Create the database table to store intances of the given tuple." }
-{ $see-also { "sqlite" "tuple-db" } default-mapping get-mapping } ;
-
-HELP: insert-tuple
-{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" }
-}
-{ $description "Insert the tuple instance into the database. It is assumed that this tuple does not currently exist in the database." }
-{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
-
-HELP: find-tuples
-{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" } { "seq" "a sequence of tuples" } }
-{ $description "Return a sequence of all tuples in the database that match the tuple provided as a template. All fields in the tuple must match the entries in the database, except for those set to 'f'." }
-{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
-
-HELP: update-tuple
-{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" }
-}
-{ $description "Update the database record for this tuple instance. The tuple must have previously been obtained from the database, or inserted into it. It must have a delegate of 'persistent' with the key field set (which is done by the find and insert operations)." }
-{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
-
-HELP: save-tuple
-{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" }
-}
-{ $description "Insert or Update the tuple instance depending on whether it has a persistent delegate." }
-{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
-
-HELP: delete-tuple
-{ $values { "db" "a database object" } { "tuple" "an instance of a tuple" }
-}
-{ $description "Delete this tuple instance from the database. The tuple must have previously been obtained from the database, or inserted into it. It must have a delegate of 'persistent' with the key field set (which is done by the find and insert operations)." }
-{ $see-also { "sqlite" "tuple-db" } insert-tuple update-tuple find-tuples delete-tuple save-tuple } ;
-
-ABOUT: { "sqlite" "tuple-db" }
\ No newline at end of file
diff --git a/extra/sqlite/tuple-db/tuple-db-tests.factor b/extra/sqlite/tuple-db/tuple-db-tests.factor
deleted file mode 100644
index 8ed2631b45..0000000000
--- a/extra/sqlite/tuple-db/tuple-db-tests.factor
+++ /dev/null
@@ -1,39 +0,0 @@
-! Copyright (C) 2005 Chris Double.
-! See http://factorcode.org/license.txt for BSD license.
-
-IN: temporary
-USING: io io.files kernel sequences namespaces
-hashtables sqlite sqlite.tuple-db math words tools.test ;
-
-TUPLE: testdata one two ;
-
-C: <testdata> testdata
-
-testdata default-mapping set-mapping
-
-"libs/sqlite/test.db" resource-path [
-
- db get testdata create-tuple-table
-
- [ "two" { } ] [
- db get "one" "two" <testdata> insert-tuple
- db get "one" f <testdata> find-tuples
- first [ testdata-two ] keep
- db get swap delete-tuple
- db get "one" f <testdata> find-tuples
- ] unit-test
-
- [ "junk" ] [
- db get "one" "two" <testdata> insert-tuple
- db get "one" f <testdata> find-tuples
- first
- "junk" over set-testdata-two
- db get swap update-tuple
- db get "one" f <testdata> find-tuples
- first [ testdata-two ] keep
- db get swap delete-tuple
- ] unit-test
-
- db get testdata drop-tuple-table
-] with-sqlite
-
diff --git a/extra/sqlite/tuple-db/tuple-db.factor b/extra/sqlite/tuple-db/tuple-db.factor
deleted file mode 100644
index c37a49d2b6..0000000000
--- a/extra/sqlite/tuple-db/tuple-db.factor
+++ /dev/null
@@ -1,270 +0,0 @@
-! Copyright (C) 2005 Chris Double.
-!
-! A tuple that is persistent has its delegate set as 'persistent'.
-! 'persistent' holds the numeric rowid for that tuple in its table.
-IN: sqlite.tuple-db
-USING: io kernel sequences namespaces slots classes slots.private
-assocs math words generic sqlite math.parser ;
-
-! Each slot in a tuple that is storable in the database has
-! an instance of a db-field object the gives the name of the
-! database table and slot number in the tuple object of that field.
-TUPLE: db-field name bind-name slot type ;
-
-C: <db-field> db-field
-
-! The mapping tuple holds information on how the slots of
-! a tuple are mapped to the fields of a sqlite database.
-TUPLE: mapping tuple table fields one-to-one one-to-many ;
-
-C: <mapping> mapping
-
-: sanitize ( string -- string )
- #! Convert a string so it can be used as a table or field name.
- clone
- H{ { CHAR: - CHAR: _ } { CHAR: ? CHAR: p } }
- over substitute ;
-
-: tuple-fields ( class -- seq )
- #! Given a tuple class return a list of the fields
- #! within that tuple. Ignores the delegate field.
- "slots" word-prop 1 tail [
- [ slot-spec-name sanitize dup ":" swap append ] keep
- slot-spec-offset
- "text"
- <db-field>
- ] map ;
-
-: default-mapping ( class -- mapping )
- #! Given a tuple class, create a default mappings object. It assumes
- #! there are no one-to-one or one-to-many relationships.
- dup [ word-name sanitize ] keep tuple-fields f f <mapping> ;
-
-! The mappings variable holds a hashtable mapping the tuple symbol
-! to the mapping object, describing how that tuple is stored
-! in the database.
-SYMBOL: mappings
-
-: init-mappings ( -- )
- H{ } mappings set-global ;
-
-: get-mappings ( -- hashtable )
- mappings get-global ;
-
-: set-mapping ( mapping -- )
- #! Store a database mapping so that the persistence system
- #! knows how to store instances of the relevant tuple in the database.
- dup mapping-tuple get-mappings set-at ;
-
-: get-mapping ( class -- mapping )
- #! Return the database mapping for the given tuple class.
- get-mappings at ;
-
-! The 'persistent' tuple will be set to the delegate of any tuple
-! instance stored in the database. It contains the database key
-! of the row in the database table for the instance or 'f' if it has
-! not yet been stored in the database. It also contains the 'mapping'
-! object used to translate the fields of the tuple to the database fields.
-TUPLE: persistent mapping key ;
-: <persistent> ( tuple -- persistent )
- persistent construct-empty
- >r class get-mapping r>
- [ set-persistent-mapping ] keep ;
-
-: make-persistent ( tuple -- tuple )
- #! Convert the tuple into something that can be stored
- #! into a database by setting its delegate to 'persistent'.
- [ <persistent> ] keep
- [ set-delegate ] keep ;
-
-
-: comma-fields ( mapping quot -- string )
- #! Given a mapping, call quot on each field in
- #! the mapping. The contents of quot should call ',' or '%'
- #! to generate output. The output of each quot call
- #! seperated by commas is returned as a string. 'quot' should be
- #! stack effect ( field -- ).
- >r mapping-fields r> [ "" make ] curry map "," join ; inline
-
-GENERIC: create-sql ( mapping -- string )
-M: mapping create-sql ( mapping -- string )
- #! Return the SQL used to create a table for storing this type of tuple.
- [
- "create table " % dup mapping-table %
- " (" %
- [ dup db-field-name % " " % db-field-type % ] comma-fields %
- ");" %
- ] "" make ;
-
-GENERIC: drop-sql ( mapping -- string )
-M: mapping drop-sql ( mapping -- string )
- #! Return the SQL used to drop the table for storing this type of tuple.
- [
- "drop table " % mapping-table % ";" %
- ] "" make ;
-
-GENERIC: insert-sql ( mapping -- string )
-M: mapping insert-sql ( mapping -- string )
- #! Return the SQL used to insert a tuple into a table
- [
- "insert into " % dup mapping-table %
- " values(" %
- [ db-field-bind-name % ] comma-fields %
- ");" %
- ] "" make ;
-
-GENERIC: delete-sql ( mapping -- string )
-M: mapping delete-sql ( mapping -- string )
- #! Return the SQL used to delete a tuple from a table
- [
- "delete from " % mapping-table %
- " where ROWID=:rowid;" %
- ] "" make ;
-
-GENERIC: update-sql ( mapping -- string )
-M: mapping update-sql ( mapping -- string )
- #! Return the SQL used to update the tuple
- [
- "update " % dup mapping-table %
- " set " %
- [ dup db-field-name % "=" % db-field-bind-name % ] comma-fields %
- " where ROWID=:rowid;" %
- ] "" make ;
-
-GENERIC: select-sql ( tuple mapping -- select )
-M: mapping select-sql ( tuple mapping -- select )
- #! Return the SQL used to select a series of tuples from the database. It
- #! will select based on only the filled in fields of the tuple (ie. all non-f).
- [
- "select ROWID,* from " % dup mapping-table %
- mapping-fields [ ! tuple field
- swap over db-field-slot slot ! field value
- [
- [ dup db-field-name % "=" % db-field-bind-name % ] "" make
- ] [
- drop f
- ] if
- ] with map [ ] subset dup length 0 > [
- " where " %
- " and " join %
- ] [
- drop
- ] if
- ";" %
- ] "" make ;
-
-: execute-update-sql ( db string -- )
- #! Execute the SQL, which should contain a database update
- #! statement (update, insert, create, etc). Ignore the result.
- sqlite-prepare dup [ drop ] sqlite-each sqlite-finalize ;
-
-: create-tuple-table ( db class -- )
- #! Create the table for the tuple class.
- get-mapping create-sql execute-update-sql ;
-
-: drop-tuple-table ( db class -- )
- #! Create the table for the tuple class.
- get-mapping drop-sql execute-update-sql ;
-
-: bind-for-insert ( statement tuple -- )
- #! Bind the fields in the tuple to the fields in the
- #! prepared insert statement.
- dup class get-mapping mapping-fields [ ! statement tuple field
- [ db-field-slot slot ] keep ! statement value field
- db-field-bind-name swap ! statement name value
- >r dupd r> sqlite-bind-text-by-name
- ] with each drop ;
-
-: bind-for-select ( statement tuple -- )
- #! Bind the fields in the tuple to the fields in the
- #! prepared select statement.
- dup class get-mapping mapping-fields [ ! statement tuple field
- [ db-field-slot slot ] keep ! statement value field
- over [
- db-field-bind-name swap ! statement name value
- >r dupd r> sqlite-bind-text-by-name
- ] [
- 2drop
- ] if
- ] with each drop ;
-
-: bind-for-update ( statement tuple -- )
- #! Bind the fields in the tuple to the fields in the
- #! prepared update statement.
- 2dup bind-for-insert
- >r ":rowid" r> persistent-key sqlite-bind-text-by-name ;
-
-: bind-for-delete ( statement tuple -- )
- #! Bind the fields in the tuple to the fields in the
- #! prepared delete statement.
- >r ":rowid" r> persistent-key sqlite-bind-text-by-name ;
-
-: (insert-tuple) ( db tuple -- )
- #! Insert this tuple instance into the database. Note that
- #! it inserts only this instance, and not any one-to-one or
- #! one-to-many fields.
- dup class get-mapping insert-sql ! db tuple sql
- swapd sqlite-prepare swap ! statement tuple
- dupd bind-for-insert ! statement
- dup [ drop ] sqlite-each
- sqlite-finalize ;
-
-: insert-tuple ( db tuple -- )
- #! Insert this tuple instance into the database and
- #! update the rowid of the insert in the tuple.
- [ (insert-tuple) ] 2keep
- >r sqlite-last-insert-rowid number>string r> make-persistent set-persistent-key ;
-
-: update-tuple ( db tuple -- )
- #! Update this tuple instance in the database. The tuple should have
- #! a delegate of 'persistent' with the key field set.
- dup class get-mapping update-sql ! db tuple sql
- swapd sqlite-prepare swap ! statement tuple
- dupd bind-for-update ! statement
- dup [ drop ] sqlite-each
- sqlite-finalize ;
-
-: save-tuple ( db tuple -- )
- #! Insert or Update the tuple instance depending on whether it
- #! has a persistent delegate.
- dup delegate [ update-tuple ] [ insert-tuple ] if ;
-
-: delete-tuple ( db tuple -- )
- #! Delete this tuple instance from the database. The tuple should have
- #! a delegate of 'persistent' with the key field set.
- dup class get-mapping delete-sql ! db tuple sql
- swapd sqlite-prepare swap ! statement tuple
- dupd bind-for-delete ! statement
- dup [ drop ] sqlite-each
- sqlite-finalize ;
-
-: restore-tuple ( statement tuple -- tuple )
- #! Using 'tuple' as a template, clone it and
- #! return the clone with fields set to the values from the
- #! database.
- clone dup class get-mapping mapping-fields 1 swap
- [ ! statement tuple index field )
- over 1+ >r ! statement tuple index field r: index+1
- db-field-slot >r ! statement tuple index r: index+1 slot
- pick swap column-text ! statement tuple value r: index+1 slot
- over r> set-slot r> ! statement tuple index+1
- ] each ! statement tuple index
- drop make-persistent swap 0 column-text swap [ set-persistent-key ] keep ;
-
-: find-tuples ( db tuple -- seq )
- #! Return a sequence of all tuples in the database that
- #! match the tuple provided as a template. All fields in the
- #! tuple must match the entries in the database, except for
- #! those set to 'f'.
- dup class get-mapping dupd select-sql ! db tuple sql
- swapd sqlite-prepare swap ! statement tuple
- 2dup bind-for-select ! statement tuple
- [
- over [ ! tuple statement
- over restore-tuple ,
- ] sqlite-each
- ] { } make nip ! statement tuple accum
- swap sqlite-finalize ;
-
-
-get-mappings [ init-mappings ] unless
From 6f2b91d4a4a9acdd83161a0d1ae884b423c59ae4 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Fri, 1 Feb 2008 18:10:32 -0800
Subject: [PATCH 09/52] Move byte-length generic and methods into alien.c-types
---
core/alien/alien-docs.factor | 4 ----
core/alien/alien.factor | 2 --
core/alien/c-types/c-types-docs.factor | 4 ++++
core/alien/c-types/c-types.factor | 8 +++++++-
core/byte-arrays/byte-arrays.factor | 2 --
core/float-arrays/float-arrays.factor | 3 +--
6 files changed, 12 insertions(+), 11 deletions(-)
diff --git a/core/alien/alien-docs.factor b/core/alien/alien-docs.factor
index 8ae89ed5b1..8fee0e8c3e 100755
--- a/core/alien/alien-docs.factor
+++ b/core/alien/alien-docs.factor
@@ -34,10 +34,6 @@ HELP: <alien>
{ $description "Creates an alien object, wrapping a raw memory address." }
{ $notes "Alien objects are invalidated between image saves and loads." } ;
-HELP: byte-length
-{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
-{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
-
HELP: c-ptr
{ $class-description "Class of objects consisting of aliens, byte arrays and " { $link f } ". These objects can convert to pointer C types, which are all aliases of " { $snippet "void*" } "." } ;
diff --git a/core/alien/alien.factor b/core/alien/alien.factor
index 4b899a15e4..1c8163e2fa 100755
--- a/core/alien/alien.factor
+++ b/core/alien/alien.factor
@@ -28,8 +28,6 @@ PREDICATE: alien pinned-alien
UNION: pinned-c-ptr
pinned-alien POSTPONE: f ;
-GENERIC: byte-length ( seq -- n ) flushable
-
M: f expired? drop t ;
: <alien> ( address -- alien )
diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor
index f6418295f7..f4aa297a3a 100755
--- a/core/alien/c-types/c-types-docs.factor
+++ b/core/alien/c-types/c-types-docs.factor
@@ -34,6 +34,10 @@ HELP: stack-size
{ $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." }
{ $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ;
+HELP: byte-length
+{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } }
+{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ;
+
HELP: c-getter
{ $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } }
{ $description "Outputs a quotation which reads values of this C type from a C structure." }
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index 1ecfa37ee6..47f9fd0326 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays arrays generator.registers assocs
+USING: byte-arrays float-arrays arrays generator.registers assocs
kernel kernel.private libc math namespaces parser sequences
strings words assocs splitting math.parser cpu.architecture
alien quotations system compiler.units ;
@@ -107,6 +107,12 @@ M: string stack-size c-type stack-size ;
M: c-type stack-size c-type-size ;
+GENERIC: byte-length ( seq -- n ) flushable
+
+M: float-array byte-length length "float" heap-size * ;
+
+M: byte-array byte-length length ;
+
: c-getter ( name -- quot )
c-type c-type-getter [
[ "Cannot read struct fields with type" throw ]
diff --git a/core/byte-arrays/byte-arrays.factor b/core/byte-arrays/byte-arrays.factor
index 295c6c4384..401b151ad0 100755
--- a/core/byte-arrays/byte-arrays.factor
+++ b/core/byte-arrays/byte-arrays.factor
@@ -15,8 +15,6 @@ M: byte-array new drop <byte-array> ;
M: byte-array equal?
over byte-array? [ sequence= ] [ 2drop f ] if ;
-M: byte-array byte-length
- length ;
M: byte-array resize
resize-byte-array ;
diff --git a/core/float-arrays/float-arrays.factor b/core/float-arrays/float-arrays.factor
index 948e41ef7a..445edd550a 100755
--- a/core/float-arrays/float-arrays.factor
+++ b/core/float-arrays/float-arrays.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel kernel.private alien alien.c-types sequences
+USING: kernel kernel.private alien sequences
sequences.private math math.private ;
IN: float-arrays
@@ -12,7 +12,6 @@ PRIVATE>
M: float-array clone (clone) ;
M: float-array length array-capacity ;
-M: float-array byte-length array-capacity "float" heap-size * ;
M: float-array nth-unsafe
float-array@ alien-double ;
From db3ac4d75ff5835d49bd9821cd303d724f330a6d Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.(none)>
Date: Fri, 1 Feb 2008 22:46:03 -0600
Subject: [PATCH 10/52] intermediate work on cookies
---
extra/http/http.factor | 7 +++----
1 file changed, 3 insertions(+), 4 deletions(-)
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 9e5d34fa36..a71e003433 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -1,18 +1,18 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs
-sequences strings splitting ;
+sequences strings splitting assocs.lib ;
IN: http
: header-line ( line -- )
- ": " split1 dup [ swap set ] [ 2drop ] if ;
+ ": " split1 dup [ swap >lower set ] [ 2drop ] if ;
: (read-header) ( -- )
readln dup
empty? [ drop ] [ header-line (read-header) ] if ;
: read-header ( -- hash )
- [ (read-header) ] H{ } make-assoc ;
+ [ (read-header) ] VH{ } make-assoc ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
@@ -74,4 +74,3 @@ IN: http
hash>query %
] if
] "" make ;
-
From 004dd0dc5e97f60bf917b2af99673c3fa2bbe754 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.(none)>
Date: Fri, 1 Feb 2008 22:46:32 -0600
Subject: [PATCH 11/52] add accumulator
---
extra/sequences/lib/lib.factor | 3 +++
1 file changed, 3 insertions(+)
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index e46ce3b107..9aac0a50bd 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -140,3 +140,6 @@ PRIVATE>
: ?second ( seq -- second/f ) 1 swap ?nth ; inline
: ?third ( seq -- third/f ) 2 swap ?nth ; inline
: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
+
+: accumulator ( quot -- quot vec )
+ V{ } clone [ [ push ] curry compose ] keep ;
From 9e9c71b6d0925d5929bbb10a20807fd3d75cfb6c Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@laptop.(none)>
Date: Fri, 1 Feb 2008 23:46:44 -0600
Subject: [PATCH 12/52] make multi-assocs work for http headers
---
extra/http/client/client.factor | 4 +--
extra/http/http.factor | 7 +++--
.../http/server/responders/responders.factor | 28 +++++++++++--------
3 files changed, 22 insertions(+), 17 deletions(-)
diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor
index 7eb84fba4c..8e6d8257a4 100755
--- a/extra/http/client/client.factor
+++ b/extra/http/client/client.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files strings splitting
-continuations ;
+continuations assocs.lib ;
IN: http.client
: parse-host ( url -- host port )
@@ -44,7 +44,7 @@ DEFER: http-get-stream
#! Should this support Location: headers that are
#! relative URLs?
pick 100 /i 3 = [
- dispose "location" swap header-single nip http-get-stream
+ dispose "location" swap peek-at nip http-get-stream
] when ;
: http-get-stream ( url -- code headers stream )
diff --git a/extra/http/http.factor b/extra/http/http.factor
index 4999559324..755f36a538 100755
--- a/extra/http/http.factor
+++ b/extra/http/http.factor
@@ -1,18 +1,19 @@
! Copyright (C) 2003, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: hashtables io kernel math namespaces math.parser assocs
-sequences strings splitting ascii io.utf8 assocs.lib ;
+sequences strings splitting ascii io.utf8 assocs.lib
+namespaces unicode.case ;
IN: http
: header-line ( line -- )
- ": " split1 dup [ swap >lower set ] [ 2drop ] if ;
+ ": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
: (read-header) ( -- )
readln dup
empty? [ drop ] [ header-line (read-header) ] if ;
: read-header ( -- hash )
- [ (read-header) ] VH{ } make-assoc ;
+ [ (read-header) ] H{ } make-assoc ;
: url-quotable? ( ch -- ? )
#! In a URL, can this character be used without
diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor
index 8dcaa7223d..a507a95a14 100644
--- a/extra/http/server/responders/responders.factor
+++ b/extra/http/server/responders/responders.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs hashtables html html.elements splitting
http io kernel math math.parser namespaces parser sequences
-strings io.server ;
+strings io.server vectors vector-hash strings.lib ;
IN: http.server.responders
@@ -10,8 +10,11 @@ IN: http.server.responders
SYMBOL: vhosts
SYMBOL: responders
+: >header ( value key -- vector-hash )
+ VH{ } clone [ set-at ] keep ;
+
: print-header ( alist -- )
- [ swap write ": " write print ] assoc-each nl ;
+ [ swap >Upper-dashes write ": " write print ] vector-hash-each nl ;
: response ( msg -- ) "HTTP/1.0 " write print ;
@@ -20,7 +23,7 @@ SYMBOL: responders
: error-head ( error -- )
dup log-error response
- H{ { "Content-Type" "text/html" } } print-header nl ;
+ VH{ { "Content-Type" "text/html" } } print-header nl ;
: httpd-error ( error -- )
#! This must be run from handle-request
@@ -36,7 +39,7 @@ SYMBOL: responders
: serving-content ( mime -- )
"200 Document follows" response
- "Content-Type" associate print-header ;
+ "Content-Type" >header print-header ;
: serving-html "text/html" serving-content ;
@@ -46,7 +49,7 @@ SYMBOL: responders
: serving-text "text/plain" serving-content ;
: redirect ( to response -- )
- response "Location" associate print-header ;
+ response "Location" >header print-header ;
: permanent-redirect ( to -- )
"301 Moved Permanently" redirect ;
@@ -84,14 +87,14 @@ SYMBOL: max-post-request
: log-headers ( hash -- )
[
drop {
- "User-Agent"
- "Referer"
- "X-Forwarded-For"
- "Host"
+ "user-agent"
+ "referer"
+ "x-forwarded-for"
+ "host"
} member?
] assoc-subset [
": " swap 3append log-message
- ] assoc-each ;
+ ] vector-hash-each ;
: prepare-url ( url -- url )
#! This is executed in the with-request namespace.
@@ -122,7 +125,8 @@ SYMBOL: max-post-request
: query-param ( key -- value ) "query" get at ;
-: header-param ( key -- value ) "header" get at ;
+: header-param ( key -- value )
+ "header" get peek-at ;
: host ( -- string )
#! The host the current responder was called from.
@@ -130,7 +134,7 @@ SYMBOL: max-post-request
: add-responder ( responder -- )
#! Add a responder object to the list.
- "responder" over at responders get set-at ;
+ "responder" over at responders get set-at ;
: make-responder ( quot -- )
#! quot has stack effect ( url -- )
From 22eb97778e04197530130d280959832db727111d Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@laptop.(none)>
Date: Fri, 1 Feb 2008 23:47:37 -0600
Subject: [PATCH 13/52] add multi-assocs
---
extra/assocs/lib/lib.factor | 23 +++++++++++++++++------
1 file changed, 17 insertions(+), 6 deletions(-)
diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor
index 849f88023f..182f04a367 100755
--- a/extra/assocs/lib/lib.factor
+++ b/extra/assocs/lib/lib.factor
@@ -1,9 +1,6 @@
-USING: assocs kernel vectors sequences ;
+USING: assocs kernel vectors sequences namespaces ;
IN: assocs.lib
-: insert-at ( value key assoc -- )
- [ ?push ] change-at ;
-
: >set ( seq -- hash )
[ dup ] H{ } map>assoc ;
@@ -19,5 +16,19 @@ IN: assocs.lib
: at-default ( key assoc -- value/key )
dupd at [ nip ] when* ;
-: at-peek ( key assoc -- value ? )
- at* dup >r [ peek ] when r> ;
+: insert-at ( value key assoc -- )
+ [ ?push ] change-at ;
+
+: peek-at* ( key assoc -- obj ? )
+ at* dup [ >r peek r> ] when ;
+
+: peek-at ( key assoc -- obj )
+ peek-at* drop ;
+
+: >multi-assoc ( assoc -- new-assoc )
+ [ 1vector ] assoc-map ;
+
+: multi-assoc-each ( assoc quot -- )
+ [ with each ] curry assoc-each ; inline
+
+: insert ( value variable -- ) namespace insert-at ;
From 698f4180bbd580c73f1cf3204cc83626a6245a7b Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@laptop.(none)>
Date: Fri, 1 Feb 2008 23:47:54 -0600
Subject: [PATCH 14/52] add a wget-bootstrap option
---
misc/factor.sh | 3 ++-
1 file changed, 2 insertions(+), 1 deletion(-)
diff --git a/misc/factor.sh b/misc/factor.sh
index 39a15f93dc..032b0b3184 100755
--- a/misc/factor.sh
+++ b/misc/factor.sh
@@ -289,7 +289,7 @@ install_libraries() {
}
usage() {
- echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap"
+ echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap"
}
case "$1" in
@@ -299,5 +299,6 @@ case "$1" in
quick-update) update; refresh_image ;;
update) update; update_bootstrap ;;
bootstrap) get_config_info; bootstrap ;;
+ wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;;
*) usage ;;
esac
From 9667afcb816c042e4c396a0b048cbebdbd9b75f0 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 2 Feb 2008 13:14:22 -0800
Subject: [PATCH 15/52] cel-shading, line-art, and bunny touch their magic
rings together and become Super Bunny Demo
---
core/alien/c-types/c-types.factor | 2 +-
extra/bunny/bunny.factor | 158 ++++-------
extra/cel-shading/cel-shading.factor | 115 --------
extra/line-art/line-art.factor | 254 ------------------
.../demo-support}/authors.txt | 0
.../demo-support/demo-support.factor} | 2 +-
.../demo-support}/summary.txt | 0
.../demo-support}/tags.txt | 0
extra/opengl/opengl.factor | 11 +-
9 files changed, 63 insertions(+), 479 deletions(-)
delete mode 100644 extra/cel-shading/cel-shading.factor
delete mode 100644 extra/line-art/line-art.factor
rename extra/{opengl-demo-support => opengl/demo-support}/authors.txt (100%)
rename extra/{opengl-demo-support/opengl-demo-support.factor => opengl/demo-support/demo-support.factor} (99%)
rename extra/{opengl-demo-support => opengl/demo-support}/summary.txt (100%)
rename extra/{opengl-demo-support => opengl/demo-support}/tags.txt (100%)
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index d260eb9b8f..8ab703eb7e 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -109,7 +109,7 @@ M: c-type stack-size c-type-size ;
GENERIC: byte-length ( seq -- n ) flushable
-M: float-array byte-length length "float" heap-size * ;
+M: float-array byte-length length "double" heap-size * ;
M: byte-array byte-length length ;
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index 479d9cb39b..efebefcef3 100755
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -1,123 +1,73 @@
-! From http://www.ffconsultancy.com/ocaml/bunny/index.html
USING: alien alien.c-types arrays sequences math
math.vectors math.matrices math.parser io io.files kernel opengl
opengl.gl opengl.glu shuffle http.client vectors timers
namespaces ui.gadgets ui.gadgets.canvas ui.render ui splitting
combinators tools.time system combinators.lib combinators.cleave
-float-arrays ;
+float-arrays continuations opengl.demo-support multiline
+ui.gestures
+bunny.fixed-pipeline bunny.cel-shaded bunny.outlined bunny.model ;
IN: bunny
-: numbers ( str -- seq )
- " " split [ string>number ] map [ ] subset ;
+<PRIVATE
-: (parse-model) ( vs is -- vs is )
- readln [
- numbers {
- { [ dup length 5 = ] [ 3 head pick push ] }
- { [ dup first 3 = ] [ 1 tail over push ] }
- { [ t ] [ drop ] }
- } cond (parse-model)
- ] when* ;
+PRIVATE>
-: parse-model ( stream -- vs is )
- [
- 100000 <vector> 100000 <vector> (parse-model)
- ] with-stream
- [
- over length # " vertices, " %
- dup length # " triangles" %
- ] "" make print ;
+TUPLE: bunny-gadget model geom draw-seq draw-n ;
-: n ( vs triple -- n )
- swap [ nth ] curry map
- dup third over first v- >r dup second swap first v- r> cross
- vneg normalize ;
+: <bunny-gadget> ( -- bunny-gadget )
+ 0.0 0.0 0.375 <demo-gadget>
+ maybe-download read-model {
+ set-delegate
+ set-bunny-gadget-model
+ } bunny-gadget construct ;
-: normal ( ns vs triple -- )
- [ n ] keep [ rot [ v+ ] change-nth ] each-with2 ;
+: bunny-gadget-draw ( gadget -- draw )
+ { bunny-gadget-draw-n bunny-gadget-draw-seq }
+ get-slots nth ;
-: normals ( vs is -- ns )
- over length { 0.0 0.0 0.0 } <array> -rot
- [ >r 2dup r> normal ] each drop
- [ normalize ] map ;
+: bunny-gadget-next-draw ( gadget -- )
+ dup { bunny-gadget-draw-seq bunny-gadget-draw-n }
+ get-slots
+ 1+ swap length mod
+ swap [ set-bunny-gadget-draw-n ] keep relayout-1 ;
-: read-model ( stream -- model )
- "Reading model" print flush [
- <file-reader> parse-model [ normals ] 2keep 3array
- ] time ;
-
-: make-vertex-buffers ( model -- array element-array )
- [
- [ first concat ] [ second concat ] bi
- append >float-array
- GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
- ] [
- third concat >c-uint-array
- GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
- ] bi ;
-
-: model-path "bun_zipper.ply" ;
-
-: model-url "http://factorcode.org/bun_zipper.ply" ;
-
-: maybe-download ( -- path )
- model-path resource-path dup exists? [
- "Downloading bunny from " write
- model-url dup print flush
- over download-to
- ] unless ;
-
-: draw-triangle ( ns vs triple -- )
- [ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ;
-
-: draw-bunny ( ns vs is -- )
- GL_TRIANGLES [ [ draw-triangle ] each-with2 ] do-state ;
-
-TUPLE: bunny-gadget model ;
-
-: <bunny-gadget> ( model -- gadget )
- <canvas>
- { set-bunny-gadget-model set-delegate }
- bunny-gadget construct ;
-
-M: bunny-gadget graft* 10 10 add-timer ;
-
-M: bunny-gadget ungraft* dup delegate ungraft* remove-timer ;
-
-M: bunny-gadget tick relayout-1 ;
-
-: aspect ( gadget -- x ) rect-dim first2 /f ;
-
-M: bunny-gadget draw-gadget*
+M: bunny-gadget graft* ( gadget -- )
GL_DEPTH_TEST glEnable
- GL_SCISSOR_TEST glDisable
- 1.0 glClearDepth
- 0.0 0.0 0.0 1.0 glClearColor
- GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
- GL_PROJECTION glMatrixMode
- glLoadIdentity
- 45.0 over aspect 0.1 1.0 gluPerspective
- 0.0 0.12 -0.25 0.0 0.1 0.0 0.0 1.0 0.0 gluLookAt
- GL_MODELVIEW glMatrixMode
- glLoadIdentity
- GL_LEQUAL glDepthFunc
- GL_LIGHTING glEnable
- GL_LIGHT0 glEnable
- GL_COLOR_MATERIAL glEnable
- GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv
- millis 24000 mod 0.015 * 0.0 1.0 0.0 glRotated
- GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf
- GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial
- GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
- 0.6 0.5 0.5 1.0 glColor4d
- [ bunny-gadget-model first3 draw-bunny ] draw-canvas ;
+ dup bunny-gadget-model <bunny-geom>
+ over {
+ [ <bunny-fixed-pipeline> ]
+ [ <bunny-cel-shaded> ]
+ [ <bunny-outlined> ]
+ } map-call-with [ ] subset
+ 0
+ roll {
+ set-bunny-gadget-geom
+ set-bunny-gadget-draw-seq
+ set-bunny-gadget-draw-n
+ } set-slots ;
-M: bunny-gadget pref-dim* drop { 400 300 } ;
+M: bunny-gadget ungraft* ( gadget -- )
+ { bunny-gadget-geom bunny-gadget-draw-seq } get-slots
+ [ [ dispose ] when* ] each
+ [ dispose ] when* ;
+
+M: bunny-gadget draw-gadget* ( gadget -- )
+ 0.15 0.15 0.15 1.0 glClearColor
+ GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
+ dup demo-gadget-set-matrices
+ GL_MODELVIEW glMatrixMode
+ 0.0 -0.12 0.0 glTranslatef
+ { bunny-gadget-geom bunny-gadget-draw } get-slots
+ draw-bunny ;
+
+M: bunny-gadget pref-dim* ( gadget -- dim )
+ drop { 640 480 } ;
+
+bunny-gadget H{
+ { T{ key-down f f "TAB" } [ bunny-gadget-next-draw ] }
+} set-gestures
: bunny-window ( -- )
- [
- maybe-download read-model <bunny-gadget>
- "Bunny" open-window
- ] with-ui ;
+ [ <bunny-gadget> "Bunny" open-window ] with-ui ;
MAIN: bunny-window
diff --git a/extra/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor
deleted file mode 100644
index 992fd9655d..0000000000
--- a/extra/cel-shading/cel-shading.factor
+++ /dev/null
@@ -1,115 +0,0 @@
-USING: arrays bunny combinators.lib io io.files kernel
- math math.functions multiline continuations debugger
- opengl opengl.gl opengl-demo-support
- sequences ui ui.gadgets ui.render ;
-IN: cel-shading
-
-TUPLE: cel-shading-gadget model program vertices elements ;
-
-: <cel-shading-gadget> ( -- cel-shading-gadget )
- 0.0 0.0 0.375 <demo-gadget>
- maybe-download read-model {
- set-delegate
- set-cel-shading-gadget-model
- } cel-shading-gadget construct ;
-
-STRING: cel-shading-vertex-shader-source
-varying vec3 position, normal;
-
-void
-main()
-{
- gl_Position = ftransform();
-
- position = gl_Vertex.xyz;
- normal = gl_Normal;
-}
-
-;
-
-STRING: cel-shading-fragment-shader-source
-varying vec3 position, normal;
-uniform vec3 light_direction;
-uniform vec4 color;
-uniform vec4 ambient, diffuse;
-
-float
-smooth_modulate(vec3 direction, vec3 normal)
-{
- return clamp(dot(direction, normal), 0.0, 1.0);
-}
-
-float
-modulate(vec3 direction, vec3 normal)
-{
- float m = smooth_modulate(direction, normal);
- return smoothstep(0.0, 0.01, m) * 0.4 + smoothstep(0.49, 0.5, m) * 0.5;
-}
-
-void
-main()
-{
- vec3 direction = normalize(light_direction - position);
- gl_FragColor = ambient + diffuse * color * vec4(vec3(modulate(direction, normal)), 1);
-}
-
-;
-
-: make-cel-shading-program ( -- program )
- cel-shading-vertex-shader-source cel-shading-fragment-shader-source
- <simple-gl-program> ;
-
-M: cel-shading-gadget graft* ( gadget -- )
- "2.0" {
- "GL_ARB_shader_objects"
- "GL_ARB_vertex_buffer_object"
- } require-gl-version-or-extensions
- 0.0 0.0 0.0 1.0 glClearColor
- GL_CULL_FACE glEnable
- GL_DEPTH_TEST glEnable
- dup cel-shading-gadget-model make-vertex-buffers
- make-cel-shading-program roll {
- set-cel-shading-gadget-vertices
- set-cel-shading-gadget-elements
- set-cel-shading-gadget-program
- } set-slots ;
-
-M: cel-shading-gadget ungraft* ( gadget -- )
- {
- [ cel-shading-gadget-program [ delete-gl-program ] when* ]
- [ cel-shading-gadget-elements [ delete-gl-buffer ] when* ]
- [ cel-shading-gadget-vertices [ delete-gl-buffer ] when* ]
- } call-with ;
-
-: cel-shading-draw-setup ( gadget -- gadget )
- [ demo-gadget-set-matrices ] keep
- [ cel-shading-gadget-program {
- [ "light_direction" glGetUniformLocation -25.0 45.0 80.0 glUniform3f ]
- [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
- [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
- [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ]
- } call-with ] keep ;
-
-M: cel-shading-gadget draw-gadget* ( gadget -- )
- dup cel-shading-gadget-program [
- cel-shading-draw-setup
- 0.0 -0.12 0.0 glTranslatef
- dup {
- cel-shading-gadget-vertices
- cel-shading-gadget-elements
- } get-slots [
- GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [
- GL_FLOAT 0 0 buffer-offset glNormalPointer
- cel-shading-gadget-model dup
- first length 3 * 4 * buffer-offset
- 3 GL_FLOAT 0 roll glVertexPointer
- third length 3 *
- GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
- ] all-enabled-client-state
- ] with-array-element-buffers
- ] with-gl-program ;
-
-: cel-shading-window ( -- )
- [ <cel-shading-gadget> "Cel Shading" open-window ] with-ui ;
-
-MAIN: cel-shading-window
diff --git a/extra/line-art/line-art.factor b/extra/line-art/line-art.factor
deleted file mode 100644
index d78ea8a4ee..0000000000
--- a/extra/line-art/line-art.factor
+++ /dev/null
@@ -1,254 +0,0 @@
-USING: arrays bunny combinators.lib continuations io io.files kernel
- math math.functions math.vectors multiline
- namespaces debugger
- opengl opengl.gl opengl-demo-support
- prettyprint
- sequences ui ui.gadgets ui.gestures ui.render ;
-IN: line-art
-
-TUPLE: line-art-gadget
- model step1-program step2-program
- framebuffer color-texture normal-texture depth-texture framebuffer-dim ;
-
-: <line-art-gadget> ( -- line-art-gadget )
- 40.0 -5.0 0.275 <demo-gadget>
- maybe-download read-model
- { set-delegate set-line-art-gadget-model } line-art-gadget construct ;
-
-STRING: line-art-step1-vertex-shader-source
-varying vec3 normal;
-
-void
-main()
-{
- gl_Position = ftransform();
- normal = gl_Normal;
-}
-
-;
-
-STRING: line-art-step1-fragment-shader-source
-varying vec3 normal;
-uniform vec4 color;
-
-void
-main()
-{
- gl_FragData[0] = color;
- gl_FragData[1] = vec4(normal, 1);
-}
-
-;
-
-STRING: line-art-step2-vertex-shader-source
-varying vec2 coord;
-
-void
-main()
-{
- gl_Position = ftransform();
- coord = (gl_Vertex * vec4(0.5) + vec4(0.5)).xy;
-}
-
-;
-
-STRING: line-art-step2-fragment-shader-source
-uniform sampler2D colormap, normalmap, depthmap;
-uniform vec4 line_color;
-varying vec2 coord;
-
-const float DEPTH_RATIO_THRESHOLD = 1.001, SAMPLE_SPREAD = 1.0/512.0;
-
-float
-depth_sample(vec2 c)
-{
- return texture2D(depthmap, c).x;
-}
-bool
-are_depths_border(vec3 depths)
-{
- return any(lessThan(depths, vec3(1.0/DEPTH_RATIO_THRESHOLD)))
- || any(greaterThan(depths, vec3(DEPTH_RATIO_THRESHOLD)));
-}
-
-vec3
-normal_sample(vec2 c)
-{
- return texture2D(normalmap, c).xyz;
-}
-
-float
-min6(float a, float b, float c, float d, float e, float f)
-{
- return min(min(min(min(min(a, b), c), d), e), f);
-}
-
-float
-border_factor(vec2 c)
-{
- vec2 coord1 = c + vec2(-SAMPLE_SPREAD, -SAMPLE_SPREAD),
- coord2 = c + vec2( SAMPLE_SPREAD, -SAMPLE_SPREAD),
- coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD),
- coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD);
-
- vec3 normal1 = normal_sample(coord1),
- normal2 = normal_sample(coord2),
- normal3 = normal_sample(coord3),
- normal4 = normal_sample(coord4);
-
- if (dot(normal1, normal1) < 0.5
- && dot(normal2, normal2) < 0.5
- && dot(normal3, normal3) < 0.5
- && dot(normal4, normal4) < 0.5) {
- return 0.0;
- } else {
- vec4 depths = vec4(depth_sample(coord1),
- depth_sample(coord2),
- depth_sample(coord3),
- depth_sample(coord4));
-
- vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww;
-
- if (are_depths_border(ratios1) || are_depths_border(ratios2)) {
- return 1.0;
- } else {
- float normal_border = 1.0 - min6(
- dot(normal1, normal2),
- dot(normal1, normal3),
- dot(normal1, normal4),
- dot(normal2, normal3),
- dot(normal2, normal4),
- dot(normal3, normal4)
- );
-
- return normal_border;
- }
- }
-}
-
-void
-main()
-{
- gl_FragColor = mix(texture2D(colormap, coord), line_color, border_factor(coord));
-}
-
-;
-
-: (line-art-step1-program) ( -- step1 )
- line-art-step1-vertex-shader-source line-art-step1-fragment-shader-source
- <simple-gl-program> ;
-: (line-art-step2-program) ( -- step2 )
- line-art-step2-vertex-shader-source line-art-step2-fragment-shader-source
- <simple-gl-program> ;
-
-: (line-art-framebuffer-texture) ( dim iformat xformat -- texture )
- swapd >r >r >r
- GL_TEXTURE0 glActiveTexture
- gen-texture GL_TEXTURE_2D over glBindTexture
- GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
- GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
- GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
- GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
- GL_TEXTURE_2D 0 r> r> first2 0 r> GL_UNSIGNED_BYTE f glTexImage2D ;
-
-: (line-art-color-texture) ( dim -- texture )
- GL_RGBA16F_ARB GL_RGBA (line-art-framebuffer-texture) ;
-
-: (line-art-normal-texture) ( dim -- texture )
- GL_RGBA16F_ARB GL_RGBA (line-art-framebuffer-texture) ;
-
-: (line-art-depth-texture) ( dim -- texture )
- GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (line-art-framebuffer-texture) ;
-
-: (attach-framebuffer-texture) ( texture attachment -- )
- swap >r >r GL_FRAMEBUFFER_EXT r> GL_TEXTURE_2D r> 0 glFramebufferTexture2DEXT gl-error ;
-
-: (line-art-framebuffer) ( color-texture normal-texture depth-texture -- framebuffer )
- 3array gen-framebuffer dup [
- swap GL_COLOR_ATTACHMENT0_EXT
- GL_COLOR_ATTACHMENT1_EXT
- GL_DEPTH_ATTACHMENT_EXT 3array [ (attach-framebuffer-texture) ] 2each
- check-framebuffer
- ] with-framebuffer ;
-
-: line-art-remake-framebuffer-if-needed ( gadget -- )
- dup { rect-dim rect-dim line-art-gadget-framebuffer-dim } get-slots = [ 2drop ] [
- swap >r
- dup (line-art-color-texture) gl-error
- swap dup (line-art-normal-texture) gl-error
- swap dup (line-art-depth-texture) gl-error
- swap >r
- [ (line-art-framebuffer) ] 3keep
- r> r> { set-line-art-gadget-framebuffer
- set-line-art-gadget-color-texture
- set-line-art-gadget-normal-texture
- set-line-art-gadget-depth-texture
- set-line-art-gadget-framebuffer-dim } set-slots
- ] if ;
-
-M: line-art-gadget graft* ( gadget -- )
- "2.0" { "GL_ARB_draw_buffers"
- "GL_ARB_shader_objects"
- "GL_ARB_multitexture"
- "GL_ARB_texture_float" }
- require-gl-version-or-extensions
- { "GL_EXT_framebuffer_object" } require-gl-extensions
- GL_CULL_FACE glEnable
- GL_DEPTH_TEST glEnable
- (line-art-step1-program) over set-line-art-gadget-step1-program
- (line-art-step2-program) swap set-line-art-gadget-step2-program ;
-
-M: line-art-gadget ungraft* ( gadget -- )
- dup line-art-gadget-framebuffer [
- { [ line-art-gadget-step1-program [ delete-gl-program ] when* ]
- [ line-art-gadget-step2-program [ delete-gl-program ] when* ]
- [ line-art-gadget-framebuffer [ delete-framebuffer ] when* ]
- [ line-art-gadget-color-texture [ delete-texture ] when* ]
- [ line-art-gadget-normal-texture [ delete-texture ] when* ]
- [ line-art-gadget-depth-texture [ delete-texture ] when* ]
- [ f swap set-line-art-gadget-framebuffer-dim ]
- [ f swap set-line-art-gadget-framebuffer ] } call-with
- ] [ drop ] if ;
-
-: line-art-draw-setup ( gadget -- gadget )
- 0.0 0.0 0.0 1.0 glClearColor
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- dup demo-gadget-set-matrices
- dup line-art-remake-framebuffer-if-needed
- gl-error ;
-
-: line-art-clear-framebuffer ( -- )
- GL_COLOR_ATTACHMENT0_EXT glDrawBuffer
- 0.2 0.2 0.2 1.0 glClearColor
- GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
- GL_COLOR_ATTACHMENT1_EXT glDrawBuffer
- 0.0 0.0 0.0 0.0 glClearColor
- GL_COLOR_BUFFER_BIT glClear ;
-
-M: line-art-gadget draw-gadget* ( gadget -- )
- line-art-draw-setup
- dup line-art-gadget-framebuffer [
- line-art-clear-framebuffer
- { GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
- dup line-art-gadget-step1-program dup [
- "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f
- 0.0 -0.12 0.0 glTranslatef
- dup line-art-gadget-model first3 draw-bunny
- ] with-gl-program
- ] with-framebuffer
- init-matrices
- dup line-art-gadget-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
- dup line-art-gadget-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit
- dup line-art-gadget-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit
- line-art-gadget-step2-program dup [
- { [ "colormap" glGetUniformLocation 0 glUniform1i ]
- [ "normalmap" glGetUniformLocation 1 glUniform1i ]
- [ "depthmap" glGetUniformLocation 2 glUniform1i ]
- [ "line_color" glGetUniformLocation 0.2 0.0 0.0 1.0 glUniform4f ] } call-with
- { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
- ] with-gl-program ;
-
-: line-art-window ( -- )
- [ <line-art-gadget> "Line Art" open-window ] with-ui ;
-
-MAIN: line-art-window
diff --git a/extra/opengl-demo-support/authors.txt b/extra/opengl/demo-support/authors.txt
similarity index 100%
rename from extra/opengl-demo-support/authors.txt
rename to extra/opengl/demo-support/authors.txt
diff --git a/extra/opengl-demo-support/opengl-demo-support.factor b/extra/opengl/demo-support/demo-support.factor
similarity index 99%
rename from extra/opengl-demo-support/opengl-demo-support.factor
rename to extra/opengl/demo-support/demo-support.factor
index ecc6458d41..59b7a3bcc3 100644
--- a/extra/opengl-demo-support/opengl-demo-support.factor
+++ b/extra/opengl/demo-support/demo-support.factor
@@ -1,6 +1,6 @@
USING: arrays combinators.lib kernel math math.functions math.vectors namespaces
opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ;
-IN: opengl-demo-support
+IN: opengl.demo-support
: NEAR-PLANE 1.0 64.0 / ; inline
: FAR-PLANE 4.0 ; inline
diff --git a/extra/opengl-demo-support/summary.txt b/extra/opengl/demo-support/summary.txt
similarity index 100%
rename from extra/opengl-demo-support/summary.txt
rename to extra/opengl/demo-support/summary.txt
diff --git a/extra/opengl-demo-support/tags.txt b/extra/opengl/demo-support/tags.txt
similarity index 100%
rename from extra/opengl-demo-support/tags.txt
rename to extra/opengl/demo-support/tags.txt
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index a6aecf1b77..9b26662cef 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -444,8 +444,11 @@ PREDICATE: integer gl-program (gl-program?) ;
[ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
(require-gl) ;
+: has-gl-version-or-extensions? ( version extensions -- ? )
+ has-gl-extensions? swap has-gl-version? or ;
+
: require-gl-version-or-extensions ( version extensions -- )
- 2array [ first2 has-gl-extensions? swap has-gl-version? or ]
- [ dup first (make-gl-version-error) "\n" %
- second (make-gl-extensions-error) "\n" % ]
- (require-gl) ;
+ 2array [ first2 has-gl-version-or-extensions? ] [
+ dup first (make-gl-version-error) "\n" %
+ second (make-gl-extensions-error) "\n" %
+ ] (require-gl) ;
From ae51681750da901134dfc6fc0de3ad948fc22999 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 2 Feb 2008 14:24:03 -0800
Subject: [PATCH 16/52] Fix has-gl-extensions? when requested extensions are
not contiguous in the gl-extensions string
---
extra/opengl/opengl.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index e000a3103e..d26c2c7685 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -401,7 +401,7 @@ PREDICATE: integer gl-program (gl-program?) ;
: gl-extensions ( -- seq )
GL_EXTENSIONS glGetString " " split ;
: has-gl-extensions? ( extensions -- ? )
- gl-extensions subseq? ;
+ gl-extensions swap [ over member? ] all? nip ;
: (make-gl-extensions-error) ( required-extensions -- )
gl-extensions swap seq-diff
"Required OpenGL extensions not supported:\n" %
From 7da1da5fff0e539fefd5772b891977f283639d65 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 2 Feb 2008 15:33:05 -0800
Subject: [PATCH 17/52] Modularize the new bunny demo, and adjust the bikeshed
parameters a bit
---
extra/bunny/cel-shaded/cel-shaded.factor | 95 +++++++
.../fixed-pipeline/fixed-pipeline.factor | 25 ++
extra/bunny/model/model.factor | 114 +++++++++
extra/bunny/outlined/outlined.factor | 235 ++++++++++++++++++
4 files changed, 469 insertions(+)
create mode 100644 extra/bunny/cel-shaded/cel-shaded.factor
create mode 100644 extra/bunny/fixed-pipeline/fixed-pipeline.factor
create mode 100644 extra/bunny/model/model.factor
create mode 100644 extra/bunny/outlined/outlined.factor
diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor
new file mode 100644
index 0000000000..eb0924f50e
--- /dev/null
+++ b/extra/bunny/cel-shaded/cel-shaded.factor
@@ -0,0 +1,95 @@
+USING: arrays bunny.model combinators.lib continuations
+kernel multiline opengl opengl.gl sequences ;
+IN: bunny.cel-shaded
+
+STRING: vertex-shader-source
+varying vec3 position, normal, viewer;
+
+void
+main()
+{
+ gl_Position = ftransform();
+
+ position = gl_Vertex.xyz;
+ normal = gl_Normal;
+ viewer = vec3(0, 0, 1) * gl_NormalMatrix;
+}
+
+;
+
+STRING: cel-shaded-fragment-shader-lib-source
+varying vec3 position, normal, viewer;
+uniform vec3 light_direction;
+uniform vec4 color;
+uniform vec4 ambient, diffuse;
+uniform float shininess;
+
+float
+modulate(vec3 direction, vec3 normal)
+{
+ return dot(direction, normal) * 0.5 + 0.5;
+}
+
+float
+cel(float m)
+{
+ return smoothstep(0.25, 0.255, m) * 0.4 + smoothstep(0.695, 0.70, m) * 0.5;
+}
+
+vec4
+cel_light()
+{
+ vec3 direction = normalize(light_direction - position);
+ vec3 reflection = reflect(direction, normal);
+ vec4 ad = (ambient + diffuse * vec4(vec3(cel(modulate(direction, normal))), 1));
+ float s = cel(pow(max(dot(-reflection, viewer), 0.0), shininess));
+ return ad * color + vec4(vec3(s), 0);
+}
+
+;
+
+STRING: cel-shaded-fragment-shader-main-source
+vec4 cel_light();
+
+void
+main()
+{
+ gl_FragColor = cel_light();
+}
+
+;
+
+TUPLE: bunny-cel-shaded program ;
+
+: cel-shading-supported? ( -- ? )
+ "2.0" { "GL_ARB_shader_objects" }
+ has-gl-version-or-extensions? ;
+
+: <bunny-cel-shaded> ( gadget -- draw )
+ drop
+ cel-shading-supported? [
+ vertex-shader-source <vertex-shader> check-gl-shader
+ cel-shaded-fragment-shader-lib-source <fragment-shader> check-gl-shader
+ cel-shaded-fragment-shader-main-source <fragment-shader> check-gl-shader
+ 3array <gl-program> check-gl-program
+ { set-bunny-cel-shaded-program } bunny-cel-shaded construct
+ ] [ f ] if ;
+
+: (draw-cel-shaded-bunny) ( geom program -- )
+ dup [
+ {
+ [ "light_direction" glGetUniformLocation 1.0 -1.0 1.0 glUniform3f ]
+ [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
+ [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
+ [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ]
+ [ "shininess" glGetUniformLocation 100.0 glUniform1f ]
+ } call-with
+ bunny-geom
+ ] with-gl-program ;
+
+M: bunny-cel-shaded draw-bunny
+ bunny-cel-shaded-program (draw-cel-shaded-bunny) ;
+
+M: bunny-cel-shaded dispose
+ bunny-cel-shaded-program delete-gl-program ;
+
diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor
new file mode 100644
index 0000000000..f3fb68e515
--- /dev/null
+++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor
@@ -0,0 +1,25 @@
+USING: alien.c-types continuations kernel
+opengl opengl.gl bunny.model ;
+IN: bunny.fixed-pipeline
+
+TUPLE: bunny-fixed-pipeline ;
+
+: <bunny-fixed-pipeline> ( gadget -- draw )
+ drop
+ { } bunny-fixed-pipeline construct ;
+
+M: bunny-fixed-pipeline draw-bunny
+ drop
+ GL_LIGHTING glEnable
+ GL_LIGHT0 glEnable
+ GL_COLOR_MATERIAL glEnable
+ GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv
+ GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf
+ GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial
+ GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial
+ 0.6 0.5 0.5 1.0 glColor4f
+ bunny-geom ;
+
+M: bunny-fixed-pipeline dispose
+ drop ;
+
diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
new file mode 100644
index 0000000000..a19adcb782
--- /dev/null
+++ b/extra/bunny/model/model.factor
@@ -0,0 +1,114 @@
+USING: alien alien.c-types arrays sequences math
+math.vectors math.matrices math.parser io io.files kernel opengl
+opengl.gl opengl.glu shuffle http.client vectors splitting
+tools.time system combinators combinators.lib combinators.cleave
+float-arrays continuations namespaces ;
+IN: bunny.model
+
+: numbers ( str -- seq )
+ " " split [ string>number ] map [ ] subset ;
+
+: (parse-model) ( vs is -- vs is )
+ readln [
+ numbers {
+ { [ dup length 5 = ] [ 3 head pick push ] }
+ { [ dup first 3 = ] [ 1 tail over push ] }
+ { [ t ] [ drop ] }
+ } cond (parse-model)
+ ] when* ;
+
+: parse-model ( stream -- vs is )
+ [
+ 100000 <vector> 100000 <vector> (parse-model)
+ ] with-stream
+ [
+ over length # " vertices, " %
+ dup length # " triangles" %
+ ] "" make print ;
+
+: n ( vs triple -- n )
+ swap [ nth ] curry map
+ dup third over first v- >r dup second swap first v- r> cross
+ vneg normalize ;
+
+: normal ( ns vs triple -- )
+ [ n ] keep [ rot [ v+ ] change-nth ] each-with2 ;
+
+: normals ( vs is -- ns )
+ over length { 0.0 0.0 0.0 } <array> -rot
+ [ >r 2dup r> normal ] each drop
+ [ normalize ] map ;
+
+: read-model ( stream -- model )
+ "Reading model" print flush [
+ <file-reader> parse-model [ normals ] 2keep 3array
+ ] time ;
+
+: model-path "bun_zipper.ply" ;
+
+: model-url "http://factorcode.org/bun_zipper.ply" ;
+
+: maybe-download ( -- path )
+ model-path resource-path dup exists? [
+ "Downloading bunny from " write
+ model-url dup print flush
+ over download-to
+ ] unless ;
+
+: (draw-triangle) ( ns vs triple -- )
+ [ dup roll nth gl-normal swap nth gl-vertex ] each-with2 ;
+
+: draw-triangles ( ns vs is -- )
+ GL_TRIANGLES [ [ (draw-triangle) ] each-with2 ] do-state ;
+
+TUPLE: bunny-dlist list ;
+TUPLE: bunny-buffers array element-array nv ni ;
+
+: <bunny-dlist> ( model -- geom )
+ GL_COMPILE [ first3 draw-triangles ] make-dlist
+ bunny-dlist construct-boa ;
+
+: <bunny-buffers> ( model -- geom )
+ [
+ [ first concat ] [ second concat ] bi
+ append >float-array
+ GL_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
+ ] [
+ third concat >c-uint-array
+ GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW <gl-buffer>
+ ]
+ [ first length 3 * ] [ third length 3 * ] tetra
+ bunny-buffers construct-boa ;
+
+GENERIC: bunny-geom ( geom -- )
+GENERIC: draw-bunny ( geom draw -- )
+
+M: bunny-dlist bunny-geom
+ bunny-dlist-list glCallList ;
+
+M: bunny-buffers bunny-geom
+ dup {
+ bunny-buffers-array
+ bunny-buffers-element-array
+ } get-slots [
+ GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [
+ GL_DOUBLE 0 0 buffer-offset glNormalPointer
+ dup bunny-buffers-nv "double" heap-size * buffer-offset
+ 3 GL_DOUBLE 0 roll glVertexPointer
+ bunny-buffers-ni
+ GL_TRIANGLES swap GL_UNSIGNED_INT 0 buffer-offset glDrawElements
+ ] all-enabled-client-state
+ ] with-array-element-buffers ;
+
+M: bunny-dlist dispose
+ bunny-dlist-list delete-dlist ;
+
+M: bunny-buffers dispose
+ { bunny-buffers-array bunny-buffers-element-array } get-slots
+ delete-gl-buffer delete-gl-buffer ;
+
+: <bunny-geom> ( model -- geom )
+ "1.5" { "GL_ARB_vertex_buffer_object" }
+ has-gl-version-or-extensions?
+ [ <bunny-buffers> ] [ <bunny-dlist> ] if ;
+
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
new file mode 100644
index 0000000000..021ac6b4d8
--- /dev/null
+++ b/extra/bunny/outlined/outlined.factor
@@ -0,0 +1,235 @@
+USING: arrays bunny.model bunny.cel-shaded
+combinators.lib continuations kernel math multiline
+opengl opengl.gl sequences ui.gadgets ;
+IN: bunny.outlined
+
+STRING: outlined-pass1-fragment-shader-main-source
+varying vec3 normal;
+vec4 cel_light();
+
+void
+main()
+{
+ gl_FragData[0] = cel_light();
+ gl_FragData[1] = vec4(normal, 1);
+}
+
+;
+
+STRING: outlined-pass2-vertex-shader-source
+varying vec2 coord;
+
+void
+main()
+{
+ gl_Position = ftransform();
+ coord = (gl_Vertex * vec4(0.5) + vec4(0.5)).xy;
+}
+
+;
+
+STRING: outlined-pass2-fragment-shader-source
+uniform sampler2D colormap, normalmap, depthmap;
+uniform vec4 line_color;
+varying vec2 coord;
+
+const float DEPTH_RATIO_THRESHOLD = 1.001, SAMPLE_SPREAD = 1.0/512.0;
+
+float
+depth_sample(vec2 c)
+{
+ return texture2D(depthmap, c).x;
+}
+bool
+are_depths_border(vec3 depths)
+{
+ return any(lessThan(depths, vec3(1.0/DEPTH_RATIO_THRESHOLD)))
+ || any(greaterThan(depths, vec3(DEPTH_RATIO_THRESHOLD)));
+}
+
+vec3
+normal_sample(vec2 c)
+{
+ return texture2D(normalmap, c).xyz;
+}
+
+float
+min6(float a, float b, float c, float d, float e, float f)
+{
+ return min(min(min(min(min(a, b), c), d), e), f);
+}
+
+float
+border_factor(vec2 c)
+{
+ vec2 coord1 = c + vec2(-SAMPLE_SPREAD, -SAMPLE_SPREAD),
+ coord2 = c + vec2( SAMPLE_SPREAD, -SAMPLE_SPREAD),
+ coord3 = c + vec2(-SAMPLE_SPREAD, SAMPLE_SPREAD),
+ coord4 = c + vec2( SAMPLE_SPREAD, SAMPLE_SPREAD);
+
+ vec3 normal1 = normal_sample(coord1),
+ normal2 = normal_sample(coord2),
+ normal3 = normal_sample(coord3),
+ normal4 = normal_sample(coord4);
+
+ if (dot(normal1, normal1) < 0.5
+ && dot(normal2, normal2) < 0.5
+ && dot(normal3, normal3) < 0.5
+ && dot(normal4, normal4) < 0.5) {
+ return 0.0;
+ } else {
+ vec4 depths = vec4(depth_sample(coord1),
+ depth_sample(coord2),
+ depth_sample(coord3),
+ depth_sample(coord4));
+
+ vec3 ratios1 = depths.xxx/depths.yzw, ratios2 = depths.yyz/depths.zww;
+
+ if (are_depths_border(ratios1) || are_depths_border(ratios2)) {
+ return 1.0;
+ } else {
+ float normal_border = 1.0 - min6(
+ dot(normal1, normal2),
+ dot(normal1, normal3),
+ dot(normal1, normal4),
+ dot(normal2, normal3),
+ dot(normal2, normal4),
+ dot(normal3, normal4)
+ );
+
+ return normal_border;
+ }
+ }
+}
+
+void
+main()
+{
+ gl_FragColor = mix(texture2D(colormap, coord), line_color, border_factor(coord));
+}
+
+;
+
+TUPLE: bunny-outlined
+ gadget
+ pass1-program pass2-program
+ color-texture normal-texture depth-texture
+ framebuffer framebuffer-dim ;
+
+: outlining-supported? ( -- ? )
+ "2.0" {
+ "GL_ARB_shading_objects"
+ "GL_ARB_draw_buffers"
+ "GL_ARB_multitexture"
+ } has-gl-version-or-extensions? {
+ "GL_EXT_framebuffer_object"
+ "GL_ARB_texture_float"
+ } has-gl-extensions? and ;
+
+: pass1-program ( -- program )
+ vertex-shader-source <vertex-shader> check-gl-shader
+ cel-shaded-fragment-shader-lib-source <fragment-shader> check-gl-shader
+ outlined-pass1-fragment-shader-main-source <fragment-shader> check-gl-shader
+ 3array <gl-program> check-gl-program ;
+
+: pass2-program ( -- program )
+ outlined-pass2-vertex-shader-source
+ outlined-pass2-fragment-shader-source <simple-gl-program> ;
+
+: <bunny-outlined> ( gadget -- draw )
+ outlining-supported? [
+ pass1-program pass2-program {
+ set-bunny-outlined-gadget
+ set-bunny-outlined-pass1-program
+ set-bunny-outlined-pass2-program
+ } bunny-outlined construct
+ ] [ drop f ] if ;
+
+: (framebuffer-texture) ( dim iformat xformat -- texture )
+ swapd >r >r >r
+ GL_TEXTURE0 glActiveTexture
+ gen-texture GL_TEXTURE_2D over glBindTexture
+ GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_CLAMP glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_CLAMP glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_MAG_FILTER GL_NEAREST glTexParameteri
+ GL_TEXTURE_2D GL_TEXTURE_MIN_FILTER GL_NEAREST glTexParameteri
+ GL_TEXTURE_2D 0 r> r> first2 0 r> GL_UNSIGNED_BYTE f glTexImage2D ;
+
+: (attach-framebuffer-texture) ( texture attachment -- )
+ swap >r >r
+ GL_FRAMEBUFFER_EXT r> GL_TEXTURE_2D r> 0 glFramebufferTexture2DEXT
+ gl-error ;
+
+: (make-framebuffer) ( color-texture normal-texture depth-texture -- framebuffer )
+ 3array gen-framebuffer dup [
+ swap GL_COLOR_ATTACHMENT0_EXT
+ GL_COLOR_ATTACHMENT1_EXT
+ GL_DEPTH_ATTACHMENT_EXT 3array [ (attach-framebuffer-texture) ] 2each
+ check-framebuffer
+ ] with-framebuffer ;
+
+: remake-framebuffer-if-needed ( draw -- )
+ dup bunny-outlined-gadget rect-dim
+ over bunny-outlined-framebuffer-dim
+ over =
+ [ 2drop ]
+ [
+ swap >r
+ dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
+ swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
+ swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
+ swap >r
+ [ (make-framebuffer) ] 3keep
+ r> r> {
+ set-bunny-outlined-framebuffer
+ set-bunny-outlined-color-texture
+ set-bunny-outlined-normal-texture
+ set-bunny-outlined-depth-texture
+ set-bunny-outlined-framebuffer-dim
+ } set-slots
+ ] if ;
+
+: clear-framebuffer ( -- )
+ GL_COLOR_ATTACHMENT0_EXT glDrawBuffer
+ 0.15 0.15 0.15 1.0 glClearColor
+ GL_COLOR_BUFFER_BIT GL_DEPTH_BUFFER_BIT bitor glClear
+ GL_COLOR_ATTACHMENT1_EXT glDrawBuffer
+ 0.0 0.0 0.0 0.0 glClearColor
+ GL_COLOR_BUFFER_BIT glClear ;
+
+: (pass1) ( geom draw -- )
+ dup bunny-outlined-framebuffer [
+ clear-framebuffer
+ { GL_COLOR_ATTACHMENT0_EXT GL_COLOR_ATTACHMENT1_EXT } set-draw-buffers
+ bunny-outlined-pass1-program (draw-cel-shaded-bunny)
+ ] with-framebuffer ;
+
+: (pass2) ( draw -- )
+ init-matrices
+ dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
+ dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit
+ dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit
+ bunny-outlined-pass2-program dup [
+ {
+ [ "colormap" glGetUniformLocation 0 glUniform1i ]
+ [ "normalmap" glGetUniformLocation 1 glUniform1i ]
+ [ "depthmap" glGetUniformLocation 2 glUniform1i ]
+ [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ]
+ } call-with
+ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
+ ] with-gl-program ;
+
+M: bunny-outlined draw-bunny
+ dup remake-framebuffer-if-needed
+ [ (pass1) ] keep (pass2) ;
+
+M: bunny-outlined dispose
+ {
+ [ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
+ [ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
+ [ bunny-outlined-framebuffer [ delete-framebuffer ] when* ]
+ [ bunny-outlined-color-texture [ delete-texture ] when* ]
+ [ bunny-outlined-normal-texture [ delete-texture ] when* ]
+ [ bunny-outlined-depth-texture [ delete-texture ] when* ]
+ [ f swap set-bunny-outlined-framebuffer-dim ]
+ } call-with ;
From 4e4e4ee157fce3dc3daa8e6a4861897065cad78b Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sat, 2 Feb 2008 18:15:22 -0800
Subject: [PATCH 18/52] Make setting up shader uniform parameters nicer from
with-gl-program
---
extra/bunny/bunny.factor | 4 ---
extra/bunny/cel-shaded/cel-shaded.factor | 17 +++++-------
extra/bunny/outlined/outlined.factor | 34 +++++++++++++-----------
extra/opengl/opengl-docs.factor | 25 +++++++++++++----
extra/opengl/opengl.factor | 18 +++++++++++--
5 files changed, 62 insertions(+), 36 deletions(-)
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index efebefcef3..38f8e32fb6 100755
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -8,10 +8,6 @@ ui.gestures
bunny.fixed-pipeline bunny.cel-shaded bunny.outlined bunny.model ;
IN: bunny
-<PRIVATE
-
-PRIVATE>
-
TUPLE: bunny-gadget model geom draw-seq draw-n ;
: <bunny-gadget> ( -- bunny-gadget )
diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor
index eb0924f50e..fc42ca971e 100644
--- a/extra/bunny/cel-shaded/cel-shaded.factor
+++ b/extra/bunny/cel-shaded/cel-shaded.factor
@@ -76,16 +76,13 @@ TUPLE: bunny-cel-shaded program ;
] [ f ] if ;
: (draw-cel-shaded-bunny) ( geom program -- )
- dup [
- {
- [ "light_direction" glGetUniformLocation 1.0 -1.0 1.0 glUniform3f ]
- [ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
- [ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
- [ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ]
- [ "shininess" glGetUniformLocation 100.0 glUniform1f ]
- } call-with
- bunny-geom
- ] with-gl-program ;
+ {
+ { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
+ { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
+ { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
+ { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
+ { "shininess" [ 100.0 glUniform1f ] }
+ } [ bunny-geom ] with-gl-program ;
M: bunny-cel-shaded draw-bunny
bunny-cel-shaded-program (draw-cel-shaded-bunny) ;
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index 021ac6b4d8..9de341561c 100644
--- a/extra/bunny/outlined/outlined.factor
+++ b/extra/bunny/outlined/outlined.factor
@@ -168,13 +168,24 @@ TUPLE: bunny-outlined
check-framebuffer
] with-framebuffer ;
+: dispose-framebuffer ( draw -- )
+ dup bunny-outlined-framebuffer-dim [
+ {
+ [ bunny-outlined-framebuffer [ delete-framebuffer ] when* ]
+ [ bunny-outlined-color-texture [ delete-texture ] when* ]
+ [ bunny-outlined-normal-texture [ delete-texture ] when* ]
+ [ bunny-outlined-depth-texture [ delete-texture ] when* ]
+ [ f swap set-bunny-outlined-framebuffer-dim ]
+ } call-with
+ ] [ drop ] if ;
+
: remake-framebuffer-if-needed ( draw -- )
dup bunny-outlined-gadget rect-dim
over bunny-outlined-framebuffer-dim
over =
[ 2drop ]
[
- swap >r
+ swap dup dispose-framebuffer >r
dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
swap dup GL_RGBA16F_ARB GL_RGBA (framebuffer-texture)
swap dup GL_DEPTH_COMPONENT32 GL_DEPTH_COMPONENT (framebuffer-texture)
@@ -209,15 +220,12 @@ TUPLE: bunny-outlined
dup bunny-outlined-color-texture GL_TEXTURE_2D GL_TEXTURE0 bind-texture-unit
dup bunny-outlined-normal-texture GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit
dup bunny-outlined-depth-texture GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit
- bunny-outlined-pass2-program dup [
- {
- [ "colormap" glGetUniformLocation 0 glUniform1i ]
- [ "normalmap" glGetUniformLocation 1 glUniform1i ]
- [ "depthmap" glGetUniformLocation 2 glUniform1i ]
- [ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ]
- } call-with
- { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
- ] with-gl-program ;
+ bunny-outlined-pass2-program {
+ { "colormap" [ 0 glUniform1i ] }
+ { "normalmap" [ 1 glUniform1i ] }
+ { "depthmap" [ 2 glUniform1i ] }
+ { "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
+ } [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ] with-gl-program ;
M: bunny-outlined draw-bunny
dup remake-framebuffer-if-needed
@@ -227,9 +235,5 @@ M: bunny-outlined dispose
{
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
- [ bunny-outlined-framebuffer [ delete-framebuffer ] when* ]
- [ bunny-outlined-color-texture [ delete-texture ] when* ]
- [ bunny-outlined-normal-texture [ delete-texture ] when* ]
- [ bunny-outlined-depth-texture [ delete-texture ] when* ]
- [ f swap set-bunny-outlined-framebuffer-dim ]
+ [ dispose-framebuffer ]
} call-with ;
diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor
index 63875e91a8..cb0c9e884f 100644
--- a/extra/opengl/opengl-docs.factor
+++ b/extra/opengl/opengl-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax io kernel math quotations
-opengl.gl ;
+opengl.gl multiline assocs ;
IN: opengl
HELP: gl-color
@@ -241,8 +241,19 @@ HELP: delete-gl-program
{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
HELP: with-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation" } }
-{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
+{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } }
+{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack for the associated quotation.\n\nExample:" }
+{ $code <"
+! From bunny.cel-shaded
+: (draw-cel-shaded-bunny) ( geom program -- )
+ {
+ { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
+ { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
+ { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
+ { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
+ { "shininess" [ 100.0 glUniform1f ] }
+ } [ bunny-geom ] with-gl-program ;
+"> } ;
HELP: gl-version
{ $values { "version" "The version string from the OpenGL implementation" } }
@@ -284,15 +295,19 @@ HELP: has-gl-extensions?
{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
+HELP: has-gl-version-or-extensions?
+{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
+{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
+
HELP: require-gl-extensions
{ $values { "extensions" "A sequence of extension name strings" } }
{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
HELP: require-gl-version-or-extensions
{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
-{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version, or a set of equivalent extensions." } ;
+{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
-{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? gl-version glsl-version gl-extensions } related-words
+{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words
ARTICLE: "gl-utilities" "OpenGL utility words"
"In addition to the full OpenGL API, the " { $vocab-link "opengl" } " vocabulary includes some utility words to give OpenGL a more Factor-like feel."
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index d26c2c7685..071f85fe12 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -5,7 +5,7 @@
USING: alien alien.c-types continuations kernel libc math macros
namespaces math.vectors math.constants math.functions
math.parser opengl.gl opengl.glu combinators arrays sequences
-splitting words byte-arrays assocs ;
+splitting words byte-arrays assocs combinators.lib ;
IN: opengl
: coordinates [ first2 ] 2apply ;
@@ -382,9 +382,23 @@ PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
2dup detach-gl-program-shader delete-gl-shader
] each delete-gl-program-only ;
-: with-gl-program ( program quot -- )
+: (with-gl-program) ( program quot -- )
swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
+: (with-gl-program-uniforms) ( uniforms -- quot )
+ [ [ swap , \ glGetUniformLocation , % ] [ ] make ]
+ { } assoc>map ;
+: (make-with-gl-program) ( uniforms quot -- q )
+ [
+ \ dup ,
+ [ swap (with-gl-program-uniforms) , \ call-with , % ]
+ [ ] make ,
+ \ (with-gl-program) ,
+ ] [ ] make ;
+
+MACRO: with-gl-program ( uniforms quot -- )
+ (make-with-gl-program) ;
+
PREDICATE: integer gl-program (gl-program?) ;
: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
From 7ad7a89a2bb47412252d4bcb47c9b4b7e31e3df2 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@laptop.(none)>
Date: Sat, 2 Feb 2008 23:27:27 -0600
Subject: [PATCH 19/52] move >Upper and >Upper-dashes to unicode.case
---
extra/strings/lib/lib.factor | 8 --------
extra/unicode/case/case.factor | 11 ++++++++++-
2 files changed, 10 insertions(+), 9 deletions(-)
diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor
index 719881b768..d0a34c8d28 100644
--- a/extra/strings/lib/lib.factor
+++ b/extra/strings/lib/lib.factor
@@ -4,11 +4,3 @@ IN: strings.lib
! : char>digit ( c -- i ) 48 - ;
! : string>digits ( s -- seq ) [ char>digit ] { } map-as ;
-
-! : >Upper ( str -- str )
-! dup empty? [
-! unclip ch>upper 1string swap append
-! ] unless ;
-
-! : >Upper-dashes ( str -- str )
-! "-" split [ >Upper ] map "-" join ;
diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor
index ee9e2a0381..f244192a32 100755
--- a/extra/unicode/case/case.factor
+++ b/extra/unicode/case/case.factor
@@ -1,6 +1,6 @@
USING: kernel unicode.data sequences sequences.next namespaces
assocs.lib unicode.normalize math unicode.categories combinators
-assocs ;
+assocs strings splitting ;
IN: unicode.case
: ch>lower ( ch -- lower ) simple-lower at-default ;
@@ -110,3 +110,12 @@ SYMBOL: locale ! Just casing locale, or overall?
dup >title = ;
: case-fold? ( string -- ? )
dup >case-fold = ;
+
+
+: >Upper ( str -- str )
+ dup empty? [
+ unclip ch>upper 1string swap append
+ ] unless ;
+
+: >Upper-dashes ( str -- str )
+ "-" split [ >Upper ] map "-" join ;
From 7954bc33bfec8694e0d619b59c07215b98548a70 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@laptop.(none)>
Date: Sat, 2 Feb 2008 23:27:44 -0600
Subject: [PATCH 20/52] fix server responders
---
extra/http/server/responders/responders.factor | 12 ++++++------
1 file changed, 6 insertions(+), 6 deletions(-)
diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor
index a507a95a14..6df52997e1 100644
--- a/extra/http/server/responders/responders.factor
+++ b/extra/http/server/responders/responders.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs hashtables html html.elements splitting
http io kernel math math.parser namespaces parser sequences
-strings io.server vectors vector-hash strings.lib ;
+strings io.server vectors assocs.lib unicode.case ;
IN: http.server.responders
@@ -10,11 +10,11 @@ IN: http.server.responders
SYMBOL: vhosts
SYMBOL: responders
-: >header ( value key -- vector-hash )
- VH{ } clone [ set-at ] keep ;
+: >header ( value key -- multi-hash )
+ H{ } clone [ insert-at ] keep ;
: print-header ( alist -- )
- [ swap >Upper-dashes write ": " write print ] vector-hash-each nl ;
+ [ swap >Upper-dashes write ": " write print ] multi-assoc-each nl ;
: response ( msg -- ) "HTTP/1.0 " write print ;
@@ -23,7 +23,7 @@ SYMBOL: responders
: error-head ( error -- )
dup log-error response
- VH{ { "Content-Type" "text/html" } } print-header nl ;
+ H{ { "Content-Type" V{ "text/html" } } } print-header nl ;
: httpd-error ( error -- )
#! This must be run from handle-request
@@ -94,7 +94,7 @@ SYMBOL: max-post-request
} member?
] assoc-subset [
": " swap 3append log-message
- ] vector-hash-each ;
+ ] multi-assoc-each ;
: prepare-url ( url -- url )
#! This is executed in the with-request namespace.
From 2c1bad2254b67b11b4780e537a832580dcdd1660 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@laptop.(none)>
Date: Sat, 2 Feb 2008 23:28:33 -0600
Subject: [PATCH 21/52] improve the db protocol and update sqlite to use it
---
extra/db/db.factor | 58 ++++++++++++++-------------
extra/db/postgresql/postgresql.factor | 47 ++++++++++++----------
extra/db/sqlite/sqlite-tests.factor | 41 +++++++++++--------
extra/db/sqlite/sqlite.factor | 49 ++++++++++++----------
4 files changed, 108 insertions(+), 87 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 597ac1f0f3..813ce901ff 100644
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -12,30 +12,20 @@ C: <db> db ( handle -- obj )
GENERIC: db-open ( db -- )
GENERIC: db-close ( db -- )
-TUPLE: statement sql params handle bound? n max ;
+TUPLE: statement sql params handle bound? ;
TUPLE: simple-statement ;
-TUPLE: bound-statement ;
TUPLE: prepared-statement ;
-TUPLE: prepared-bound-statement ;
HOOK: <simple-statement> db ( str -- statement )
-HOOK: <bound-statement> db ( str obj -- statement )
HOOK: <prepared-statement> db ( str -- statement )
-HOOK: <prepared-bound-statement> db ( str obj -- statement )
-
-! TUPLE: result sql params handle n max ;
-
-GENERIC: #rows ( statement -- n )
-GENERIC: #columns ( statement -- n )
-GENERIC# row-column 1 ( statement n -- obj )
-GENERIC: advance-row ( statement -- ? )
GENERIC: prepare-statement ( statement -- )
-GENERIC: reset-statement ( statement -- )
GENERIC: bind-statement* ( obj statement -- )
GENERIC: rebind-statement ( obj statement -- )
+GENERIC: execute-statement ( statement -- )
+
: bind-statement ( obj statement -- )
2dup dup statement-bound? [
rebind-statement
@@ -45,7 +35,24 @@ GENERIC: rebind-statement ( obj statement -- )
tuck set-statement-params
t swap set-statement-bound? ;
-: sql-row ( statement -- seq )
+TUPLE: result-set sql params handle n max ;
+
+GENERIC: query-results ( query -- result-set )
+
+GENERIC: #rows ( result-set -- n )
+GENERIC: #columns ( result-set -- n )
+GENERIC# row-column 1 ( result-set n -- obj )
+GENERIC: advance-row ( result-set -- ? )
+
+: <result-set> ( query handle tuple -- result-set )
+ >r >r { statement-sql statement-params } get-slots r>
+ {
+ set-result-set-sql
+ set-result-set-params
+ set-result-set-handle
+ } result-set construct r> construct-delegate ;
+
+: sql-row ( result-set -- seq )
dup #columns [ row-column ] with map ;
: query-each ( statement quot -- )
@@ -64,23 +71,20 @@ GENERIC: rebind-statement ( obj statement -- )
[ db swap with-variable ] curry with-disposal
] with-scope ;
-: do-statement ( statement -- )
- [ advance-row drop ] with-disposal ;
+: do-query ( query -- result-set )
+ query-results [ [ sql-row ] query-map ] with-disposal ;
-: do-query ( query -- rows )
- [ [ sql-row ] query-map ] with-disposal ;
+: do-bound-query ( obj query -- rows )
+ [ bind-statement ] keep do-query ;
-: do-simple-query ( sql -- rows )
- <simple-statement> do-query ;
+: do-bound-command ( obj query -- rows )
+ [ bind-statement ] keep execute-statement ;
-: do-bound-query ( sql obj -- rows )
- <bound-statement> do-query ;
+: sql-query ( sql -- rows )
+ <simple-statement> [ do-query ] with-disposal ;
-: do-simple-command ( sql -- )
- <simple-statement> do-statement ;
-
-: do-bound-command ( sql obj -- )
- <bound-statement> do-statement ;
+: sql-command ( sql -- )
+ <simple-statement> [ execute-statement ] with-disposal ;
SYMBOL: in-transaction
HOOK: begin-transaction db ( -- )
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index cd2c34682e..2ea1b3a1dc 100644
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -38,32 +38,41 @@ M: postgresql-db dispose ( db -- )
: with-postgresql ( host ust pass db quot -- )
>r <postgresql-db> r> with-disposal ;
-M: postgresql-statement #rows ( statement -- n )
+
+M: postgresql-result-set #rows ( statement -- n )
statement-handle PQntuples ;
-M: postgresql-statement #columns ( statement -- n )
+M: postgresql-result-set #columns ( statement -- n )
statement-handle PQnfields ;
-M: postgresql-statement row-column ( statement n -- obj )
+M: postgresql-result-set row-column ( statement n -- obj )
>r dup statement-handle swap statement-n r> PQgetvalue ;
-: init-statement ( statement -- )
- dup statement-max [
- dup do-postgresql-statement over set-statement-handle
- dup #rows over set-statement-max
- -1 over set-statement-n
+
+: init-result-set ( result-set -- )
+ dup result-set-max [
+ dup do-postgresql-statement over set-result-set-handle
+ dup #rows over set-result-set-max
+ -1 over set-result-set-n
] unless drop ;
-: increment-n ( statement -- n )
- dup statement-n 1+ dup rot set-statement-n ;
+: increment-n ( result-set -- n )
+ dup result-set-n 1+ dup rot set-result-set-n ;
+
+M: postgresql-result-set advance-row ( result-set -- ? )
+ dup init-result-set
+ dup increment-n swap result-set-max >= ;
-M: postgresql-statement advance-row ( statement -- ? )
- dup init-statement
- dup increment-n swap statement-max >= ;
M: postgresql-statement dispose ( query -- )
dup statement-handle PQclear
- 0 0 rot { set-statement-n set-statement-max } set-slots ;
+ f swap set-statement-handle ;
+
+M: postgresql-result-set dispose ( result-set -- )
+ dup result-set-handle PQclear
+ 0 0 f roll {
+ set-statement-n set-statement-max set-statement-handle
+ } set-slots ;
M: postgresql-statement prepare-statement ( statement -- )
[
@@ -76,12 +85,6 @@ M: postgresql-db <simple-statement> ( sql -- statement )
{ set-statement-sql } statement construct
<postgresql-statement> ;
-M: postgresql-db <bound-statement> ( sql array -- statement )
- { set-statement-sql set-statement-params } statement construct
- <postgresql-statement> ;
-
M: postgresql-db <prepared-statement> ( sql -- statement )
- ;
-
-M: postgresql-db <prepared-bound-statement> ( sql seq -- statement )
- ;
+ { set-statement-sql } statement construct
+ <postgresql-statement> ;
diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor
index 79e967de24..ef1bbfc262 100644
--- a/extra/db/sqlite/sqlite-tests.factor
+++ b/extra/db/sqlite/sqlite-tests.factor
@@ -26,20 +26,27 @@ IN: temporary
{ "John" "America" }
{ "Jane" "New Zealand" }
}
-] [ test.db [ "select * from person" do-simple-query ] with-sqlite ] unit-test
+] [
+ "extra/db/sqlite/test.db" resource-path [
+ "select * from person" sql-query
+ ] with-sqlite
+] unit-test
[
{ { "John" "America" } }
] [
- test.db [
+ "extra/db/sqlite/test.db" resource-path [
"select * from person where name = :name and country = :country"
- { { ":name" "Jane" } { ":country" "New Zealand" } }
- <bound-statement> dup [ sql-row ] query-map
+ <simple-statement> [
+ { { ":name" "Jane" } { ":country" "New Zealand" } }
+ over do-bound-query
- { { "Jane" "New Zealand" } } = [ "test fails" throw ] unless
- { { ":name" "John" } { ":country" "America" } } over bind-statement
+ { { "Jane" "New Zealand" } } =
+ [ "test fails" throw ] unless
- dup [ sql-row ] query-map swap dispose
+ { { ":name" "John" } { ":country" "America" } }
+ swap do-bound-query
+ ] with-disposal
] with-sqlite
] unit-test
@@ -48,13 +55,13 @@ IN: temporary
{ "1" "John" "America" }
{ "2" "Jane" "New Zealand" }
}
-] [ test.db [ "select rowid, * from person" do-simple-query ] with-sqlite ] unit-test
+] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[
] [
"extra/db/sqlite/test.db" resource-path [
"insert into person(name, country) values('Jimmy', 'Canada')"
- do-simple-command
+ sql-command
] with-sqlite
] unit-test
@@ -64,13 +71,13 @@ IN: temporary
{ "2" "Jane" "New Zealand" }
{ "3" "Jimmy" "Canada" }
}
-] [ test.db [ "select rowid, * from person" do-simple-query ] with-sqlite ] unit-test
+] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[
"extra/db/sqlite/test.db" resource-path [
[
- "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command
- "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command
+ "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+ "insert into person(name, country) values('Jose', 'Mexico')" sql-command
"oops" throw
] with-transaction
] with-sqlite
@@ -78,7 +85,7 @@ IN: temporary
[ 3 ] [
"extra/db/sqlite/test.db" resource-path [
- "select * from person" do-simple-query length
+ "select * from person" sql-query length
] with-sqlite
] unit-test
@@ -86,14 +93,16 @@ IN: temporary
] [
"extra/db/sqlite/test.db" resource-path [
[
- "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command
- "insert into person(name, country) values('Jose', 'Mexico')" do-simple-command
+ "insert into person(name, country) values('Jose', 'Mexico')"
+ sql-command
+ "insert into person(name, country) values('Jose', 'Mexico')"
+ sql-command
] with-transaction
] with-sqlite
] unit-test
[ 5 ] [
"extra/db/sqlite/test.db" resource-path [
- "select * from person" do-simple-query length
+ "select * from person" sql-query length
] with-sqlite
] unit-test
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index c5964ed599..8352d2e11f 100644
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -1,9 +1,9 @@
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien arrays assocs classes compiler db db.sql hashtables
-io.files kernel math math.parser namespaces prettyprint sequences
-strings sqlite.lib tuples alien.c-types continuations
-db.sqlite.lib db.sqlite.ffi ;
+USING: alien arrays assocs classes compiler db db.sql
+hashtables io.files kernel math math.parser namespaces
+prettyprint sequences strings tuples alien.c-types
+continuations db.sqlite.lib db.sqlite.ffi ;
IN: db.sqlite
TUPLE: sqlite-db path ;
@@ -24,47 +24,52 @@ M: sqlite-db dispose ( obj -- )
TUPLE: sqlite-statement ;
C: <sqlite-statement> sqlite-statement
+TUPLE: sqlite-result-set ;
+: <sqlite-result-set> ( query -- sqlite-result-set )
+ dup statement-handle sqlite-result-set <result-set> ;
+
M: sqlite-db <simple-statement> ( str -- obj )
<prepared-statement> ;
-M: sqlite-db <bound-statement> ( str -- obj )
- <prepared-bound-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 ;
-M: sqlite-db <prepared-bound-statement> ( str assoc -- obj )
- swap <prepared-statement> tuck bind-statement ;
-
M: sqlite-statement dispose ( statement -- )
statement-handle sqlite-finalize ;
+M: sqlite-result-set dispose ( result-set -- )
+ f swap set-result-set-handle ;
+
M: sqlite-statement bind-statement* ( assoc statement -- )
statement-handle swap sqlite-bind-assoc ;
M: sqlite-statement rebind-statement ( assoc statement -- )
- dup reset-statement
+ dup statement-handle sqlite-reset
statement-handle swap sqlite-bind-assoc ;
-M: sqlite-statement #columns ( statement -- n )
- statement-handle sqlite-#columns ;
+M: sqlite-statement execute-statement ( statement -- )
+ statement-handle sqlite-next drop ;
-M: sqlite-statement row-column ( statement n -- obj )
- >r statement-handle r> sqlite-column ;
+M: sqlite-result-set #columns ( result-set -- n )
+ result-set-handle sqlite-#columns ;
-M: sqlite-statement advance-row ( statement -- ? )
- statement-handle sqlite-next ;
+M: sqlite-result-set row-column ( result-set n -- obj )
+ >r result-set-handle r> sqlite-column ;
+
+M: sqlite-result-set advance-row ( result-set -- handle ? )
+ result-set-handle sqlite-next ;
+
+M: sqlite-statement query-results ( query -- result-set )
+ dup statement-handle sqlite-result-set <result-set> ;
-M: sqlite-statement reset-statement ( statement -- )
- statement-handle sqlite-reset ;
M: sqlite-db begin-transaction ( -- )
- "BEGIN" do-simple-command ;
+ "BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- )
- "COMMIT" do-simple-command ;
+ "COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- )
- "ROLLBACK" do-simple-command ;
+ "ROLLBACK" sql-command ;
From 55cfd30543091c74889b1c8a0ae9a3838377f783 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@laptop.(none)>
Date: Sat, 2 Feb 2008 23:46:56 -0600
Subject: [PATCH 22/52] remove strings.lib from automata
---
extra/automata/automata.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor
index 732033fb75..cd799d477e 100644
--- a/extra/automata/automata.factor
+++ b/extra/automata/automata.factor
@@ -1,6 +1,6 @@
USING: kernel math math.parser random arrays hashtables assocs sequences
- vars strings.lib ;
+ vars ;
IN: automata
@@ -108,4 +108,4 @@ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
-! : stop-loop ( -- ) f >loop-flag ;
\ No newline at end of file
+! : stop-loop ( -- ) f >loop-flag ;
From 1b03538caa28f37c4e56986c9e22eae9fcf4d966 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@laptop.(none)>
Date: Sun, 3 Feb 2008 00:14:27 -0600
Subject: [PATCH 23/52] fix compile errors in sqlite
---
extra/db/db.factor | 2 +-
extra/db/sqlite/ffi/ffi.factor | 1 -
extra/db/sqlite/lib/lib.factor | 2 +-
3 files changed, 2 insertions(+), 3 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 813ce901ff..81d79eb695 100644
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -77,7 +77,7 @@ GENERIC: advance-row ( result-set -- ? )
: do-bound-query ( obj query -- rows )
[ bind-statement ] keep do-query ;
-: do-bound-command ( obj query -- rows )
+: do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ;
: sql-query ( sql -- rows )
diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor
index 77a86a8a2d..609c597b35 100644
--- a/extra/db/sqlite/ffi/ffi.factor
+++ b/extra/db/sqlite/ffi/ffi.factor
@@ -109,7 +109,6 @@ TYPEDEF: void sqlite3_stmt
LIBRARY: sqlite
FUNCTION: int sqlite3_open ( char* filename, void* ppDb ) ;
-FUNCTION: int sqlite3_open_v2 ( char* filename, void* ppDb, int flags, char* zVfs ) ;
FUNCTION: int sqlite3_close ( sqlite3* pDb ) ;
FUNCTION: int sqlite3_prepare ( sqlite3* pDb, char* zSql, int nBytes, void* ppStmt, void* pzTail ) ;
FUNCTION: int sqlite3_finalize ( sqlite3_stmt* pStmt ) ;
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index 99cd9c1b9f..4e4f2ca508 100644
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -80,7 +80,7 @@ TUPLE: sqlite-error n message ;
sqlite-step
] if ;
-: sqlite-next ( prepared -- )
+: sqlite-next ( prepared -- ? )
sqlite3_step step-complete? ;
: sqlite-each ( statement quot -- )
From 303cb0edc2efaedfab5d8e38cf7ab18a5a975d65 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 3 Feb 2008 03:48:08 -0600
Subject: [PATCH 24/52] Fix missing math.bitfields
---
extra/x11/windows/windows.factor | 16 +---------------
extra/x11/xlib/xlib.factor | 22 +++++++++++-----------
2 files changed, 12 insertions(+), 26 deletions(-)
diff --git a/extra/x11/windows/windows.factor b/extra/x11/windows/windows.factor
index b3220d44bd..f9158c2956 100755
--- a/extra/x11/windows/windows.factor
+++ b/extra/x11/windows/windows.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types hashtables kernel math math.vectors
+USING: alien alien.c-types hashtables kernel math math.vectors math.bitfields
namespaces sequences x11.xlib x11.constants x11.glx ;
IN: x11.windows
@@ -12,7 +12,6 @@ IN: x11.windows
XCreateColormap ;
: event-mask ( -- n )
-<<<<<<< HEAD:extra/x11/windows/windows.factor
{
ExposureMask
StructureNotifyMask
@@ -26,19 +25,6 @@ IN: x11.windows
LeaveWindowMask
PropertyChangeMask
} flags ;
-=======
- ExposureMask
- StructureNotifyMask bitor
- KeyPressMask bitor
- KeyReleaseMask bitor
- ButtonPressMask bitor
- ButtonReleaseMask bitor
- PointerMotionMask bitor
- FocusChangeMask bitor
- EnterWindowMask bitor
- LeaveWindowMask bitor
- PropertyChangeMask bitor ;
->>>>>>> a05c18152b59073c49aa313ba685516310ec74a8:extra/x11/windows/windows.factor
: window-attributes ( visinfo -- attributes )
"XSetWindowAttributes" <c-object>
diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor
index 230b24c6d0..70006c9f64 100755
--- a/extra/x11/xlib/xlib.factor
+++ b/extra/x11/xlib/xlib.factor
@@ -12,7 +12,7 @@
! and note the section.
USING: kernel arrays alien alien.c-types alien.syntax
-math words sequences namespaces continuations ;
+math math.bitfields words sequences namespaces continuations ;
IN: x11.xlib
LIBRARY: xlib
@@ -1078,16 +1078,16 @@ FUNCTION: Status XWithdrawWindow (
! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property
-: USPosition 1 0 shift ; inline
-: USSize 1 1 shift ; inline
-: PPosition 1 2 shift ; inline
-: PSize 1 3 shift ; inline
-: PMinSize 1 4 shift ; inline
-: PMaxSize 1 5 shift ; inline
-: PResizeInc 1 6 shift ; inline
-: PAspect 1 7 shift ; inline
-: PBaseSize 1 8 shift ; inline
-: PWinGravity 1 9 shift ; inline
+: USPosition 1 0 shift ; inline
+: USSize 1 1 shift ; inline
+: PPosition 1 2 shift ; inline
+: PSize 1 3 shift ; inline
+: PMinSize 1 4 shift ; inline
+: PMaxSize 1 5 shift ; inline
+: PResizeInc 1 6 shift ; inline
+: PAspect 1 7 shift ; inline
+: PBaseSize 1 8 shift ; inline
+: PWinGravity 1 9 shift ; inline
: PAllHints
{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
From 7a5d48cadb7c67c0859cd71879a68b7c58e355c7 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 3 Feb 2008 03:48:29 -0600
Subject: [PATCH 25/52] shuffle: add nrev
---
extra/shuffle/shuffle.factor | 5 +++++
1 file changed, 5 insertions(+)
diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor
index f9f8b030a8..f139a4864e 100644
--- a/extra/shuffle/shuffle.factor
+++ b/extra/shuffle/shuffle.factor
@@ -30,3 +30,8 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ;
: 4drop ( a b c d -- ) 3drop drop ; inline
: tuckd ( x y z -- z x y z ) 2 ntuck ; inline
+
+MACRO: nrev ( n -- quot )
+ [ 1+ ] map
+ reverse
+ [ [ -nrot ] curry ] map concat ;
From 8cfc644893a61e4cd807da2dea6a6019f7c175de Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 3 Feb 2008 03:48:58 -0600
Subject: [PATCH 26/52] sequences.lib: indices
---
extra/sequences/lib/lib.factor | 10 ++++++++++
1 file changed, 10 insertions(+)
diff --git a/extra/sequences/lib/lib.factor b/extra/sequences/lib/lib.factor
index d784726754..65b0d1beb0 100755
--- a/extra/sequences/lib/lib.factor
+++ b/extra/sequences/lib/lib.factor
@@ -140,3 +140,13 @@ PRIVATE>
: ?second ( seq -- second/f ) 1 swap ?nth ; inline
: ?third ( seq -- third/f ) 2 swap ?nth ; inline
: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
+
+! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
+
+! List the positions of obj in seq
+
+: indices ( seq obj -- seq )
+ >r dup length swap r>
+ [ = [ ] [ drop f ] if ] curry
+ 2map
+ [ ] subset ;
From 1de4896c248f6f95767c4d75df3bd7ffc3130c32 Mon Sep 17 00:00:00 2001
From: Eduardo Cavazos <dharmatech@finkelstein.stackeffects.info>
Date: Sun, 3 Feb 2008 03:49:19 -0600
Subject: [PATCH 27/52] Add partial-apply
---
extra/partial-apply/partial-apply.factor | 26 ++++++++++++++++++++++++
1 file changed, 26 insertions(+)
create mode 100644 extra/partial-apply/partial-apply.factor
diff --git a/extra/partial-apply/partial-apply.factor b/extra/partial-apply/partial-apply.factor
new file mode 100644
index 0000000000..0340e53025
--- /dev/null
+++ b/extra/partial-apply/partial-apply.factor
@@ -0,0 +1,26 @@
+
+USING: kernel sequences quotations math parser
+ shuffle combinators.cleave combinators.lib sequences.lib ;
+
+IN: partial-apply
+
+! Basic conceptual implementation. Todo: get it to compile.
+
+: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ;
+
+SYMBOL: _
+
+SYMBOL: ~
+
+: blank-positions ( quot -- seq )
+ [ length 2 - ] [ _ indices ] bi [ - ] map-with ;
+
+: partial-apply ( pattern -- quot )
+ [ blank-positions length nrev ]
+ [ peek 1quotation ]
+ [ blank-positions ]
+ tri
+ [ apply-n ] each ;
+
+: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing
+
From c60338df7e82a1ac8ae1df3f7fd35470a48cdc86 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 3 Feb 2008 10:24:28 -0800
Subject: [PATCH 28/52] Fix bug in TextMate bundle when using the see or help
commands on the first word on a line
---
extra/bunny/model/model.factor | 1 -
misc/Factor.tmbundle/Support/lib/tm_factor.rb | 2 +-
2 files changed, 1 insertion(+), 2 deletions(-)
diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
index a19adcb782..e3df6bb26c 100644
--- a/extra/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -111,4 +111,3 @@ M: bunny-buffers dispose
"1.5" { "GL_ARB_vertex_buffer_object" }
has-gl-version-or-extensions?
[ <bunny-buffers> ] [ <bunny-dlist> ] if ;
-
diff --git a/misc/Factor.tmbundle/Support/lib/tm_factor.rb b/misc/Factor.tmbundle/Support/lib/tm_factor.rb
index 54272e5e36..2775a12ae9 100644
--- a/misc/Factor.tmbundle/Support/lib/tm_factor.rb
+++ b/misc/Factor.tmbundle/Support/lib/tm_factor.rb
@@ -33,6 +33,6 @@ def doc_using_statements(document)
end
def line_current_word(line, point)
- left = line.rindex(/\s|^/, point - 1) + 1; right = line.index(/\s|$/, point) - 1
+ left = line.rindex(/\s/, point - 1) || 0; right = line.index(/\s/, point) || line.length
line[left..right]
end
From bb1e06dd8d812db71bb802b0faa9d5fae70b0571 Mon Sep 17 00:00:00 2001
From: Doug Coleman <erg@jjjj.(none)>
Date: Sun, 3 Feb 2008 15:06:31 -0600
Subject: [PATCH 29/52] add copyright notices update postgresql for new db
protocol make unit tests pass
---
extra/db/db.factor | 4 +
extra/db/postgresql/ffi/ffi.factor | 4 +-
extra/db/postgresql/lib/lib.factor | 60 +++------
extra/db/postgresql/postgresql-tests.factor | 128 ++++++++++++++------
extra/db/postgresql/postgresql.factor | 57 +++++----
extra/db/sqlite/lib/lib.factor | 22 +---
extra/db/sqlite/sqlite-tests.factor | 18 +--
extra/db/sqlite/sqlite.factor | 1 -
8 files changed, 161 insertions(+), 133 deletions(-)
diff --git a/extra/db/db.factor b/extra/db/db.factor
index 81d79eb695..b765924cd6 100644
--- a/extra/db/db.factor
+++ b/extra/db/db.factor
@@ -44,6 +44,10 @@ GENERIC: #columns ( result-set -- n )
GENERIC# row-column 1 ( result-set n -- obj )
GENERIC: advance-row ( result-set -- ? )
+: init-result-set ( result-set -- )
+ dup #rows over set-result-set-max
+ -1 swap set-result-set-n ;
+
: <result-set> ( query handle tuple -- result-set )
>r >r { statement-sql statement-params } get-slots r>
{
diff --git a/extra/db/postgresql/ffi/ffi.factor b/extra/db/postgresql/ffi/ffi.factor
index 368e2fbe77..dbaa70c625 100644
--- a/extra/db/postgresql/ffi/ffi.factor
+++ b/extra/db/postgresql/ffi/ffi.factor
@@ -1,9 +1,7 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-
! adapted from libpq-fe.h version 7.4.7
-! tested on debian linux with postgresql 7.4.7
-! Updated to 8.1
+! tested on debian linux with postgresql 8.1
USING: alien alien.syntax combinators system ;
IN: db.postgresql.ffi
diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor
index 4b362f9931..a940a42ae4 100644
--- a/extra/db/postgresql/lib/lib.factor
+++ b/extra/db/postgresql/lib/lib.factor
@@ -1,13 +1,9 @@
+! Copyright (C) 2008 Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: arrays continuations db io kernel math namespaces
-quotations sequences db.postgresql.ffi ;
+quotations sequences db.postgresql.ffi alien alien.c-types ;
IN: db.postgresql.lib
-SYMBOL: query-res
-
-: connect-postgres ( host port pgopts pgtty db user pass -- conn )
- PQsetdbLogin
- dup PQstatus zero? [ "couldn't connect to database" throw ] unless ;
-
: postgresql-result-error-message ( res -- str/f )
dup zero? [
drop f
@@ -28,45 +24,21 @@ SYMBOL: query-res
PQresultStatus
PGRES_COMMAND_OK PGRES_TUPLES_OK 2array member? ;
+: connect-postgres ( host port pgopts pgtty db user pass -- conn )
+ PQsetdbLogin
+ 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? [
dup postgresql-result-error-message swap PQclear throw
] unless ;
-! : do-command ( str -- )
- ! 1quotation \ (do-command) add db get swap call ;
-
-! : prepare ( str quot word -- conn quot )
- ! rot 1quotation swap append swap append db get swap ;
-
-! : do-query ( str quot -- )
- ! [ (do-query) query-res set ] prepare catch
- ! [ rethrow ] [ query-res get PQclear ] if* ;
-
-! : result>seq ( -- seq )
- ! query-res get [ PQnfields ] keep PQntuples
- ! [ swap [ query-res get -rot PQgetvalue ] with map ] with map ;
-!
-! : print-table ( seq -- )
- ! [ [ write bl ] each "\n" write ] each ;
-
-
-
-! select * from animal where name = 'Simba'
-! select * from animal where name = $1
-
-! : (do-query) ( PGconn query -- PGresult* )
- ! ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK
- ! ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK
- ! PQexec dup postgresql-result-ok? [
- ! dup postgresql-error-message swap PQclear throw
- ! ] unless ;
-
-! : (do-command) ( PGconn query -- PGresult* )
- ! [ (do-query) ] catch
- ! [
- ! swap
- ! "non-fatal error: " print
- ! "\tQuery: " write "'" write write "'" print
- ! "\t" write print
- ! ] when* drop ;
+: do-postgresql-bound-statement ( statement -- res )
+ >r db get db-handle r>
+ [ statement-sql ] keep
+ [ statement-params length f ] keep
+ statement-params [ malloc-char-string ] map >c-void*-array
+ f f 0 PQexecParams
+ dup postgresql-result-ok? [
+ dup postgresql-result-error-message swap PQclear throw
+ ] unless ;
diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor
index 438a80e2d8..c5a5155d12 100644
--- a/extra/db/postgresql/postgresql-tests.factor
+++ b/extra/db/postgresql/postgresql-tests.factor
@@ -2,53 +2,109 @@
! Set username and password in the 'connect' word.
USING: kernel db.postgresql alien continuations io prettyprint
-sequences namespaces tools.test ;
+sequences namespaces tools.test db ;
IN: temporary
-: test-connection ( host port pgopts pgtty db user pass -- bool )
- [ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ;
+IN: scratchpad
+: test-db ( -- postgresql-db )
+ "localhost" "postgres" "" "factor-test" <postgresql-db> ;
+IN: temporary
-[ ] [ "localhost" "" "" "" "factor-test" "postgres" "" test-connection ] unit-test
+[ ] [ test-db [ ] with-db ] unit-test
-[ ] [ "localhost" "postgres" "" "factor-test" <postgresql-db> [ ] with-db ] unit-test
+[ ] [
+ test-db [
+ [ "drop table person;" sql-command ] catch drop
+ "create table person (name varchar(30), country varchar(30));"
+ sql-command
-! just a basic demo
+ "insert into person values('John', 'America');" sql-command
+ "insert into person values('Jane', 'New Zealand');" sql-command
+ ] with-db
+] unit-test
-"localhost" "postgres" "" "factor-test" <postgresql-db> [
- [ ] [ "drop table animal" do-command ] unit-test
+[
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ }
+] [
+ test-db [
+ "select * from person" sql-query
+ ] with-db
+] unit-test
- [ ] [ "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command ] unit-test
-
- [ ] [ "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)"
- do-command ] unit-test
+[
+ { { "John" "America" } }
+] [
+ test-db [
+ "select * from person where name = $1 and country = $2"
+ <simple-statement> [
+ { "Jane" "New Zealand" }
+ over do-bound-query
- [ ] [ "select * from animal where name = 'Mufasa'" [ ] do-query ] unit-test
- [ ] [ "select * from animal where name = 'Mufasa'" [
- result>seq length 1 = [
- "...there can only be one Mufasa..." throw
- ] unless
- ] do-query
- ] unit-test
+ { { "Jane" "New Zealand" } } =
+ [ "test fails" throw ] unless
- [ ] [ "insert into animal (species, name, age) values ('lion', 'Simba', 1)"
- do-command ] unit-test
+ { "John" "America" }
+ swap do-bound-query
+ ] with-disposal
+ ] with-db
+] unit-test
- [ ] [
- "select * from animal"
+[
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ }
+] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
+
+[
+] [
+ test-db [
+ "insert into person(name, country) values('Jimmy', 'Canada')"
+ sql-command
+ ] with-db
+] unit-test
+
+[
+ {
+ { "John" "America" }
+ { "Jane" "New Zealand" }
+ { "Jimmy" "Canada" }
+ }
+] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
+
+[
+ test-db [
[
- "Animal table:" print
- result>seq print-table
- ] do-query
- ] unit-test
+ "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+ "insert into person(name, country) values('Jose', 'Mexico')" sql-command
+ "oops" throw
+ ] with-transaction
+ ] with-db
+] unit-test-fails
- ! intentional errors
- ! [ "select asdf from animal"
- ! [ ] do-query ] catch [ "caught: " write print ] when*
- ! "select asdf from animal" [ ] do-query
- ! "aofijweafew" do-command
-] with-db
+[ 3 ] [
+ test-db [
+ "select * from person" sql-query length
+ ] with-db
+] unit-test
+[
+] [
+ test-db [
+ [
+ "insert into person(name, country) values('Jose', 'Mexico')"
+ sql-command
+ "insert into person(name, country) values('Jose', 'Mexico')"
+ sql-command
+ ] with-transaction
+ ] with-db
+] unit-test
-"localhost" "postgres" "" "factor-test" <postgresql-db> [
- [ ] [ "drop table animal" do-command ] unit-test
-] with-db
+[ 5 ] [
+ test-db [
+ "select * from person" sql-query length
+ ] with-db
+] unit-test
diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor
index 2ea1b3a1dc..df778cc80d 100644
--- a/extra/db/postgresql/postgresql.factor
+++ b/extra/db/postgresql/postgresql.factor
@@ -1,8 +1,5 @@
-! Copyright (C) 2007 Doug Coleman.
+! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
-! adapted from libpq-fe.h version 7.4.7
-! tested on debian linux with postgresql 7.4.7
-
USING: arrays assocs alien alien.syntax continuations io
kernel math namespaces prettyprint quotations
sequences debugger db db.postgresql.lib db.postgresql.ffi ;
@@ -10,6 +7,7 @@ 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 construct-delegate ;
@@ -38,31 +36,39 @@ M: postgresql-db dispose ( db -- )
: with-postgresql ( host ust pass db quot -- )
>r <postgresql-db> r> with-disposal ;
+M: postgresql-statement bind-statement* ( seq statement -- )
+ set-statement-params ;
-M: postgresql-result-set #rows ( statement -- n )
- statement-handle PQntuples ;
+M: postgresql-statement rebind-statement ( seq statement -- )
+ bind-statement* ;
-M: postgresql-result-set #columns ( statement -- n )
- statement-handle PQnfields ;
+M: postgresql-result-set #rows ( result-set -- n )
+ result-set-handle PQntuples ;
-M: postgresql-result-set row-column ( statement n -- obj )
- >r dup statement-handle swap statement-n r> PQgetvalue ;
+M: postgresql-result-set #columns ( result-set -- n )
+ result-set-handle PQnfields ;
+M: postgresql-result-set row-column ( result-set n -- obj )
+ >r dup result-set-handle swap result-set-n r> PQgetvalue ;
-: init-result-set ( result-set -- )
- dup result-set-max [
- dup do-postgresql-statement over set-result-set-handle
- dup #rows over set-result-set-max
- -1 over set-result-set-n
- ] unless drop ;
+M: postgresql-statement execute-statement ( statement -- )
+ query-results dispose ;
: increment-n ( result-set -- n )
dup result-set-n 1+ dup rot set-result-set-n ;
-M: postgresql-result-set advance-row ( result-set -- ? )
- dup init-result-set
- dup increment-n swap result-set-max >= ;
+M: postgresql-statement query-results ( query -- result-set )
+ dup statement-params [
+ over [ bind-statement ] keep
+ do-postgresql-bound-statement
+ ] [
+ dup do-postgresql-statement
+ ] if*
+ postgresql-result-set <result-set>
+ dup init-result-set ;
+M: postgresql-result-set advance-row ( result-set -- ? )
+ dup increment-n swap result-set-max >= ;
M: postgresql-statement dispose ( query -- )
dup statement-handle PQclear
@@ -71,14 +77,14 @@ M: postgresql-statement dispose ( query -- )
M: postgresql-result-set dispose ( result-set -- )
dup result-set-handle PQclear
0 0 f roll {
- set-statement-n set-statement-max set-statement-handle
+ set-result-set-n set-result-set-max set-result-set-handle
} set-slots ;
M: postgresql-statement prepare-statement ( statement -- )
[
>r db get db-handle "" r>
dup statement-sql swap statement-params
- dup assoc-size swap PQprepare postgresql-error
+ length f PQprepare postgresql-error
] keep set-statement-handle ;
M: postgresql-db <simple-statement> ( sql -- statement )
@@ -88,3 +94,12 @@ M: postgresql-db <simple-statement> ( sql -- statement )
M: postgresql-db <prepared-statement> ( sql -- statement )
{ set-statement-sql } statement construct
<postgresql-statement> ;
+
+M: postgresql-db begin-transaction ( -- )
+ "BEGIN" sql-command ;
+
+M: postgresql-db commit-transaction ( -- )
+ "COMMIT" sql-command ;
+
+M: postgresql-db rollback-transaction ( -- )
+ "ROLLBACK" sql-command ;
diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor
index 4e4f2ca508..e5f8425d92 100644
--- a/extra/db/sqlite/lib/lib.factor
+++ b/extra/db/sqlite/lib/lib.factor
@@ -1,3 +1,5 @@
+! Copyright (C) 2008 Chris Double, Doug Coleman.
+! See http://factorcode.org/license.txt for BSD license.
USING: alien.c-types assocs kernel math math.parser sequences
db.sqlite.ffi ;
IN: db.sqlite.lib
@@ -65,7 +67,6 @@ TUPLE: sqlite-error n message ;
! SQLITE_BLOB 4
! SQLITE_NULL 5
-
: step-complete? ( step-result -- bool )
dup SQLITE_ROW = [
drop f
@@ -82,22 +83,3 @@ TUPLE: sqlite-error n message ;
: sqlite-next ( prepared -- ? )
sqlite3_step step-complete? ;
-
-: sqlite-each ( statement quot -- )
- over sqlite3_step step-complete? [
- 2drop
- ] [
- [ call ] 2keep sqlite-each
- ] if ; inline
-
-DEFER: (sqlite-map)
-
-: (sqlite-map) ( statement quot seq -- )
- pick sqlite3_step step-complete? [
- 2nip
- ] [
- >r 2dup call r> swap add (sqlite-map)
- ] if ;
-
-: sqlite-map ( statement quot -- seq )
- { } (sqlite-map) ;
diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor
index ef1bbfc262..f64b8d1104 100644
--- a/extra/db/sqlite/sqlite-tests.factor
+++ b/extra/db/sqlite/sqlite-tests.factor
@@ -5,12 +5,14 @@ IN: temporary
! "sqlite3 -init test.txt test.db"
+IN: scratchpad
: test.db "extra/db/sqlite/test.db" resource-path ;
+IN: temporary
: (create-db) ( -- str )
[
"sqlite3 -init " %
- "extra/db/sqlite/test.txt" resource-path %
+ test.db %
" " %
test.db %
] "" make ;
@@ -27,7 +29,7 @@ IN: temporary
{ "Jane" "New Zealand" }
}
] [
- "extra/db/sqlite/test.db" resource-path [
+ test.db [
"select * from person" sql-query
] with-sqlite
] unit-test
@@ -35,7 +37,7 @@ IN: temporary
[
{ { "John" "America" } }
] [
- "extra/db/sqlite/test.db" resource-path [
+ test.db [
"select * from person where name = :name and country = :country"
<simple-statement> [
{ { ":name" "Jane" } { ":country" "New Zealand" } }
@@ -59,7 +61,7 @@ IN: temporary
[
] [
- "extra/db/sqlite/test.db" resource-path [
+ test.db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
] with-sqlite
@@ -74,7 +76,7 @@ IN: temporary
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[
- "extra/db/sqlite/test.db" resource-path [
+ test.db [
[
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
@@ -84,14 +86,14 @@ IN: temporary
] unit-test-fails
[ 3 ] [
- "extra/db/sqlite/test.db" resource-path [
+ test.db [
"select * from person" sql-query length
] with-sqlite
] unit-test
[
] [
- "extra/db/sqlite/test.db" resource-path [
+ test.db [
[
"insert into person(name, country) values('Jose', 'Mexico')"
sql-command
@@ -102,7 +104,7 @@ IN: temporary
] unit-test
[ 5 ] [
- "extra/db/sqlite/test.db" resource-path [
+ test.db [
"select * from person" sql-query length
] with-sqlite
] unit-test
diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor
index 8352d2e11f..49462dcc50 100644
--- a/extra/db/sqlite/sqlite.factor
+++ b/extra/db/sqlite/sqlite.factor
@@ -64,7 +64,6 @@ M: sqlite-result-set advance-row ( result-set -- handle ? )
M: sqlite-statement query-results ( query -- result-set )
dup statement-handle sqlite-result-set <result-set> ;
-
M: sqlite-db begin-transaction ( -- )
"BEGIN" sql-command ;
From bae79b80e32cc2658dbd7c0f804f5c9ae0f2ec95 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 3 Feb 2008 15:14:48 -0600
Subject: [PATCH 30/52] Undo handle duplication
---
extra/io/windows/launcher/launcher.factor | 14 +-------------
1 file changed, 1 insertion(+), 13 deletions(-)
diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor
index 3d0c2feac1..f3f78fbb88 100755
--- a/extra/io/windows/launcher/launcher.factor
+++ b/extra/io/windows/launcher/launcher.factor
@@ -118,23 +118,11 @@ TUPLE: CreateProcess-args
: inherited-stderr ( args -- handle )
drop STD_ERROR_HANDLE GetStdHandle ;
-: duplicate-handle ( handle -- handle )
- GetCurrentProcess
- swap
- GetCurrentProcess
- f <void*> [
- 0
- TRUE
- DUPLICATE_SAME_ACCESS
- DuplicateHandle win32-error=0/f
- ] keep *void* ;
-
: redirect-stderr ( args -- handle )
+stderr+ get
dup +stdout+ eq? [
drop
- CreateProcess-args-lpStartupInfo duplicate-handle
- STARTUPINFO-hStdOutput
+ CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput
] [
GENERIC_WRITE CREATE_ALWAYS redirect
swap inherited-stderr ?closed
From f4244e7cafacdd82972419226b33c67535c4a7f5 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Sun, 3 Feb 2008 15:55:59 -0600
Subject: [PATCH 31/52] Fix Unix launcher
---
extra/io/unix/launcher/launcher.factor | 4 ++--
1 file changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index 030583dbe8..b44ac80159 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -57,8 +57,8 @@ MEMO: 'arguments' ( -- parser )
: setup-redirection ( -- )
+stdin+ get read-flags 0 redirect
+stdout+ get write-flags 1 redirect
- +stderr+ get dup +stdout+ get eq?
- [ 1 2 dup2 ] [ write-flags 2 redirect ] if ;
+ +stderr+ get dup +stdout+ eq?
+ [ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ;
: spawn-process ( -- )
[
From 793c3ceb1f627d578fa510f272786cb3e10cc70f Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Sun, 3 Feb 2008 16:06:57 -0600
Subject: [PATCH 32/52] byte-length for bit-arrays
---
core/alien/c-types/c-types.factor | 15 +++++++++------
1 file changed, 9 insertions(+), 6 deletions(-)
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index 8ab703eb7e..1f0f6b121e 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -1,9 +1,10 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: byte-arrays float-arrays arrays generator.registers assocs
-kernel kernel.private libc math namespaces parser sequences
-strings words assocs splitting math.parser cpu.architecture
-alien alien.accessors quotations system compiler.units ;
+USING: bit-arrays byte-arrays float-arrays arrays
+generator.registers assocs kernel kernel.private libc math
+namespaces parser sequences strings words assocs splitting
+math.parser cpu.architecture alien alien.accessors quotations
+system compiler.units ;
IN: alien.c-types
TUPLE: c-type
@@ -109,10 +110,12 @@ M: c-type stack-size c-type-size ;
GENERIC: byte-length ( seq -- n ) flushable
-M: float-array byte-length length "double" heap-size * ;
+M: bit-array byte-length length 7 + -3 shift ;
M: byte-array byte-length length ;
+M: float-array byte-length length "double" heap-size * ;
+
: c-getter ( name -- quot )
c-type c-type-getter [
[ "Cannot read struct fields with type" throw ]
From d6185e224ad77ec30490086c101536bcdd4eed7e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Sun, 3 Feb 2008 16:13:57 -0600
Subject: [PATCH 33/52] Undo funny stuff
---
extra/http/server/responders/responders.factor | 4 ++--
extra/unicode/case/case.factor | 9 ---------
2 files changed, 2 insertions(+), 11 deletions(-)
diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor
index 6df52997e1..70503236f6 100644
--- a/extra/http/server/responders/responders.factor
+++ b/extra/http/server/responders/responders.factor
@@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs hashtables html html.elements splitting
http io kernel math math.parser namespaces parser sequences
-strings io.server vectors assocs.lib unicode.case ;
+strings io.server vectors assocs.lib ;
IN: http.server.responders
@@ -14,7 +14,7 @@ SYMBOL: responders
H{ } clone [ insert-at ] keep ;
: print-header ( alist -- )
- [ swap >Upper-dashes write ": " write print ] multi-assoc-each nl ;
+ [ swap write ": " write print ] multi-assoc-each nl ;
: response ( msg -- ) "HTTP/1.0 " write print ;
diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor
index f244192a32..8129ec17f8 100755
--- a/extra/unicode/case/case.factor
+++ b/extra/unicode/case/case.factor
@@ -110,12 +110,3 @@ SYMBOL: locale ! Just casing locale, or overall?
dup >title = ;
: case-fold? ( string -- ? )
dup >case-fold = ;
-
-
-: >Upper ( str -- str )
- dup empty? [
- unclip ch>upper 1string swap append
- ] unless ;
-
-: >Upper-dashes ( str -- str )
- "-" split [ >Upper ] map "-" join ;
From e7722c02b75252c9ba8456c1390c0db6b2d98860 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 3 Feb 2008 17:28:57 -0600
Subject: [PATCH 34/52] Add unit test for float alignment
---
core/compiler/test/alien.factor | 10 ++++++++++
vm/ffi_test.c | 5 +++++
vm/ffi_test.h | 4 ++++
3 files changed, 19 insertions(+)
mode change 100644 => 100755 vm/ffi_test.c
mode change 100644 => 100755 vm/ffi_test.h
diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor
index acb9a4a4fa..9416fd1415 100755
--- a/core/compiler/test/alien.factor
+++ b/core/compiler/test/alien.factor
@@ -270,6 +270,16 @@ FUNCTION: double ffi_test_35 test-struct-11 x int y ;
3 ffi_test_35
] unit-test
+C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
+
+: make-struct-12
+ "test-struct-12" <c-object>
+ [ set-test-struct-12-x ] keep ;
+
+FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
+
+[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
+
! Test callbacks
: callback-1 "void" { } "cdecl" [ ] alien-callback ;
diff --git a/vm/ffi_test.c b/vm/ffi_test.c
old mode 100644
new mode 100755
index f6e70fd6ac..9cec5ccbad
--- a/vm/ffi_test.c
+++ b/vm/ffi_test.c
@@ -245,3 +245,8 @@ double ffi_test_35(struct test_struct_11 x, int y)
{
return (x.x + x.y) * y;
}
+
+double ffi_test_36(struct test_struct_12 x)
+{
+ return x.x;
+}
diff --git a/vm/ffi_test.h b/vm/ffi_test.h
old mode 100644
new mode 100755
index 27e402b74f..aac5d32f93
--- a/vm/ffi_test.h
+++ b/vm/ffi_test.h
@@ -57,3 +57,7 @@ struct test_struct_10 { float x; int y; };
DLLEXPORT double ffi_test_34(struct test_struct_10 x, int y);
struct test_struct_11 { int x; int y; };
DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y);
+
+struct test_struct_12 { int a; double x; };
+
+DLLEXPORT double ffi_test_36(struct test_struct_12 x);
From a544f5eedab164251be0eefaac031c803074985f Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 3 Feb 2008 15:59:47 -0800
Subject: [PATCH 35/52] Take the fattening opengl vocab and hack it up into
smaller, mouth-sized morsels
---
core/alien/c-types/c-types.factor | 3 +
extra/bunny/authors.txt | 1 +
extra/bunny/cel-shaded/cel-shaded.factor | 3 +-
extra/bunny/model/model.factor | 3 +-
extra/bunny/outlined/outlined.factor | 3 +-
extra/bunny/tags.txt | 1 +
extra/opengl/authors.txt | 1 +
extra/opengl/capabilities/authors.txt | 1 +
.../capabilities/capabilities-docs.factor | 59 +++++
extra/opengl/capabilities/capabilities.factor | 67 +++++
extra/opengl/capabilities/summary.txt | 1 +
extra/opengl/capabilities/tags.txt | 2 +
extra/opengl/framebuffers/authors.txt | 1 +
.../framebuffers/framebuffer-docs.factor | 35 +++
extra/opengl/framebuffers/framebuffers.factor | 43 ++++
extra/opengl/framebuffers/summary.txt | 1 +
extra/opengl/framebuffers/tags.txt | 2 +
extra/opengl/opengl-docs.factor | 202 +--------------
extra/opengl/opengl.factor | 241 +-----------------
extra/opengl/shaders/authors.txt | 1 +
extra/opengl/shaders/shaders-docs.factor | 112 ++++++++
extra/opengl/shaders/shaders.factor | 134 ++++++++++
extra/opengl/shaders/summary.txt | 1 +
extra/opengl/shaders/tags.txt | 3 +
24 files changed, 487 insertions(+), 434 deletions(-)
create mode 100644 extra/opengl/capabilities/authors.txt
create mode 100644 extra/opengl/capabilities/capabilities-docs.factor
create mode 100644 extra/opengl/capabilities/capabilities.factor
create mode 100644 extra/opengl/capabilities/summary.txt
create mode 100644 extra/opengl/capabilities/tags.txt
create mode 100644 extra/opengl/framebuffers/authors.txt
create mode 100644 extra/opengl/framebuffers/framebuffer-docs.factor
create mode 100644 extra/opengl/framebuffers/framebuffers.factor
create mode 100644 extra/opengl/framebuffers/summary.txt
create mode 100644 extra/opengl/framebuffers/tags.txt
create mode 100644 extra/opengl/shaders/authors.txt
create mode 100644 extra/opengl/shaders/shaders-docs.factor
create mode 100644 extra/opengl/shaders/shaders.factor
create mode 100644 extra/opengl/shaders/summary.txt
create mode 100644 extra/opengl/shaders/tags.txt
diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor
index 8ab703eb7e..9bbd24351c 100755
--- a/core/alien/c-types/c-types.factor
+++ b/core/alien/c-types/c-types.factor
@@ -211,6 +211,9 @@ M: long-long-type box-return ( type -- )
over [ <c-object> tuck 0 ] over c-setter append swap
>r >r constructor-word r> r> add* define-inline ;
+: c-bool> ( int -- ? )
+ zero? not ;
+
: >c-array ( seq type word -- )
>r >r dup length dup r> <c-array> dup -roll r>
[ execute ] 2curry 2each ; inline
diff --git a/extra/bunny/authors.txt b/extra/bunny/authors.txt
index 1901f27a24..580f882c8d 100644
--- a/extra/bunny/authors.txt
+++ b/extra/bunny/authors.txt
@@ -1 +1,2 @@
Slava Pestov
+Joe Groff
diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor
index fc42ca971e..37343a23fb 100644
--- a/extra/bunny/cel-shaded/cel-shaded.factor
+++ b/extra/bunny/cel-shaded/cel-shaded.factor
@@ -1,5 +1,6 @@
USING: arrays bunny.model combinators.lib continuations
-kernel multiline opengl opengl.gl sequences ;
+kernel multiline opengl opengl.shaders opengl.capabilities
+opengl.gl sequences ;
IN: bunny.cel-shaded
STRING: vertex-shader-source
diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
index e3df6bb26c..f2c93eac3e 100644
--- a/extra/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -1,6 +1,7 @@
USING: alien alien.c-types arrays sequences math
math.vectors math.matrices math.parser io io.files kernel opengl
-opengl.gl opengl.glu shuffle http.client vectors splitting
+opengl.gl opengl.glu opengl.capabilities shuffle http.client
+vectors splitting
tools.time system combinators combinators.lib combinators.cleave
float-arrays continuations namespaces ;
IN: bunny.model
diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor
index 9de341561c..d7064ebdde 100644
--- a/extra/bunny/outlined/outlined.factor
+++ b/extra/bunny/outlined/outlined.factor
@@ -1,6 +1,7 @@
USING: arrays bunny.model bunny.cel-shaded
combinators.lib continuations kernel math multiline
-opengl opengl.gl sequences ui.gadgets ;
+opengl opengl.shaders opengl.framebuffers opengl.gl
+opengl.capabilities sequences ui.gadgets ;
IN: bunny.outlined
STRING: outlined-pass1-fragment-shader-main-source
diff --git a/extra/bunny/tags.txt b/extra/bunny/tags.txt
index cb5fc203e1..339115d3c7 100644
--- a/extra/bunny/tags.txt
+++ b/extra/bunny/tags.txt
@@ -1 +1,2 @@
demos
+opengl
diff --git a/extra/opengl/authors.txt b/extra/opengl/authors.txt
index e1907c6d91..55ac3c728e 100644
--- a/extra/opengl/authors.txt
+++ b/extra/opengl/authors.txt
@@ -1,2 +1,3 @@
Slava Pestov
Eduardo Cavazos
+Joe Groff
diff --git a/extra/opengl/capabilities/authors.txt b/extra/opengl/capabilities/authors.txt
new file mode 100644
index 0000000000..6a0dc7293a
--- /dev/null
+++ b/extra/opengl/capabilities/authors.txt
@@ -0,0 +1 @@
+Joe Groff
\ No newline at end of file
diff --git a/extra/opengl/capabilities/capabilities-docs.factor b/extra/opengl/capabilities/capabilities-docs.factor
new file mode 100644
index 0000000000..e73b7a3f0b
--- /dev/null
+++ b/extra/opengl/capabilities/capabilities-docs.factor
@@ -0,0 +1,59 @@
+USING: help.markup help.syntax io kernel math quotations
+opengl.gl multiline assocs ;
+IN: opengl.capabilities
+
+HELP: gl-version
+{ $values { "version" "The version string from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
+
+HELP: gl-vendor-version
+{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
+
+HELP: has-gl-version?
+{ $values { "version" "A version string" } { "?" "A boolean value" } }
+{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
+
+HELP: require-gl-version
+{ $values { "version" "A version string" } }
+{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ;
+
+HELP: glsl-version
+{ $values { "version" "The GLSL version string from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
+
+HELP: glsl-vendor-version
+{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } }
+{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
+
+HELP: has-glsl-version?
+{ $values { "version" "A version string" } { "?" "A boolean value" } }
+{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
+
+HELP: require-glsl-version
+{ $values { "version" "A version string" } }
+{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ;
+
+HELP: gl-extensions
+{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } }
+{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ;
+
+HELP: has-gl-extensions?
+{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
+{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
+
+HELP: has-gl-version-or-extensions?
+{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
+{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
+
+HELP: require-gl-extensions
+{ $values { "extensions" "A sequence of extension name strings" } }
+{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
+
+HELP: require-gl-version-or-extensions
+{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
+{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
+
+{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words
+
+ABOUT: "gl-utilities"
diff --git a/extra/opengl/capabilities/capabilities.factor b/extra/opengl/capabilities/capabilities.factor
new file mode 100644
index 0000000000..d9eb6fd679
--- /dev/null
+++ b/extra/opengl/capabilities/capabilities.factor
@@ -0,0 +1,67 @@
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel namespaces sequences splitting opengl.gl
+continuations math.parser math arrays ;
+IN: opengl.capabilities
+
+: (require-gl) ( thing require-quot make-error-quot -- )
+ >r dupd call
+ [ r> 2drop ]
+ [ r> " " make throw ]
+ if ; inline
+
+: gl-extensions ( -- seq )
+ GL_EXTENSIONS glGetString " " split ;
+: has-gl-extensions? ( extensions -- ? )
+ gl-extensions swap [ over member? ] all? nip ;
+: (make-gl-extensions-error) ( required-extensions -- )
+ gl-extensions swap seq-diff
+ "Required OpenGL extensions not supported:\n" %
+ [ " " % % "\n" % ] each ;
+: require-gl-extensions ( extensions -- )
+ [ has-gl-extensions? ]
+ [ (make-gl-extensions-error) ]
+ (require-gl) ;
+
+: version-seq ( version-string -- version-seq )
+ "." split [ string>number ] map ;
+
+: version<=> ( version1 version2 -- n )
+ swap version-seq swap version-seq <=> ;
+
+: (gl-version) ( -- version vendor )
+ GL_VERSION glGetString " " split1 ;
+: gl-version ( -- version )
+ (gl-version) drop ;
+: gl-vendor-version ( -- version )
+ (gl-version) nip ;
+: has-gl-version? ( version -- ? )
+ gl-version version<=> 0 <= ;
+: (make-gl-version-error) ( required-version -- )
+ "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
+: require-gl-version ( version -- )
+ [ has-gl-version? ]
+ [ (make-gl-version-error) ]
+ (require-gl) ;
+
+: (glsl-version) ( -- version vendor )
+ GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ;
+: glsl-version ( -- version )
+ (glsl-version) drop ;
+: glsl-vendor-version ( -- version )
+ (glsl-version) nip ;
+: has-glsl-version? ( version -- ? )
+ glsl-version version<=> 0 <= ;
+: require-glsl-version ( version -- )
+ [ has-glsl-version? ]
+ [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
+ (require-gl) ;
+
+: has-gl-version-or-extensions? ( version extensions -- ? )
+ has-gl-extensions? swap has-gl-version? or ;
+
+: require-gl-version-or-extensions ( version extensions -- )
+ 2array [ first2 has-gl-version-or-extensions? ] [
+ dup first (make-gl-version-error) "\n" %
+ second (make-gl-extensions-error) "\n" %
+ ] (require-gl) ;
diff --git a/extra/opengl/capabilities/summary.txt b/extra/opengl/capabilities/summary.txt
new file mode 100644
index 0000000000..d31b63b8d4
--- /dev/null
+++ b/extra/opengl/capabilities/summary.txt
@@ -0,0 +1 @@
+Testing for OpenGL versions and extensions
\ No newline at end of file
diff --git a/extra/opengl/capabilities/tags.txt b/extra/opengl/capabilities/tags.txt
new file mode 100644
index 0000000000..77282be3a9
--- /dev/null
+++ b/extra/opengl/capabilities/tags.txt
@@ -0,0 +1,2 @@
+opengl
+bindings
diff --git a/extra/opengl/framebuffers/authors.txt b/extra/opengl/framebuffers/authors.txt
new file mode 100644
index 0000000000..6a0dc7293a
--- /dev/null
+++ b/extra/opengl/framebuffers/authors.txt
@@ -0,0 +1 @@
+Joe Groff
\ No newline at end of file
diff --git a/extra/opengl/framebuffers/framebuffer-docs.factor b/extra/opengl/framebuffers/framebuffer-docs.factor
new file mode 100644
index 0000000000..c5507dcce1
--- /dev/null
+++ b/extra/opengl/framebuffers/framebuffer-docs.factor
@@ -0,0 +1,35 @@
+USING: help.markup help.syntax io kernel math quotations
+opengl.gl multiline assocs ;
+IN: opengl.framebuffers
+
+HELP: gen-framebuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
+
+HELP: gen-renderbuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
+
+HELP: delete-framebuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
+
+HELP: delete-renderbuffer
+{ $values { "id" integer } }
+{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
+
+{ gen-framebuffer delete-framebuffer } related-words
+{ gen-renderbuffer delete-renderbuffer } related-words
+
+HELP: framebuffer-incomplete?
+{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
+
+HELP: check-framebuffer
+{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
+
+HELP: with-framebuffer
+{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
+{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
+
+ABOUT: "gl-utilities"
\ No newline at end of file
diff --git a/extra/opengl/framebuffers/framebuffers.factor b/extra/opengl/framebuffers/framebuffers.factor
new file mode 100644
index 0000000000..346789e1c5
--- /dev/null
+++ b/extra/opengl/framebuffers/framebuffers.factor
@@ -0,0 +1,43 @@
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: opengl opengl.gl combinators continuations kernel
+alien.c-types ;
+IN: opengl.framebuffers
+
+: gen-framebuffer ( -- id )
+ [ glGenFramebuffersEXT ] (gen-gl-object) ;
+: gen-renderbuffer ( -- id )
+ [ glGenRenderbuffersEXT ] (gen-gl-object) ;
+
+: delete-framebuffer ( id -- )
+ [ glDeleteFramebuffersEXT ] (delete-gl-object) ;
+: delete-renderbuffer ( id -- )
+ [ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
+
+: framebuffer-incomplete? ( -- status/f )
+ GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
+ dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
+
+: framebuffer-error ( status -- * )
+ {
+ { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
+ { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
+ { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
+ [ drop gl-error "unknown framebuffer error" ]
+ } case throw ;
+
+: check-framebuffer ( -- )
+ framebuffer-incomplete? [ framebuffer-error ] when* ;
+
+: with-framebuffer ( id quot -- )
+ GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
+ [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
+
+: framebuffer-attachment ( attachment -- id )
+ GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
+ 0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
diff --git a/extra/opengl/framebuffers/summary.txt b/extra/opengl/framebuffers/summary.txt
new file mode 100644
index 0000000000..3ef713ac13
--- /dev/null
+++ b/extra/opengl/framebuffers/summary.txt
@@ -0,0 +1 @@
+Rendering to offscreen textures using the GL_EXT_framebuffer_object extension
\ No newline at end of file
diff --git a/extra/opengl/framebuffers/tags.txt b/extra/opengl/framebuffers/tags.txt
new file mode 100644
index 0000000000..77282be3a9
--- /dev/null
+++ b/extra/opengl/framebuffers/tags.txt
@@ -0,0 +1,2 @@
+opengl
+bindings
diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor
index cb0c9e884f..97120237ec 100644
--- a/extra/opengl/opengl-docs.factor
+++ b/extra/opengl/opengl-docs.factor
@@ -1,5 +1,5 @@
USING: help.markup help.syntax io kernel math quotations
-opengl.gl multiline assocs ;
+opengl.gl multiline assocs vocabs.loader sequences ;
IN: opengl
HELP: gl-color
@@ -57,14 +57,6 @@ HELP: gen-texture
{ $values { "id" integer } }
{ $description "Wrapper for " { $link glGenTextures } " to handle the common case of generating a single texture ID." } ;
-HELP: gen-framebuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ;
-
-HELP: gen-renderbuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ;
-
HELP: gen-gl-buffer
{ $values { "id" integer } }
{ $description "Wrapper for " { $link glGenBuffers } " to handle the common case of generating a single buffer ID." } ;
@@ -73,34 +65,13 @@ HELP: delete-texture
{ $values { "id" integer } }
{ $description "Wrapper for " { $link glDeleteTextures } " to handle the common case of deleting a single texture ID." } ;
-HELP: delete-framebuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ;
-
-HELP: delete-renderbuffer
-{ $values { "id" integer } }
-{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ;
-
HELP: delete-gl-buffer
{ $values { "id" integer } }
{ $description "Wrapper for " { $link glDeleteBuffers } " to handle the common case of deleting a single buffer ID." } ;
{ gen-texture delete-texture } related-words
-{ gen-framebuffer delete-framebuffer } related-words
-{ gen-renderbuffer delete-renderbuffer } related-words
{ gen-gl-buffer delete-gl-buffer } related-words
-HELP: framebuffer-incomplete?
-{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } }
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ;
-
-HELP: check-framebuffer
-{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ;
-
-HELP: with-framebuffer
-{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } }
-{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ;
-
HELP: bind-texture-unit
{ $values { "id" "The id of a texture object." } { "target" "The texture target (e.g., " { $snippet "GL_TEXTURE_2D" } ")" } { "unit" "The texture unit to bind (e.g., " { $snippet "GL_TEXTURE0" } ")" } }
{ $description "Binds texture " { $snippet "id" } " to texture target " { $snippet "target" } " of texture unit " { $snippet "unit" } ". Equivalent to " { $snippet "unit glActiveTexture target id glBindTexture" } "." } ;
@@ -148,175 +119,9 @@ HELP: with-translation
{ $values { "loc" "a pair of integers" } { "quot" quotation } }
{ $description "Calls the quotation with a translation by " { $snippet "loc" } " pixels applied to the current " { $link GL_MODELVIEW } " matrix, restoring the matrix when the quotation is done." } ;
-HELP: gl-shader
-{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:"
- { $list
- { { $link <gl-shader> } " - Compile GLSL code into a shader object" }
- { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" }
- { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" }
- { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" }
- { { $link delete-gl-shader } " - Invalidate a shader object" }
- }
- "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ;
-
-HELP: vertex-shader
-{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:"
- { $list
- { { $link <vertex-shader> } " - Compile GLSL code into a vertex shader object "}
- }
-} ;
-
-HELP: fragment-shader
-{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:"
- { $list
- { { $link <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
- }
-} ;
-
-HELP: <gl-shader>
-{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } }
-{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ;
-
-HELP: <vertex-shader>
-{ $values { "source" "The GLSL source code to compile" } }
-{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER <gl-shader>" } "." } ;
-
-HELP: <fragment-shader>
-{ $values { "source" "The GLSL source code to compile" } }
-{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER <gl-shader>" } "." } ;
-
-HELP: gl-shader-ok?
-{ $values { "shader" "A " { $link gl-shader } " object" } }
-{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ;
-
-HELP: check-gl-shader
-{ $values { "shader" "A " { $link gl-shader } " object" } }
-{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ;
-
-HELP: delete-gl-shader
-{ $values { "shader" "A " { $link gl-shader } " object" } }
-{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
-
-HELP: gl-shader-info-log
-{ $values { "shader" "A " { $link gl-shader } " object" } }
-{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
-
-HELP: gl-program
-{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:"
- { $list
- { { $link <gl-program> } ", " { $link <simple-gl-program> } " - Link a set of shaders into a GLSL program" }
- { { $link gl-program-ok? } " - Check whether a program object linked successfully" }
- { { $link check-gl-program } " - Throw an error unless a program object linked successfully" }
- { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" }
- { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" }
- { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" }
- { { $link with-gl-program } " - Use a program object" }
- }
-} ;
-
-HELP: <gl-program>
-{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } }
-{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
-
-HELP: <simple-gl-program>
-{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } }
-{ $description "Wrapper for " { $link <gl-program> } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ;
-
-{ <gl-program> <simple-gl-program> } related-words
-
-HELP: gl-program-ok?
-{ $values { "program" "A " { $link gl-program } " object" } }
-{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
-
-HELP: check-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } }
-{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ;
-
-HELP: gl-program-info-log
-{ $values { "program" "A " { $link gl-program } " object" } }
-{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ;
-
-HELP: delete-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } }
-{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
-
-HELP: with-gl-program
-{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } }
-{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack for the associated quotation.\n\nExample:" }
-{ $code <"
-! From bunny.cel-shaded
-: (draw-cel-shaded-bunny) ( geom program -- )
- {
- { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
- { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
- { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
- { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
- { "shininess" [ 100.0 glUniform1f ] }
- } [ bunny-geom ] with-gl-program ;
-"> } ;
-
-HELP: gl-version
-{ $values { "version" "The version string from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
-
-HELP: gl-vendor-version
-{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
-
-HELP: has-gl-version?
-{ $values { "version" "A version string" } { "?" "A boolean value" } }
-{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
-
-HELP: require-gl-version
-{ $values { "version" "A version string" } }
-{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ;
-
-HELP: glsl-version
-{ $values { "version" "The GLSL version string from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ;
-
-HELP: glsl-vendor-version
-{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } }
-{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ;
-
-HELP: has-glsl-version?
-{ $values { "version" "A version string" } { "?" "A boolean value" } }
-{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ;
-
-HELP: require-glsl-version
-{ $values { "version" "A version string" } }
-{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ;
-
-HELP: gl-extensions
-{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } }
-{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ;
-
-HELP: has-gl-extensions?
-{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } }
-{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ;
-
-HELP: has-gl-version-or-extensions?
-{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
-{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
-
-HELP: require-gl-extensions
-{ $values { "extensions" "A sequence of extension name strings" } }
-{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ;
-
-HELP: require-gl-version-or-extensions
-{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } }
-{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ;
-
-{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words
-
ARTICLE: "gl-utilities" "OpenGL utility words"
"In addition to the full OpenGL API, the " { $vocab-link "opengl" } " vocabulary includes some utility words to give OpenGL a more Factor-like feel."
$nl
-"Checking implementation capabilities:"
-{ $subsection require-gl-version }
-{ $subsection require-gl-extensions }
-{ $subsection require-glsl-version }
-{ $subsection require-gl-version-or-extensions }
"Wrappers:"
{ $subsection gl-color }
{ $subsection gl-vertex }
@@ -329,8 +134,6 @@ $nl
{ $subsection do-attribs }
{ $subsection do-matrix }
{ $subsection with-translation }
-{ $subsection with-framebuffer }
-{ $subsection with-gl-program }
{ $subsection make-dlist }
"Rendering geometric shapes:"
{ $subsection gl-line }
@@ -339,9 +142,6 @@ $nl
{ $subsection gl-fill-poly }
{ $subsection gl-poly }
{ $subsection gl-gradient }
-"Compiling, linking, and using GLSL programs:"
-{ $subsection gl-shader }
-{ $subsection gl-program }
;
ABOUT: "gl-utilities"
diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor
index 071f85fe12..5afb6ef070 100755
--- a/extra/opengl/opengl.factor
+++ b/extra/opengl/opengl.factor
@@ -33,11 +33,19 @@ IN: opengl
: do-enabled-client-state ( what quot -- )
over glEnableClientState dip glDisableClientState ; inline
-: all-enabled ( seq quot -- )
+: words>values ( word/value-seq -- value-seq )
+ [ dup word? [ execute ] [ ] if ] map ;
+
+: (all-enabled) ( seq quot -- )
over [ glEnable ] each dip [ glDisable ] each ; inline
-: all-enabled-client-state ( seq quot -- )
+: (all-enabled-client-state) ( seq quot -- )
over [ glEnableClientState ] each dip [ glDisableClientState ] each ; inline
+MACRO: all-enabled ( seq quot -- )
+ >r words>values r> [ (all-enabled) ] 2curry ;
+MACRO: all-enabled-client-state ( seq quot -- )
+ >r words>values r> [ (all-enabled-client-state) ] 2curry ;
+
: do-matrix ( mode quot -- )
swap [ glMatrixMode glPushMatrix call ] keep
glMatrixMode glPopMatrix ; inline
@@ -106,10 +114,6 @@ IN: opengl
>r 1 0 <uint> r> keep *uint ; inline
: gen-texture ( -- id )
[ glGenTextures ] (gen-gl-object) ;
-: gen-framebuffer ( -- id )
- [ glGenFramebuffersEXT ] (gen-gl-object) ;
-: gen-renderbuffer ( -- id )
- [ glGenRenderbuffersEXT ] (gen-gl-object) ;
: gen-gl-buffer ( -- id )
[ glGenBuffers ] (gen-gl-object) ;
@@ -117,10 +121,6 @@ IN: opengl
>r 1 swap <uint> r> call ; inline
: delete-texture ( id -- )
[ glDeleteTextures ] (delete-gl-object) ;
-: delete-framebuffer ( id -- )
- [ glDeleteFramebuffersEXT ] (delete-gl-object) ;
-: delete-renderbuffer ( id -- )
- [ glDeleteRenderbuffersEXT ] (delete-gl-object) ;
: delete-gl-buffer ( id -- )
[ glDeleteBuffers ] (delete-gl-object) ;
@@ -141,40 +141,14 @@ IN: opengl
: buffer-offset ( int -- alien )
<alien> ; inline
-: framebuffer-incomplete? ( -- status/f )
- GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
- dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
-
-: framebuffer-error ( status -- * )
- { { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] }
- { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] }
- { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] }
- [ drop gl-error "unknown framebuffer error" ] } case throw ;
-
-: check-framebuffer ( -- )
- framebuffer-incomplete? [ framebuffer-error ] when* ;
-
-: with-framebuffer ( id quot -- )
- GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
- [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
-
: bind-texture-unit ( id target unit -- )
glActiveTexture swap glBindTexture gl-error ;
-: framebuffer-attachment ( attachment -- id )
- GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT
- 0 <uint> [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ;
-
: (set-draw-buffers) ( buffers -- )
dup length swap >c-uint-array glDrawBuffers ;
MACRO: set-draw-buffers ( buffers -- )
- [ dup word? [ execute ] [ ] if ] map [ (set-draw-buffers) ] curry ;
+ words>values [ (set-draw-buffers) ] curry ;
: do-attribs ( bits quot -- )
swap glPushAttrib call glPopAttrib ; inline
@@ -274,196 +248,3 @@ TUPLE: sprite loc dim dim2 dlist texture ;
glLoadIdentity
GL_MODELVIEW glMatrixMode
glLoadIdentity ;
-
-! Shaders
-
-: c-true? ( int -- ? ) zero? not ; inline
-
-: with-gl-shader-source-ptr ( string quot -- )
- swap string>char-alien malloc-byte-array [
- <void*> swap call
- ] keep free ; inline
-
-: <gl-shader> ( source kind -- shader )
- glCreateShader dup rot
- [ 1 swap f glShaderSource ] with-gl-shader-source-ptr
- [ glCompileShader ] keep
- gl-error ;
-
-: (gl-shader?) ( object -- ? )
- dup integer? [ glIsShader c-true? ] [ drop f ] if ;
-
-: gl-shader-get-int ( shader enum -- value )
- 0 <int> [ glGetShaderiv ] keep *int ;
-
-: gl-shader-ok? ( shader -- ? )
- GL_COMPILE_STATUS gl-shader-get-int c-true? ;
-
-: <vertex-shader> ( source -- vertex-shader )
- GL_VERTEX_SHADER <gl-shader> ; inline
-
-: (vertex-shader?) ( object -- ? )
- dup (gl-shader?)
- [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
- [ drop f ] if ;
-
-: <fragment-shader> ( source -- fragment-shader )
- GL_FRAGMENT_SHADER <gl-shader> ; inline
-
-: (fragment-shader?) ( object -- ? )
- dup (gl-shader?)
- [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ]
- [ drop f ] if ;
-
-: gl-shader-info-log-length ( shader -- log-length )
- GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
-
-: gl-shader-info-log ( shader -- log )
- dup gl-shader-info-log-length dup [
- [ 0 <int> swap glGetShaderInfoLog ] keep
- alien>char-string
- ] with-malloc ;
-
-: check-gl-shader ( shader -- shader* )
- dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
-
-: delete-gl-shader ( shader -- ) glDeleteShader ; inline
-
-PREDICATE: integer gl-shader (gl-shader?) ;
-PREDICATE: gl-shader vertex-shader (vertex-shader?) ;
-PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
-
-! Programs
-
-: <gl-program> ( shaders -- program )
- glCreateProgram swap
- [ dupd glAttachShader ] each
- [ glLinkProgram ] keep
- gl-error ;
-
-: (gl-program?) ( object -- ? )
- dup integer? [ glIsProgram c-true? ] [ drop f ] if ;
-
-: gl-program-get-int ( program enum -- value )
- 0 <int> [ glGetProgramiv ] keep *int ;
-
-: gl-program-ok? ( program -- ? )
- GL_LINK_STATUS gl-program-get-int c-true? ;
-
-: gl-program-info-log-length ( program -- log-length )
- GL_INFO_LOG_LENGTH gl-program-get-int ; inline
-
-: gl-program-info-log ( program -- log )
- dup gl-program-info-log-length dup [
- [ 0 <int> swap glGetProgramInfoLog ] keep
- alien>char-string
- ] with-malloc ;
-
-: check-gl-program ( program -- program* )
- dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
-
-: gl-program-shaders-length ( program -- shaders-length )
- GL_ATTACHED_SHADERS gl-program-get-int ; inline
-
-: gl-program-shaders ( program -- shaders )
- dup gl-program-shaders-length [
- dup "GLuint" <c-array>
- [ 0 <int> swap glGetAttachedShaders ] keep
- ] keep c-uint-array> ;
-
-: delete-gl-program-only ( program -- )
- glDeleteProgram ; inline
-
-: detach-gl-program-shader ( program shader -- )
- glDetachShader ; inline
-
-: delete-gl-program ( program -- )
- dup gl-program-shaders [
- 2dup detach-gl-program-shader delete-gl-shader
- ] each delete-gl-program-only ;
-
-: (with-gl-program) ( program quot -- )
- swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
-
-: (with-gl-program-uniforms) ( uniforms -- quot )
- [ [ swap , \ glGetUniformLocation , % ] [ ] make ]
- { } assoc>map ;
-: (make-with-gl-program) ( uniforms quot -- q )
- [
- \ dup ,
- [ swap (with-gl-program-uniforms) , \ call-with , % ]
- [ ] make ,
- \ (with-gl-program) ,
- ] [ ] make ;
-
-MACRO: with-gl-program ( uniforms quot -- )
- (make-with-gl-program) ;
-
-PREDICATE: integer gl-program (gl-program?) ;
-
-: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
- >r <vertex-shader> check-gl-shader
- r> <fragment-shader> check-gl-shader
- 2array <gl-program> check-gl-program ;
-
-: (require-gl) ( thing require-quot make-error-quot -- )
- >r dupd call
- [ r> 2drop ]
- [ r> " " make throw ]
- if ; inline
-
-: gl-extensions ( -- seq )
- GL_EXTENSIONS glGetString " " split ;
-: has-gl-extensions? ( extensions -- ? )
- gl-extensions swap [ over member? ] all? nip ;
-: (make-gl-extensions-error) ( required-extensions -- )
- gl-extensions swap seq-diff
- "Required OpenGL extensions not supported:\n" %
- [ " " % % "\n" % ] each ;
-: require-gl-extensions ( extensions -- )
- [ has-gl-extensions? ]
- [ (make-gl-extensions-error) ]
- (require-gl) ;
-
-: version-seq ( version-string -- version-seq )
- "." split [ string>number ] map ;
-
-: version<=> ( version1 version2 -- n )
- swap version-seq swap version-seq <=> ;
-
-: (gl-version) ( -- version vendor )
- GL_VERSION glGetString " " split1 ;
-: gl-version ( -- version )
- (gl-version) drop ;
-: gl-vendor-version ( -- version )
- (gl-version) nip ;
-: has-gl-version? ( version -- ? )
- gl-version version<=> 0 <= ;
-: (make-gl-version-error) ( required-version -- )
- "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ;
-: require-gl-version ( version -- )
- [ has-gl-version? ]
- [ (make-gl-version-error) ]
- (require-gl) ;
-
-: (glsl-version) ( -- version vendor )
- GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ;
-: glsl-version ( -- version )
- (glsl-version) drop ;
-: glsl-vendor-version ( -- version )
- (glsl-version) nip ;
-: has-glsl-version? ( version -- ? )
- glsl-version version<=> 0 <= ;
-: require-glsl-version ( version -- )
- [ has-glsl-version? ]
- [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ]
- (require-gl) ;
-
-: has-gl-version-or-extensions? ( version extensions -- ? )
- has-gl-extensions? swap has-gl-version? or ;
-
-: require-gl-version-or-extensions ( version extensions -- )
- 2array [ first2 has-gl-version-or-extensions? ] [
- dup first (make-gl-version-error) "\n" %
- second (make-gl-extensions-error) "\n" %
- ] (require-gl) ;
diff --git a/extra/opengl/shaders/authors.txt b/extra/opengl/shaders/authors.txt
new file mode 100644
index 0000000000..6a0dc7293a
--- /dev/null
+++ b/extra/opengl/shaders/authors.txt
@@ -0,0 +1 @@
+Joe Groff
\ No newline at end of file
diff --git a/extra/opengl/shaders/shaders-docs.factor b/extra/opengl/shaders/shaders-docs.factor
new file mode 100644
index 0000000000..e065367323
--- /dev/null
+++ b/extra/opengl/shaders/shaders-docs.factor
@@ -0,0 +1,112 @@
+USING: help.markup help.syntax io kernel math quotations
+opengl.gl multiline assocs ;
+IN: opengl.shaders
+
+HELP: gl-shader
+{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:"
+ { $list
+ { { $link <gl-shader> } " - Compile GLSL code into a shader object" }
+ { { $link gl-shader-ok? } " - Check whether a shader object compiled successfully" }
+ { { $link check-gl-shader } " - Throw an error unless a shader object compiled successfully" }
+ { { $link gl-shader-info-log } " - Retrieve the info log of messages generated by the GLSL compiler" }
+ { { $link delete-gl-shader } " - Invalidate a shader object" }
+ }
+ "The derived predicate classes " { $link vertex-shader } " and " { $link fragment-shader } " are also defined for the two standard kinds of shader defined by the OpenGL specification." } ;
+
+HELP: vertex-shader
+{ $class-description { $snippet "vertex-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_VERTEX_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following vertex shader-specific functions are defined:"
+ { $list
+ { { $link <vertex-shader> } " - Compile GLSL code into a vertex shader object "}
+ }
+} ;
+
+HELP: fragment-shader
+{ $class-description { $snippet "fragment-shader" } " is the predicate class of " { $link gl-shader } " objects that refer to shaders of type " { $snippet "GL_FRAGMENT_SHADER" } ". In addition to the " { $snippet "gl-shader" } " words, the following fragment shader-specific functions are defined:"
+ { $list
+ { { $link <fragment-shader> } " - Compile GLSL code into a fragment shader object "}
+ }
+} ;
+
+HELP: <gl-shader>
+{ $values { "source" "The GLSL source code to compile" } { "kind" "The kind of shader to compile, such as " { $snippet "GL_VERTEX_SHADER" } " or " { $snippet "GL_FRAGMENT_SHADER" } } }
+{ $description "Tries to compile the given GLSL source into a shader object. The returned object can be checked for validity by " { $link check-gl-shader } " or " { $link gl-shader-ok? } ". Errors and warnings generated by the GLSL compiler will be collected in the info log, available from " { $link gl-shader-info-log } ".\n\nWhen the shader object is no longer needed, it should be deleted using " { $link delete-gl-shader } " or else be attached to a " { $link gl-program } " object deleted using " { $link delete-gl-program } "." } ;
+
+HELP: <vertex-shader>
+{ $values { "source" "The GLSL source code to compile" } }
+{ $description "Tries to compile the given GLSL source into a vertex shader object. Equivalent to " { $snippet "GL_VERTEX_SHADER <gl-shader>" } "." } ;
+
+HELP: <fragment-shader>
+{ $values { "source" "The GLSL source code to compile" } }
+{ $description "Tries to compile the given GLSL source into a fragment shader object. Equivalent to " { $snippet "GL_FRAGMENT_SHADER <gl-shader>" } "." } ;
+
+HELP: gl-shader-ok?
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Returns a boolean value indicating whether the given shader object compiled successfully. Compilation errors and warnings are available in the shader's info log, which can be gotten using " { $link gl-shader-info-log } "." } ;
+
+HELP: check-gl-shader
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Throws an error containing the " { $link gl-shader-info-log } " for the shader object if it failed to compile. Otherwise, the shader object is left on the stack." } ;
+
+HELP: delete-gl-shader
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Deletes the shader object, invalidating it and releasing any resources allocated for it by the OpenGL implementation." } ;
+
+HELP: gl-shader-info-log
+{ $values { "shader" "A " { $link gl-shader } " object" } }
+{ $description "Retrieves the info log for " { $snippet "shader" } ", including any errors or warnings generated in compiling the shader object." } ;
+
+HELP: gl-program
+{ $class-description { $snippet "gl-program" } " is a predicate class comprising values returned by OpenGL to represent proram objects. The following words are provided for creating and manipulating these objects:"
+ { $list
+ { { $link <gl-program> } ", " { $link <simple-gl-program> } " - Link a set of shaders into a GLSL program" }
+ { { $link gl-program-ok? } " - Check whether a program object linked successfully" }
+ { { $link check-gl-program } " - Throw an error unless a program object linked successfully" }
+ { { $link gl-program-info-log } " - Retrieve the info log of messages generated by the GLSL linker" }
+ { { $link gl-program-shaders } " - Retrieve the set of shader objects composing the GLSL program" }
+ { { $link delete-gl-program } " - Invalidate a program object and all its attached shaders" }
+ { { $link with-gl-program } " - Use a program object" }
+ }
+} ;
+
+HELP: <gl-program>
+{ $values { "shaders" "A sequence of " { $link gl-shader } " objects." } }
+{ $description "Creates a new GLSL program object, attaches all the shader objects in the " { $snippet "shaders" } " sequence, and attempts to link them. The returned object can be checked for validity by " { $link check-gl-program } " or " { $link gl-program-ok? } ". Errors and warnings generated by the GLSL linker will be collected in the info log, available from " { $link gl-program-info-log } ".\n\nWhen the program object and its attached shaders are no longer needed, it should be deleted using " { $link delete-gl-program } "." } ;
+
+HELP: <simple-gl-program>
+{ $values { "vertex-shader-source" "A string containing GLSL vertex shader source" } { "fragment-shader-source" "A string containing GLSL fragment shader source" } }
+{ $description "Wrapper for " { $link <gl-program> } " for the simple case of compiling a single vertex shader and fragment shader and linking them into a GLSL program. Throws an exception if compiling or linking fails." } ;
+
+{ <gl-program> <simple-gl-program> } related-words
+
+HELP: gl-program-ok?
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ;
+
+HELP: check-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ;
+
+HELP: gl-program-info-log
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ;
+
+HELP: delete-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } }
+{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
+
+HELP: with-gl-program
+{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } }
+{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack as the associated quotation is called.\n\nExample:" }
+{ $code <"
+! From bunny.cel-shaded
+: (draw-cel-shaded-bunny) ( geom program -- )
+ {
+ { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
+ { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
+ { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
+ { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
+ { "shininess" [ 100.0 glUniform1f ] }
+ } [ bunny-geom ] with-gl-program ;
+"> } ;
+
+ABOUT: "gl-utilities"
diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor
new file mode 100644
index 0000000000..0ff708d6d4
--- /dev/null
+++ b/extra/opengl/shaders/shaders.factor
@@ -0,0 +1,134 @@
+! Copyright (C) 2008 Joe Groff.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel opengl.gl alien.c-types continuations namespaces
+assocs alien libc opengl math sequences combinators.lib
+macros arrays ;
+IN: opengl.shaders
+
+: with-gl-shader-source-ptr ( string quot -- )
+ swap string>char-alien malloc-byte-array [
+ <void*> swap call
+ ] keep free ; inline
+
+: <gl-shader> ( source kind -- shader )
+ glCreateShader dup rot
+ [ 1 swap f glShaderSource ] with-gl-shader-source-ptr
+ [ glCompileShader ] keep
+ gl-error ;
+
+: (gl-shader?) ( object -- ? )
+ dup integer? [ glIsShader c-bool> ] [ drop f ] if ;
+
+: gl-shader-get-int ( shader enum -- value )
+ 0 <int> [ glGetShaderiv ] keep *int ;
+
+: gl-shader-ok? ( shader -- ? )
+ GL_COMPILE_STATUS gl-shader-get-int c-bool> ;
+
+: <vertex-shader> ( source -- vertex-shader )
+ GL_VERTEX_SHADER <gl-shader> ; inline
+
+: (vertex-shader?) ( object -- ? )
+ dup (gl-shader?)
+ [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ]
+ [ drop f ] if ;
+
+: <fragment-shader> ( source -- fragment-shader )
+ GL_FRAGMENT_SHADER <gl-shader> ; inline
+
+: (fragment-shader?) ( object -- ? )
+ dup (gl-shader?)
+ [ GL_SHADER_TYPE gl-shader-get-int GL_FRAGMENT_SHADER = ]
+ [ drop f ] if ;
+
+: gl-shader-info-log-length ( shader -- log-length )
+ GL_INFO_LOG_LENGTH gl-shader-get-int ; inline
+
+: gl-shader-info-log ( shader -- log )
+ dup gl-shader-info-log-length dup [
+ [ 0 <int> swap glGetShaderInfoLog ] keep
+ alien>char-string
+ ] with-malloc ;
+
+: check-gl-shader ( shader -- shader* )
+ dup gl-shader-ok? [ dup gl-shader-info-log throw ] unless ;
+
+: delete-gl-shader ( shader -- ) glDeleteShader ; inline
+
+PREDICATE: integer gl-shader (gl-shader?) ;
+PREDICATE: gl-shader vertex-shader (vertex-shader?) ;
+PREDICATE: gl-shader fragment-shader (fragment-shader?) ;
+
+! Programs
+
+: <gl-program> ( shaders -- program )
+ glCreateProgram swap
+ [ dupd glAttachShader ] each
+ [ glLinkProgram ] keep
+ gl-error ;
+
+: (gl-program?) ( object -- ? )
+ dup integer? [ glIsProgram c-bool> ] [ drop f ] if ;
+
+: gl-program-get-int ( program enum -- value )
+ 0 <int> [ glGetProgramiv ] keep *int ;
+
+: gl-program-ok? ( program -- ? )
+ GL_LINK_STATUS gl-program-get-int c-bool> ;
+
+: gl-program-info-log-length ( program -- log-length )
+ GL_INFO_LOG_LENGTH gl-program-get-int ; inline
+
+: gl-program-info-log ( program -- log )
+ dup gl-program-info-log-length dup [
+ [ 0 <int> swap glGetProgramInfoLog ] keep
+ alien>char-string
+ ] with-malloc ;
+
+: check-gl-program ( program -- program* )
+ dup gl-program-ok? [ dup gl-program-info-log throw ] unless ;
+
+: gl-program-shaders-length ( program -- shaders-length )
+ GL_ATTACHED_SHADERS gl-program-get-int ; inline
+
+: gl-program-shaders ( program -- shaders )
+ dup gl-program-shaders-length [
+ dup "GLuint" <c-array>
+ [ 0 <int> swap glGetAttachedShaders ] keep
+ ] keep c-uint-array> ;
+
+: delete-gl-program-only ( program -- )
+ glDeleteProgram ; inline
+
+: detach-gl-program-shader ( program shader -- )
+ glDetachShader ; inline
+
+: delete-gl-program ( program -- )
+ dup gl-program-shaders [
+ 2dup detach-gl-program-shader delete-gl-shader
+ ] each delete-gl-program-only ;
+
+: (with-gl-program) ( program quot -- )
+ swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
+
+: (with-gl-program-uniforms) ( uniforms -- quot )
+ [ [ swap , \ glGetUniformLocation , % ] [ ] make ]
+ { } assoc>map ;
+: (make-with-gl-program) ( uniforms quot -- q )
+ [
+ \ dup ,
+ [ swap (with-gl-program-uniforms) , \ call-with , % ]
+ [ ] make ,
+ \ (with-gl-program) ,
+ ] [ ] make ;
+
+MACRO: with-gl-program ( uniforms quot -- )
+ (make-with-gl-program) ;
+
+PREDICATE: integer gl-program (gl-program?) ;
+
+: <simple-gl-program> ( vertex-shader-source fragment-shader-source -- program )
+ >r <vertex-shader> check-gl-shader
+ r> <fragment-shader> check-gl-shader
+ 2array <gl-program> check-gl-program ;
+
diff --git a/extra/opengl/shaders/summary.txt b/extra/opengl/shaders/summary.txt
new file mode 100644
index 0000000000..c55f76668f
--- /dev/null
+++ b/extra/opengl/shaders/summary.txt
@@ -0,0 +1 @@
+OpenGL Shading Language (GLSL) support
\ No newline at end of file
diff --git a/extra/opengl/shaders/tags.txt b/extra/opengl/shaders/tags.txt
new file mode 100644
index 0000000000..ce0345edc9
--- /dev/null
+++ b/extra/opengl/shaders/tags.txt
@@ -0,0 +1,3 @@
+opengl
+glsl
+bindings
\ No newline at end of file
From 3bc9790b740dd8d989b9b9146f01d472418c4116 Mon Sep 17 00:00:00 2001
From: Joe Groff <arcata@gmail.com>
Date: Sun, 3 Feb 2008 16:19:05 -0800
Subject: [PATCH 36/52] Adjust the bunny position to be better centered
---
extra/bunny/bunny.factor | 2 +-
extra/bunny/model/model.factor | 2 +-
2 files changed, 2 insertions(+), 2 deletions(-)
diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor
index 38f8e32fb6..7cf6132925 100755
--- a/extra/bunny/bunny.factor
+++ b/extra/bunny/bunny.factor
@@ -52,7 +52,7 @@ M: bunny-gadget draw-gadget* ( gadget -- )
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
dup demo-gadget-set-matrices
GL_MODELVIEW glMatrixMode
- 0.0 -0.12 0.0 glTranslatef
+ 0.02 -0.105 0.0 glTranslatef
{ bunny-gadget-geom bunny-gadget-draw } get-slots
draw-bunny ;
diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor
index f2c93eac3e..b238bd8b99 100644
--- a/extra/bunny/model/model.factor
+++ b/extra/bunny/model/model.factor
@@ -92,7 +92,7 @@ M: bunny-buffers bunny-geom
bunny-buffers-array
bunny-buffers-element-array
} get-slots [
- GL_VERTEX_ARRAY GL_NORMAL_ARRAY 2array [
+ { GL_VERTEX_ARRAY GL_NORMAL_ARRAY } [
GL_DOUBLE 0 0 buffer-offset glNormalPointer
dup bunny-buffers-nv "double" heap-size * buffer-offset
3 GL_DOUBLE 0 roll glVertexPointer
From d0e5b238e2c056500e4bab055b404eac04ad7a52 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Sun, 3 Feb 2008 20:36:04 -0600
Subject: [PATCH 37/52] Use new feature
---
extra/tools/deploy/backend/backend.factor | 7 +++++--
1 file changed, 5 insertions(+), 2 deletions(-)
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index f2bd03475f..d768b6a334 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -16,8 +16,11 @@ IN: tools.deploy.backend
: copy-lines ( stream -- )
[ (copy-lines) ] with-disposal ;
-: run-with-output ( descriptor -- )
- <process-stream>
+: run-with-output ( arguments -- )
+ [
+ +arguments+ set
+ +stdout+ +stderr+ set
+ ] H{ } make-assoc <process-stream>
dup duplex-stream-out dispose
copy-lines ;
From 46e02fa30d45f23fe98aed2ff4233fa0eba26415 Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@joy.internal.stack-effects.com>
Date: Mon, 4 Feb 2008 11:50:02 -0600
Subject: [PATCH 38/52] Linux inotify works
---
extra/io/monitor/monitor.factor | 4 ++--
extra/io/unix/linux/linux.factor | 27 +++++++++++-----------
extra/io/windows/nt/monitor/monitor.factor | 7 +++---
3 files changed, 20 insertions(+), 18 deletions(-)
diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor
index 11d1b6ecf9..1d8499b392 100755
--- a/extra/io/monitor/monitor.factor
+++ b/extra/io/monitor/monitor.factor
@@ -17,7 +17,7 @@ TUPLE: monitor queue closed? ;
set-monitor-queue
} monitor construct ;
-HOOK: fill-queue io-backend ( monitor -- assoc )
+HOOK: fill-queue io-backend ( monitor -- )
: changed-file ( changed path -- )
namespace [ append ] change-at ;
@@ -32,7 +32,7 @@ HOOK: <monitor> io-backend ( path recursive? -- monitor )
: next-change ( monitor -- path changed )
dup check-monitor
dup monitor-queue dup assoc-empty? [
- drop dup fill-queue over set-monitor-queue next-change
+ drop dup fill-queue next-change
] [ nip dequeue-change ] if ;
SYMBOL: +add-file+
diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor
index 9751cefe91..1707ac9546 100755
--- a/extra/io/unix/linux/linux.factor
+++ b/extra/io/unix/linux/linux.factor
@@ -54,21 +54,22 @@ TUPLE: inotify watches ;
M: linux-io <monitor> ( path recursive? -- monitor )
drop IN_CHANGE_EVENTS add-watch ;
-: notify-callback ( assoc monitor -- )
- linux-monitor-callback dup
- [ schedule-thread-with ] [ 2drop ] if ;
+: notify-callback ( monitor -- )
+ dup linux-monitor-callback
+ f rot set-linux-monitor-callback
+ [ schedule-thread ] when* ;
-M: linux-io fill-queue ( monitor -- assoc )
+M: linux-io fill-queue ( monitor -- )
dup linux-monitor-callback [
"Cannot wait for changes on the same file from multiple threads" throw
] when
- [ swap set-linux-monitor-callback stop ] callcc1
- swap check-monitor ;
+ [ swap set-linux-monitor-callback stop ] callcc0
+ check-monitor ;
M: linux-monitor dispose ( monitor -- )
dup check-monitor
t over set-monitor-closed?
- H{ } over notify-callback
+ dup notify-callback
remove-watch ;
: ?flag ( n mask symbol -- n )
@@ -106,13 +107,13 @@ M: linux-monitor dispose ( monitor -- )
inotify-event-len "inotify-event" heap-size +
swap >r + r> ;
-: wd>queue ( wd -- queue )
- inotify-event-wd wd>monitor monitor-queue ;
-
: parse-file-notifications ( i buffer -- )
2dup events-exhausted? [ 2drop ] [
- 2dup inotify-event@ dup inotify-event-wd wd>queue
- [ parse-file-notify changed-file ] bind
+ 2dup inotify-event@ dup inotify-event-wd wd>monitor [
+ monitor-queue [
+ parse-file-notify changed-file
+ ] bind
+ ] keep notify-callback
next-event parse-file-notifications
] if ;
@@ -135,7 +136,7 @@ M: inotify-task do-io-task ( task -- )
io-task-port read-notifications f ;
M: linux-io init-io ( -- )
- <select-mx> mx set-global ; ! init-inotify ;
+ <select-mx> dup mx set-global init-inotify ;
T{ linux-io } set-io-backend
diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor
index f2cc4ef92a..d418dff270 100755
--- a/extra/io/windows/nt/monitor/monitor.factor
+++ b/extra/io/windows/nt/monitor/monitor.factor
@@ -78,6 +78,7 @@ M: windows-nt-io <monitor> ( path recursive? -- monitor )
dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero?
[ 3drop ] [ swap <displaced-alien> (changed-files) ] if ;
-M: windows-nt-io fill-queue ( monitor -- assoc )
- dup win32-monitor-path over buffer-ptr rot read-changes
- [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc ;
+M: windows-nt-io fill-queue ( monitor -- )
+ dup win32-monitor-path over buffer-ptr pick read-changes
+ [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc
+ swap set-monitor-queue ;
From f2af000ed040468ed6377ad526c461fbff66b6af Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@joy.internal.stack-effects.com>
Date: Mon, 4 Feb 2008 11:50:20 -0600
Subject: [PATCH 39/52] refresh-all fix, new show word for debugging
---
core/io/crc32/crc32-docs.factor | 10 +++++-----
core/io/crc32/crc32.factor | 2 --
core/io/streams/c/c.factor | 7 +++++++
core/source-files/source-files.factor | 2 +-
extra/tools/deploy/shaker/shaker.factor | 5 -----
5 files changed, 13 insertions(+), 13 deletions(-)
diff --git a/core/io/crc32/crc32-docs.factor b/core/io/crc32/crc32-docs.factor
index 020f2668b0..3855c77cd8 100644
--- a/core/io/crc32/crc32-docs.factor
+++ b/core/io/crc32/crc32-docs.factor
@@ -2,16 +2,16 @@ USING: help.markup help.syntax math ;
IN: io.crc32
HELP: crc32
-{ $values { "seq" "a sequence" } { "n" integer } }
+{ $values { "seq" "a sequence of bytes" } { "n" integer } }
{ $description "Computes the CRC32 checksum of a sequence of bytes." } ;
-HELP: file-crc32
-{ $values { "path" "a pathname string" } { "n" integer } }
-{ $description "Computes the CRC32 checksum of a file's contents." } ;
+HELP: lines-crc32
+{ $values { "lines" "a sequence of strings" } { "n" integer } }
+{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ;
ARTICLE: "io.crc32" "CRC32 checksum calculation"
"The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data."
{ $subsection crc32 }
-{ $subsection file-crc32 } ;
+{ $subsection lines-crc32 } ;
ABOUT: "io.crc32"
diff --git a/core/io/crc32/crc32.factor b/core/io/crc32/crc32.factor
index b83943df48..afe7e4bfb7 100755
--- a/core/io/crc32/crc32.factor
+++ b/core/io/crc32/crc32.factor
@@ -23,8 +23,6 @@ IN: io.crc32
: crc32 ( seq -- n )
>r HEX: ffffffff dup r> [ (crc32) ] each bitxor ;
-: file-crc32 ( path -- n ) file-contents crc32 ;
-
: lines-crc32 ( seq -- n )
HEX: ffffffff tuck [
[ (crc32) ] each CHAR: \n (crc32)
diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor
index b02c3367d4..288ab212d1 100755
--- a/core/io/streams/c/c.factor
+++ b/core/io/streams/c/c.factor
@@ -74,3 +74,10 @@ M: object <file-writer>
M: object <file-appender>
"ab" fopen <c-writer> <plain-writer> ;
+
+: show ( msg -- )
+ #! A word which directly calls primitives. It is used to
+ #! print stuff from contexts where the I/O system would
+ #! otherwise not work (tools.deploy.shaker, the I/O
+ #! multiplexer thread).
+ "\r\n" append stdout-handle fwrite stdout-handle fflush ;
diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor
index 8bbf329491..c974145928 100755
--- a/core/source-files/source-files.factor
+++ b/core/source-files/source-files.factor
@@ -17,7 +17,7 @@ uses definitions ;
: (source-modified?) ( path modified checksum -- ? )
pick file-modified rot [ 0 or ] 2apply >
- [ swap file-crc32 number= not ] [ 2drop f ] if ;
+ [ swap file-lines lines-crc32 = not ] [ 2drop f ] if ;
: source-modified? ( path -- ? )
dup source-files get at [
diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor
index f2b951ad16..16507232ae 100755
--- a/extra/tools/deploy/shaker/shaker.factor
+++ b/extra/tools/deploy/shaker/shaker.factor
@@ -8,11 +8,6 @@ debugger io.streams.c io.streams.duplex io.files io.backend
quotations words.private tools.deploy.config compiler.units ;
IN: tools.deploy.shaker
-: show ( msg -- )
- #! Use primitives directly so that we can print stuff even
- #! after most of the image has been stripped away
- "\r\n" append stdout-handle fwrite stdout-handle fflush ;
-
: strip-init-hooks ( -- )
"Stripping startup hooks" show
"command-line" init-hooks get delete-at
From 53cb45c9ff3a53ea1cce2679e9a772ea94d3b24a Mon Sep 17 00:00:00 2001
From: sheeple <sheeple@joy.internal.stack-effects.com>
Date: Mon, 4 Feb 2008 12:03:48 -0600
Subject: [PATCH 40/52] Fix TYPEDEF: issue
---
extra/unix/linux/linux.factor | 4 +---
extra/unix/solaris/solaris.factor | 2 --
extra/unix/unix.factor | 4 +++-
3 files changed, 4 insertions(+), 6 deletions(-)
diff --git a/extra/unix/linux/linux.factor b/extra/unix/linux/linux.factor
index d25ff71d65..0a3eb7ee5f 100644
--- a/extra/unix/linux/linux.factor
+++ b/extra/unix/linux/linux.factor
@@ -1,10 +1,8 @@
-! Copyright (C) 2005 Slava Pestov.
+! Copyright (C) 2005, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: unix
USING: alien.syntax ;
-TYPEDEF: ulong off_t
-
! Linux.
: O_RDONLY HEX: 0000 ; inline
diff --git a/extra/unix/solaris/solaris.factor b/extra/unix/solaris/solaris.factor
index b4aa8285eb..2bca20c6b6 100644
--- a/extra/unix/solaris/solaris.factor
+++ b/extra/unix/solaris/solaris.factor
@@ -3,8 +3,6 @@
IN: unix
USING: alien.syntax system kernel ;
-TYPEDEF: ulong off_t
-
! Solaris.
: O_RDONLY HEX: 0000 ; inline
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index bcfbb3a214..7c3467b052 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -19,11 +19,13 @@ TYPEDEF: uint time_t
TYPEDEF: uint uid_t
TYPEDEF: ulong size_t
TYPEDEF: ulong u_long
-TYPEDEF: ulonglong off_t
TYPEDEF: ushort mode_t
TYPEDEF: ushort nlink_t
TYPEDEF: void* caddr_t
+TYPEDEF: ulong off_t
+TYPEDEF-IF: bsd? ulonglong off_t
+
C-STRUCT: tm
{ "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?)
{ "int" "min" } ! Minutes: 0-59
From a75afb18d71e6ffb2fdedf3787e6190e94b86ef2 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Mon, 4 Feb 2008 12:58:38 -0600
Subject: [PATCH 41/52] Fix GCC error
---
vm/os-genunix.c | 13 ++++++++++---
1 file changed, 10 insertions(+), 3 deletions(-)
diff --git a/vm/os-genunix.c b/vm/os-genunix.c
index a0bd3e05ae..f582483ce7 100755
--- a/vm/os-genunix.c
+++ b/vm/os-genunix.c
@@ -13,6 +13,7 @@ void init_signals(void)
void early_init(void) { }
#define SUFFIX ".image"
+#define SUFFIX_LEN 6
const char *default_image_path(void)
{
@@ -21,8 +22,14 @@ const char *default_image_path(void)
if(!path)
return "factor.image";
- char *new_path = safe_malloc(PATH_MAX + strlen(SUFFIX) + 1);
- memcpy(new_path,path,strlen(path) + 1);
- strcat(new_path,SUFFIX);
+ /* We can't call strlen() here because with gcc 4.1.2 this
+ causes an internal compiler error. */
+ int len = 0;
+ const char *iter = path;
+ while(*iter) { len++; iter++; }
+
+ char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1);
+ memcpy(new_path,path,len + 1);
+ memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1);
return new_path;
}
From 0311c0a842380aebcf53c026b4215529758637cd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Mon, 4 Feb 2008 13:07:34 -0600
Subject: [PATCH 42/52] Remove broken optimization
---
vm/types.c | 11 +----------
1 file changed, 1 insertion(+), 10 deletions(-)
diff --git a/vm/types.c b/vm/types.c
index 24b5e7ff07..11e92ec754 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -471,8 +471,6 @@ F_STRING* allot_string_internal(CELL capacity)
string->hashcode = F;
string->aux = F;
- set_string_nth(string,capacity,0);
-
return string;
}
@@ -645,14 +643,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size)
} \
type *to_##type##_string(F_STRING *s, bool check) \
{ \
- if(sizeof(type) == sizeof(char)) \
- { \
- if(check && !check_string(s,sizeof(type))) \
- general_error(ERROR_C_STRING,tag_object(s),F,NULL); \
- return (type*)(s + 1); \
- } \
- else \
- return (type*)(string_to_##type##_alien(s,check) + 1); \
+ return (type*)(string_to_##type##_alien(s,check) + 1); \
} \
type *unbox_##type##_string(void) \
{ \
From bc2ce8a77b3f2994bdb07623ea71e942ac77856e Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Mon, 4 Feb 2008 14:05:31 -0600
Subject: [PATCH 43/52] Space one byte per string
---
core/bootstrap/image/image.factor | 2 +-
vm/types.c | 4 ----
vm/types.h | 2 +-
3 files changed, 2 insertions(+), 6 deletions(-)
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index e9ee569fd6..4995d0b572 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -248,7 +248,7 @@ M: wrapper '
emit-seq ;
: pack-string ( string -- newstr )
- dup length 1+ bootstrap-cell align 0 pad-right ;
+ dup length bootstrap-cell align 0 pad-right ;
: emit-string ( string -- ptr )
string type-number object tag-number [
diff --git a/vm/types.c b/vm/types.c
index 11e92ec754..78e74535b8 100755
--- a/vm/types.c
+++ b/vm/types.c
@@ -463,10 +463,6 @@ F_STRING* allot_string_internal(CELL capacity)
{
F_STRING *string = allot_object(STRING_TYPE,string_size(capacity));
- /* strings are null-terminated in memory, even though they also
- have a length field. The null termination allows us to add
- the sizeof(F_STRING) to a Factor string to get a C-style
- char* string for C library calls. */
string->length = tag_fixnum(capacity);
string->hashcode = F;
string->aux = F;
diff --git a/vm/types.h b/vm/types.h
index e5003ea069..62b2e06dd0 100755
--- a/vm/types.h
+++ b/vm/types.h
@@ -11,7 +11,7 @@ INLINE CELL string_capacity(F_STRING* str)
INLINE CELL string_size(CELL size)
{
- return sizeof(F_STRING) + size + 1;
+ return sizeof(F_STRING) + size;
}
DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array)
From dee25cda136cb01c3960946839e43f845e2ec0e7 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 4 Feb 2008 16:20:07 -0600
Subject: [PATCH 44/52] New generic word implementation reduces compile time
---
core/bootstrap/image/image.factor | 53 ++++-----------
core/bootstrap/primitives.factor | 10 +--
core/bootstrap/stage1.factor | 1 +
core/bootstrap/stage2.factor | 2 +-
core/classes/classes.factor | 2 +-
core/classes/union/union.factor | 29 ++++++--
core/compiler/compiler.factor | 2 +-
core/effects/effects.factor | 16 +++--
core/generator/generator.factor | 10 ++-
core/generic/generic-docs.factor | 6 +-
core/generic/generic.factor | 77 ++++++++++++++--------
core/generic/math/math.factor | 9 ++-
core/generic/standard/standard.factor | 53 +++++++++------
core/inference/backend/backend.factor | 10 ++-
core/optimizer/backend/backend.factor | 10 ++-
core/words/words.factor | 3 +-
extra/benchmark/dispatch5/dispatch5.factor | 77 ++++++++++++++++++++++
extra/tools/crossref/crossref.factor | 3 +-
18 files changed, 254 insertions(+), 119 deletions(-)
mode change 100644 => 100755 core/effects/effects.factor
mode change 100644 => 100755 core/optimizer/backend/backend.factor
create mode 100755 extra/benchmark/dispatch5/dispatch5.factor
mode change 100644 => 100755 extra/tools/crossref/crossref.factor
diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor
index e9ee569fd6..10715d2c5c 100755
--- a/core/bootstrap/image/image.factor
+++ b/core/bootstrap/image/image.factor
@@ -203,7 +203,14 @@ M: f '
! Words
+DEFER: emit-word
+
+: emit-generic ( generic -- )
+ dup "default-method" word-prop method-word emit-word
+ "methods" word-prop [ nip method-word emit-word ] assoc-each ;
+
: emit-word ( word -- )
+ dup generic? [ dup emit-generic ] when
[
dup hashcode ' ,
dup word-name ' ,
@@ -224,7 +231,7 @@ M: f '
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
: transfer-word ( word -- word )
- dup target-word [ ] [ word-name no-word ] ?if ;
+ dup target-word swap or ;
: fixup-word ( word -- offset )
transfer-word dup objects get at
@@ -285,17 +292,20 @@ M: float-array ' float-array emit-dummy-array ;
] emit-object ;
: emit-tuple ( obj -- pointer )
- objects get [
+ [
[ tuple>array unclip transfer-word , % ] { } make
tuple type-number dup emit-array
- ] cache ; inline
+ ]
+ ! Hack
+ over class word-name "tombstone" =
+ [ objects get swap cache ] [ call ] if ;
M: tuple ' emit-tuple ;
M: tombstone '
delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup
- word-def first emit-tuple ;
+ word-def first objects get [ emit-tuple ] cache ;
M: array '
array type-number object tag-number emit-array ;
@@ -313,41 +323,6 @@ M: quotation '
] emit-object
] cache ;
-! Vectors and sbufs
-
-M: vector '
- dup length swap underlying '
- tuple type-number tuple tag-number [
- 4 emit-fixnum
- vector ' emit
- f ' emit
- emit ! array ptr
- emit-fixnum ! length
- ] emit-object ;
-
-M: sbuf '
- dup length swap underlying '
- tuple type-number tuple tag-number [
- 4 emit-fixnum
- sbuf ' emit
- f ' emit
- emit ! array ptr
- emit-fixnum ! length
- ] emit-object ;
-
-! Hashes
-
-M: hashtable '
- [ hash-array ' ] keep
- tuple type-number tuple tag-number [
- 5 emit-fixnum
- hashtable ' emit
- f ' emit
- dup hash-count emit-fixnum
- hash-deleted emit-fixnum
- emit ! array ptr
- ] emit-object ;
-
! Curries
M: curry '
diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor
index 545d904c9c..550aac71b0 100755
--- a/core/bootstrap/primitives.factor
+++ b/core/bootstrap/primitives.factor
@@ -118,11 +118,11 @@ H{ } clone update-map set
H{ } clone typemap set
num-types get f <array> builtins set
-! These symbols are needed by the code that executes below
-{
- { "object" "kernel" }
- { "null" "kernel" }
-} [ create drop ] assoc-each
+! Forward definitions
+"object" "kernel" create t "class" set-word-prop
+"object" "kernel" create union-class "metaclass" set-word-prop
+
+"null" "kernel" create drop
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor
index 8af1bfdec9..cc328e9760 100755
--- a/core/bootstrap/stage1.factor
+++ b/core/bootstrap/stage1.factor
@@ -32,6 +32,7 @@ vocabs.loader system ;
"io.streams.c" require
"vocabs.loader" require
+
"syntax" require
"bootstrap.layouts" require
diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor
index 5a5a8d1c67..7a0fab8a99 100755
--- a/core/bootstrap/stage2.factor
+++ b/core/bootstrap/stage2.factor
@@ -15,7 +15,7 @@ IN: bootstrap.stage2
vm file-name windows? [ "." split1 drop ] when
".image" append "output-image" set-global
- "math tools help compiler ui ui.tools io" "include" set-global
+ "math help compiler tools ui ui.tools io" "include" set-global
"" "exclude" set-global
parse-command-line
diff --git a/core/classes/classes.factor b/core/classes/classes.factor
index a6a1db7045..151429bf69 100755
--- a/core/classes/classes.factor
+++ b/core/classes/classes.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: classes
USING: arrays definitions assocs kernel
diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor
index 0adbdc080d..332903d36b 100755
--- a/core/classes/union/union.factor
+++ b/core/classes/union/union.factor
@@ -1,19 +1,34 @@
-! Copyright (C) 2004, 2007 Slava Pestov.
+! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words sequences kernel assocs combinators classes
-generic.standard namespaces arrays ;
+generic.standard namespaces arrays math quotations ;
IN: classes.union
PREDICATE: class union-class
"metaclass" word-prop union-class eq? ;
! Union classes for dispatch on multiple classes.
+: small-union-predicate-quot ( members -- quot )
+ dup empty? [
+ drop [ drop f ]
+ ] [
+ unclip first "predicate" word-prop swap
+ [ >r "predicate" word-prop [ dup ] swap append r> ]
+ assoc-map alist>quot
+ ] if ;
+
+: big-union-predicate-quot ( members -- quot )
+ [ small-union-predicate-quot ] [ dup ]
+ class-hash-dispatch-quot ;
+
: union-predicate-quot ( members -- quot )
- 0 (dispatch#) [
- [ [ drop t ] ] { } map>assoc
- object bootstrap-word [ drop f ] 2array add*
- single-combination
- ] with-variable ;
+ [ [ drop t ] ] { } map>assoc
+ dup length 4 <= [
+ small-union-predicate-quot
+ ] [
+ flatten-methods
+ big-union-predicate-quot
+ ] if ;
: define-union-predicate ( class -- )
dup predicate-word
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index 1e6d4f8a17..631c2e4f53 100755
--- a/core/compiler/compiler.factor
+++ b/core/compiler/compiler.factor
@@ -26,7 +26,7 @@ IN: compiler
>r dupd save-effect r>
f pick compiler-error
over compiled-unxref
- over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
+ compiled-xref ;
: compile-succeeded ( word -- effect dependencies )
[
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
old mode 100644
new mode 100755
index ee929507c8..10ebca6dea
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -42,12 +42,16 @@ M: integer (stack-picture) drop "object" ;
] "" make ;
: stack-effect ( word -- effect/f )
- dup symbol? [
- drop 0 1 <effect>
- ] [
- { "declared-effect" "inferred-effect" }
- swap word-props [ at ] curry map [ ] find nip
- ] if ;
+ {
+ { [ dup symbol? ] [ drop 0 1 <effect> ] }
+ { [ dup "parent-generic" word-prop ] [
+ "parent-generic" word-prop stack-effect
+ ] }
+ { [ t ] [
+ { "declared-effect" "inferred-effect" }
+ swap word-props [ at ] curry map [ ] find nip
+ ] }
+ } cond ;
M: effect clone
[ effect-in clone ] keep effect-out clone <effect> ;
diff --git a/core/generator/generator.factor b/core/generator/generator.factor
index de80872b73..3d66241bc3 100755
--- a/core/generator/generator.factor
+++ b/core/generator/generator.factor
@@ -154,9 +154,17 @@ M: #if generate-node
] generate-1
] keep ;
+: tail-dispatch? ( node -- ? )
+ #! Is the dispatch a jump to a tail call to a word?
+ dup #call? swap node-successor #return? and ;
+
: dispatch-branches ( node -- )
node-children [
- compiling-word get dispatch-branch %dispatch-label
+ dup tail-dispatch? [
+ node-param
+ ] [
+ compiling-word get dispatch-branch
+ ] if %dispatch-label
] each ;
M: #dispatch generate-node
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index f1cdae1c91..f4da9575e9 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -125,16 +125,12 @@ HELP: method
{ $description "Looks up a method definition." }
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
-{ method method-def method-loc define-method POSTPONE: M: } related-words
+{ method define-method POSTPONE: M: } related-words
HELP: <method>
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
{ $description "Creates a new "{ $link method } " instance." } ;
-HELP: sort-methods
-{ $values { "assoc" "an assoc mapping classes to methods" } { "newassoc" "an association list mapping classes to quotations" } }
-{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
-
HELP: methods
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index c75dd41d74..951813dbcd 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -5,12 +5,7 @@ definitions kernel.private classes classes.private
quotations arrays vocabs ;
IN: generic
-PREDICATE: word generic "combination" word-prop >boolean ;
-
-M: generic definer drop f f ;
-
-M: generic definition drop f ;
-
+! Method combination protocol
GENERIC: perform-combination ( word combination -- quot )
M: object perform-combination
@@ -22,22 +17,22 @@ M: object perform-combination
#! the method will throw an error. We don't want that.
nip [ "Invalid method combination" throw ] curry [ ] like ;
+GENERIC: method-prologue ( class combination -- quot )
+
+M: object method-prologue 2drop [ ] ;
+
+GENERIC: make-default-method ( generic combination -- method )
+
+PREDICATE: word generic "combination" word-prop >boolean ;
+
+M: generic definer drop f f ;
+
+M: generic definition drop f ;
+
: make-generic ( word -- )
dup dup "combination" word-prop perform-combination define ;
-: init-methods ( word -- )
- dup "methods" word-prop
- H{ } assoc-like
- "methods" set-word-prop ;
-
-: define-generic ( word combination -- )
- dupd "combination" set-word-prop
- dup init-methods make-generic ;
-
-TUPLE: method loc def ;
-
-: <method> ( def -- method )
- { set-method-def } \ method construct ;
+TUPLE: method word def specializer generic loc ;
: method ( class generic -- method/f )
"methods" word-prop at ;
@@ -48,12 +43,10 @@ PREDICATE: pair method-spec
: order ( generic -- seq )
"methods" word-prop keys sort-classes ;
-: sort-methods ( assoc -- newassoc )
- [ keys sort-classes ] keep
- [ dupd at method-def ] curry { } map>assoc ;
-
: methods ( word -- assoc )
- "methods" word-prop sort-methods ;
+ "methods" word-prop
+ [ keys sort-classes ] keep
+ [ dupd at method-word ] curry { } map>assoc ;
TUPLE: check-method class generic ;
@@ -66,10 +59,31 @@ TUPLE: check-method class generic ;
swap [ "methods" word-prop swap call ] keep make-generic ;
inline
-: define-method ( method class generic -- )
- >r >r <method> r> bootstrap-word r> check-method
+: method-word-name ( class word -- string )
+ word-name "/" rot word-name 3append ;
+
+: make-method-def ( quot word combination -- quot )
+ "combination" word-prop method-prologue swap append ;
+
+: <method-word> ( quot class generic -- word )
+ [ make-method-def ] 2keep
+ [ method-word-name f <word> dup ] keep
+ "parent-generic" set-word-prop
+ dup rot define ;
+
+: <method> ( quot class generic -- method )
+ check-method
+ [ <method-word> ] 3keep f \ method construct-boa ;
+
+: define-method ( quot class generic -- )
+ >r bootstrap-word r>
+ [ <method> ] 2keep
[ set-at ] with-methods ;
+: define-default-method ( generic combination -- )
+ dupd make-default-method object bootstrap-word pick <method>
+ "default-method" set-word-prop ;
+
! Definition protocol
M: method-spec where
dup first2 method [ method-loc ] [ second where ] ?if ;
@@ -105,3 +119,14 @@ M: class forget* ( class -- )
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
+
+: init-methods ( word -- )
+ dup "methods" word-prop
+ H{ } assoc-like
+ "methods" set-word-prop ;
+
+: define-generic ( word combination -- )
+ 2dup "combination" set-word-prop
+ dupd define-default-method
+ dup init-methods
+ make-generic ;
diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor
index d5079c5dfb..8cf83b0ba7 100755
--- a/core/generic/math/math.factor
+++ b/core/generic/math/math.factor
@@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ;
: no-math-method ( left right generic -- * )
\ no-math-method construct-boa throw ;
+: default-math-method ( generic -- quot )
+ [ no-math-method ] curry [ ] like ;
+
: applicable-method ( generic class -- quot )
over method
- [ method-def ] [ [ no-math-method ] curry [ ] like ] ?if ;
+ [ method-word word-def ]
+ [ default-math-method ] ?if ;
: object-method ( generic -- quot )
object bootstrap-word applicable-method ;
@@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ;
TUPLE: math-combination ;
+M: math-combination make-default-method
+ drop default-math-method ;
+
M: math-combination perform-combination
drop
\ over [
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 6cc7f7f3e8..94ac82a0e4 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -8,6 +8,10 @@ IN: generic.standard
TUPLE: standard-combination # ;
+M: standard-combination method-prologue
+ standard-combination-# object
+ <array> swap add [ declare ] curry ;
+
C: <standard-combination> standard-combination
SYMBOL: (dispatch#)
@@ -31,10 +35,10 @@ TUPLE: no-method object generic ;
: no-method ( object generic -- * )
\ no-method construct-boa throw ;
-: error-method ( word -- method )
+: error-method ( word -- quot )
picker swap [ no-method ] curry append ;
-: empty-method ( word -- method )
+: empty-method ( word -- quot )
[
picker % [ delegate dup ] %
unpicker over add ,
@@ -65,13 +69,15 @@ TUPLE: no-method object generic ;
] if ;
: default-method ( word -- pair )
- empty-method object bootstrap-word swap 2array ;
+ "default-method" word-prop method-word
+ object bootstrap-word swap 2array ;
: method-alist>quot ( alist base-class -- quot )
bootstrap-word swap simplify-alist
class-predicates alist>quot ;
: small-generic ( methods -- def )
+ [ 1quotation ] assoc-map
object method-alist>quot ;
: hash-methods ( methods -- buckets )
@@ -83,9 +89,12 @@ TUPLE: no-method object generic ;
] if
] distribute-buckets ;
+: class-hash-dispatch-quot ( methods quot picker -- quot )
+ >r >r hash-methods r> map
+ hash-dispatch-quot r> [ class-hash ] rot 3append ;
+
: big-generic ( methods -- quot )
- hash-methods [ small-generic ] map
- hash-dispatch-quot picker [ class-hash ] rot 3append ;
+ [ small-generic ] picker class-hash-dispatch-quot ;
: vtable-class ( n -- class )
type>class [ hi-tag bootstrap-word ] unless* ;
@@ -100,7 +109,8 @@ TUPLE: no-method object generic ;
: build-type-vtable ( alist-seq -- alist-seq )
dup length [
- vtable-class swap simplify-alist
+ vtable-class
+ swap [ word-def ] assoc-map simplify-alist
class-predicates alist>quot
] 2map ;
@@ -137,30 +147,35 @@ TUPLE: no-method object generic ;
: standard-methods ( word -- alist )
dup methods swap default-method add* ;
+M: standard-combination make-default-method
+ standard-combination-# (dispatch#)
+ [ empty-method ] with-variable ;
+
M: standard-combination perform-combination
standard-combination-# (dispatch#) [
[ standard-methods ] keep "inline" word-prop
[ small-generic ] [ single-combination ] if
] with-variable ;
-: default-hook-method ( word -- pair )
- error-method object bootstrap-word swap 2array ;
-
-: hook-methods ( word -- methods )
- dup methods [ [ drop ] swap append ] assoc-map
- swap default-hook-method add* ;
-
TUPLE: hook-combination var ;
C: <hook-combination> hook-combination
-M: hook-combination perform-combination
+M: hook-combination method-prologue
+ 2drop [ drop ] ;
+
+: with-hook ( combination quot -- quot' )
0 (dispatch#) [
- [
- hook-combination-var [ get ] curry %
- hook-methods single-combination %
- ] [ ] make
- ] with-variable ;
+ swap slip
+ hook-combination-var [ get ] curry
+ swap append
+ ] with-variable ; inline
+
+M: hook-combination make-default-method
+ [ error-method ] with-hook ;
+
+M: hook-combination perform-combination
+ [ standard-methods single-combination ] with-hook ;
: define-simple-generic ( word -- )
T{ standard-combination f 0 } define-generic ;
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index 121c555d29..34179bbf32 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -9,9 +9,13 @@ IN: inference.backend
: recursive-label ( word -- label/f )
recursive-state get at ;
+: inline? ( word -- ? )
+ dup "parent-generic" word-prop
+ [ inline? ] [ "inline" word-prop ] ?if ;
+
: local-recursive-state ( -- assoc )
recursive-state get dup keys
- [ dup word? [ "inline" word-prop ] when not ] find drop
+ [ dup word? [ inline? ] when not ] find drop
[ head-slice ] when* ;
: inline-recursive-label ( word -- label/f )
@@ -157,7 +161,7 @@ TUPLE: too-many-r> ;
meta-d get push-all ;
: if-inline ( word true false -- )
- >r >r dup "inline" word-prop r> r> if ; inline
+ >r >r dup inline? r> r> if ; inline
: consume/produce ( effect node -- )
over effect-in over consume-values
@@ -331,7 +335,7 @@ TUPLE: unbalanced-branches-error quots in out ;
#merge node, ; inline
: make-call-node ( word effect -- )
- swap dup "inline" word-prop
+ swap dup inline?
over dup recursive-label eq? not and [
meta-d get clone -rot
recursive-label #call-label [ consume/produce ] keep
diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor
old mode 100644
new mode 100755
index 4843a9ff26..27b1b1e0ec
--- a/core/optimizer/backend/backend.factor
+++ b/core/optimizer/backend/backend.factor
@@ -245,11 +245,19 @@ M: #dispatch optimize-node*
: dispatching-class ( node word -- class )
[ dispatch# node-class# ] keep specific-method ;
+: flat-length ( seq -- n )
+ [
+ dup quotation? over array? or
+ [ flat-length ] [ drop 1 ] if
+ ] map sum ;
+
: will-inline-method ( node word -- method-spec/t quot/t )
#! t indicates failure
tuck dispatching-class dup [
swap [ 2array ] 2keep
- method method-def
+ method method-word
+ dup word-def flat-length 5 >=
+ [ 1quotation ] [ word-def ] if
] [
2drop t t
] if ;
diff --git a/core/words/words.factor b/core/words/words.factor
index 5dc89212a8..b4062d8f02 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -154,7 +154,8 @@ SYMBOL: changed-words
} reset-props ;
: reset-generic ( word -- )
- dup reset-word { "methods" "combination" } reset-props ;
+ dup reset-word
+ { "methods" "combination" "default-method" } reset-props ;
: gensym ( -- word )
"G:" \ gensym counter number>string append f <word> ;
diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor
new file mode 100755
index 0000000000..34df715f89
--- /dev/null
+++ b/extra/benchmark/dispatch5/dispatch5.factor
@@ -0,0 +1,77 @@
+USING: classes kernel sequences vocabs math ;
+IN: benchmark.dispatch5
+
+MIXIN: g
+
+TUPLE: x1 ;
+INSTANCE: x1 g
+TUPLE: x2 ;
+INSTANCE: x2 g
+TUPLE: x3 ;
+INSTANCE: x3 g
+TUPLE: x4 ;
+INSTANCE: x4 g
+TUPLE: x5 ;
+INSTANCE: x5 g
+TUPLE: x6 ;
+INSTANCE: x6 g
+TUPLE: x7 ;
+INSTANCE: x7 g
+TUPLE: x8 ;
+INSTANCE: x8 g
+TUPLE: x9 ;
+INSTANCE: x9 g
+TUPLE: x10 ;
+INSTANCE: x10 g
+TUPLE: x11 ;
+INSTANCE: x11 g
+TUPLE: x12 ;
+INSTANCE: x12 g
+TUPLE: x13 ;
+INSTANCE: x13 g
+TUPLE: x14 ;
+INSTANCE: x14 g
+TUPLE: x15 ;
+INSTANCE: x15 g
+TUPLE: x16 ;
+INSTANCE: x16 g
+TUPLE: x17 ;
+INSTANCE: x17 g
+TUPLE: x18 ;
+INSTANCE: x18 g
+TUPLE: x19 ;
+INSTANCE: x19 g
+TUPLE: x20 ;
+INSTANCE: x20 g
+TUPLE: x21 ;
+INSTANCE: x21 g
+TUPLE: x22 ;
+INSTANCE: x22 g
+TUPLE: x23 ;
+INSTANCE: x23 g
+TUPLE: x24 ;
+INSTANCE: x24 g
+TUPLE: x25 ;
+INSTANCE: x25 g
+TUPLE: x26 ;
+INSTANCE: x26 g
+TUPLE: x27 ;
+INSTANCE: x27 g
+TUPLE: x28 ;
+INSTANCE: x28 g
+TUPLE: x29 ;
+INSTANCE: x29 g
+TUPLE: x30 ;
+INSTANCE: x30 g
+
+: my-classes ( -- seq )
+ "benchmark.dispatch5" words [ tuple-class? ] subset ;
+
+: a-bunch-of-objects ( -- seq )
+ my-classes [ construct-empty ] map ;
+
+: dispatch-benchmark ( -- )
+ 1000000 a-bunch-of-objects
+ [ f [ g? or ] reduce drop ] curry times ;
+
+MAIN: dispatch-benchmark
diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor
old mode 100644
new mode 100755
index dfb421c8f8..663df61926
--- a/extra/tools/crossref/crossref.factor
+++ b/extra/tools/crossref/crossref.factor
@@ -14,8 +14,7 @@ IN: tools.crossref
: (method-usage) ( word generic -- methods )
tuck methods
- [ second quot-uses key? ] with subset
- 0 <column>
+ [ second uses member? ] with subset keys
swap [ 2array ] curry map ;
: method-usage ( word seq -- methods )
From 37bb75b19b1ce245e2522d4d6511b4e7e05dbc3d Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 4 Feb 2008 16:50:15 -0600
Subject: [PATCH 45/52] Fix extra/delegate
---
extra/delegate/delegate.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor
index 4cd25baeb9..c0da9c51bc 100755
--- a/extra/delegate/delegate.factor
+++ b/extra/delegate/delegate.factor
@@ -27,7 +27,7 @@ M: tuple-class group-words
swap [ slot-spec-writer ] map append ;
: define-consult-method ( word class quot -- )
- pick add <method> spin define-method ;
+ pick add spin define-method ;
: define-consult ( class group quot -- )
>r group-words r>
From 123aabc730b17e49f8ba27804514f4159db1fe43 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 4 Feb 2008 17:33:59 -0600
Subject: [PATCH 46/52] Fix Mac Intel alignment issue
---
core/cpu/x86/32/32.factor | 4 ++++
1 file changed, 4 insertions(+)
diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor
index d3e33c46bd..4ed186d769 100755
--- a/core/cpu/x86/32/32.factor
+++ b/core/cpu/x86/32/32.factor
@@ -261,6 +261,10 @@ windows? [
cell "ulonglong" c-type set-c-type-align
] unless
+macosx? [
+ cell "double" c-type set-c-type-align
+] when
+
T{ x86-backend f 4 } compiler-backend set-global
: sse2? "Intrinsic" throw ;
From e9b5a6b9d30a1ad21d46978731c4ffc202df8b43 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 4 Feb 2008 19:38:19 -0600
Subject: [PATCH 47/52] with-process-stream waits for process exit
---
extra/io/launcher/launcher-docs.factor | 4 ++--
extra/io/launcher/launcher.factor | 4 ++--
2 files changed, 4 insertions(+), 4 deletions(-)
diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor
index c30516a83f..e372f7a41e 100755
--- a/extra/io/launcher/launcher-docs.factor
+++ b/extra/io/launcher/launcher-docs.factor
@@ -146,8 +146,8 @@ HELP: with-process-stream
{ $values
{ "desc" "a launch descriptor" }
{ "quot" quotation }
- { "process" process } }
-{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". When the quotation returns, the " { $link process } " instance is output." } ;
+ { "status" "an exit code" } }
+{ $description "Calls " { $snippet "quot" } " in a dynamic scope where " { $link stdio } " is rebound to a " { $link process-stream } ". After the quotation returns, waits for the process to end and outputs the exit code." } ;
HELP: wait-for-process
{ $values { "process" process } { "status" integer } }
diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor
index 09a77fe985..9be90d28de 100755
--- a/extra/io/launcher/launcher.factor
+++ b/extra/io/launcher/launcher.factor
@@ -98,10 +98,10 @@ TUPLE: process-stream process ;
{ set-delegate set-process-stream-process }
process-stream construct ;
-: with-process-stream ( desc quot -- process )
+: with-process-stream ( desc quot -- status )
swap <process-stream>
[ swap with-stream ] keep
- process-stream-process ; inline
+ process-stream-process wait-for-process ; inline
: notify-exit ( status process -- )
[ set-process-status ] keep
From 2872bc9d306c553b1546a46983d660d36e6dcafd Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 4 Feb 2008 19:38:31 -0600
Subject: [PATCH 48/52] More method cleanups
---
core/compiler/compiler.factor | 2 +-
core/effects/effects.factor | 20 +++++++----------
core/generic/generic-docs.factor | 4 ----
core/generic/generic-tests.factor | 3 +++
core/generic/generic.factor | 32 +++++++++++++++------------
core/generic/standard/standard.factor | 2 +-
core/inference/backend/backend.factor | 4 ++--
core/words/words.factor | 5 ++++-
8 files changed, 37 insertions(+), 35 deletions(-)
diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor
index 631c2e4f53..2674734483 100755
--- a/core/compiler/compiler.factor
+++ b/core/compiler/compiler.factor
@@ -26,7 +26,7 @@ IN: compiler
>r dupd save-effect r>
f pick compiler-error
over compiled-unxref
- compiled-xref ;
+ over crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[
diff --git a/core/effects/effects.factor b/core/effects/effects.factor
index 10ebca6dea..23e8daf122 100755
--- a/core/effects/effects.factor
+++ b/core/effects/effects.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel math namespaces sequences strings words assocs
combinators ;
@@ -41,17 +41,13 @@ M: integer (stack-picture) drop "object" ;
")" %
] "" make ;
-: stack-effect ( word -- effect/f )
- {
- { [ dup symbol? ] [ drop 0 1 <effect> ] }
- { [ dup "parent-generic" word-prop ] [
- "parent-generic" word-prop stack-effect
- ] }
- { [ t ] [
- { "declared-effect" "inferred-effect" }
- swap word-props [ at ] curry map [ ] find nip
- ] }
- } cond ;
+GENERIC: stack-effect ( word -- effect/f )
+
+M: symbol stack-effect drop 0 1 <effect> ;
+
+M: word stack-effect
+ { "declared-effect" "inferred-effect" }
+ swap word-props [ at ] curry map [ ] find nip ;
M: effect clone
[ effect-in clone ] keep effect-out clone <effect> ;
diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor
index f4da9575e9..631aa7e62d 100755
--- a/core/generic/generic-docs.factor
+++ b/core/generic/generic-docs.factor
@@ -107,10 +107,6 @@ HELP: make-generic
{ $description "Regenerates the definition of a generic word by applying the method combination to the set of defined methods." }
$low-level-note ;
-HELP: init-methods
-{ $values { "word" word } }
-{ $description "Prepare to define a generic word." } ;
-
HELP: define-generic
{ $values { "word" word } { "combination" "a method combination" } }
{ $description "Defines a generic word. A method combination is an object which responds to the " { $link perform-combination } " generic word." }
diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor
index dc888ec30c..f0d5bf3063 100755
--- a/core/generic/generic-tests.factor
+++ b/core/generic/generic-tests.factor
@@ -176,6 +176,9 @@ M: f tag-and-f 4 ;
! define-class hashing issue
TUPLE: debug-combination ;
+M: debug-combination make-default-method
+ 2drop [ "Oops" throw ] when ;
+
M: debug-combination perform-combination
drop
order [ dup class-hashes ] { } map>assoc sort-keys
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 951813dbcd..78577eaed4 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2006, 2007 Slava Pestov.
+! Copyright (C) 2006, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: words kernel sequences namespaces assocs hashtables
definitions kernel.private classes classes.private
-quotations arrays vocabs ;
+quotations arrays vocabs effects ;
IN: generic
! Method combination protocol
@@ -65,15 +65,20 @@ TUPLE: check-method class generic ;
: make-method-def ( quot word combination -- quot )
"combination" word-prop method-prologue swap append ;
+PREDICATE: word method-body "method" word-prop >boolean ;
+
+M: method-body stack-effect
+ "method" word-prop method-generic stack-effect ;
+
: <method-word> ( quot class generic -- word )
[ make-method-def ] 2keep
- [ method-word-name f <word> dup ] keep
- "parent-generic" set-word-prop
+ method-word-name f <word>
dup rot define ;
: <method> ( quot class generic -- method )
check-method
- [ <method-word> ] 3keep f \ method construct-boa ;
+ [ <method-word> ] 3keep f \ method construct-boa
+ dup method-word over "method" set-word-prop ;
: define-method ( quot class generic -- )
>r bootstrap-word r>
@@ -120,13 +125,12 @@ M: class forget* ( class -- )
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
-: init-methods ( word -- )
- dup "methods" word-prop
- H{ } assoc-like
- "methods" set-word-prop ;
-
: define-generic ( word combination -- )
- 2dup "combination" set-word-prop
- dupd define-default-method
- dup init-methods
- make-generic ;
+ over "combination" word-prop over = [
+ 2drop
+ ] [
+ 2dup "combination" set-word-prop
+ over H{ } clone "methods" set-word-prop
+ dupd define-default-method
+ make-generic
+ ] if ;
diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor
index 94ac82a0e4..d52208ccbf 100755
--- a/core/generic/standard/standard.factor
+++ b/core/generic/standard/standard.factor
@@ -10,7 +10,7 @@ TUPLE: standard-combination # ;
M: standard-combination method-prologue
standard-combination-# object
- <array> swap add [ declare ] curry ;
+ <array> swap add* [ declare ] curry ;
C: <standard-combination> standard-combination
diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor
index 34179bbf32..b839b047d6 100755
--- a/core/inference/backend/backend.factor
+++ b/core/inference/backend/backend.factor
@@ -10,8 +10,8 @@ IN: inference.backend
recursive-state get at ;
: inline? ( word -- ? )
- dup "parent-generic" word-prop
- [ inline? ] [ "inline" word-prop ] ?if ;
+ dup "method" word-prop
+ [ method-generic inline? ] [ "inline" word-prop ] ?if ;
: local-recursive-state ( -- assoc )
recursive-state get dup keys
diff --git a/core/words/words.factor b/core/words/words.factor
index b4062d8f02..93b1185335 100755
--- a/core/words/words.factor
+++ b/core/words/words.factor
@@ -116,13 +116,16 @@ SYMBOL: changed-words
[ no-compilation-unit ] unless*
set-at ;
+: crossref? ( word -- ? )
+ dup word-vocabulary swap "method" word-prop or ;
+
: define ( word def -- )
[ ] like
over unxref
over redefined
over set-word-def
dup changed-word
- dup word-vocabulary [ dup xref ] when drop ;
+ dup crossref? [ dup xref ] when drop ;
: define-declared ( word def effect -- )
pick swap "declared-effect" set-word-prop
From 77a2a2136a0d4837c6f00e66d784fce9bf8d8a97 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 4 Feb 2008 19:43:10 -0600
Subject: [PATCH 49/52] Better method usages work in progres
---
core/generic/generic.factor | 10 ++++++++++
1 file changed, 10 insertions(+)
diff --git a/core/generic/generic.factor b/core/generic/generic.factor
index 78577eaed4..2100f49423 100755
--- a/core/generic/generic.factor
+++ b/core/generic/generic.factor
@@ -134,3 +134,13 @@ M: assoc update-methods ( assoc -- )
dupd define-default-method
make-generic
] if ;
+
+: subwords ( generic -- seq )
+ dup "methods" word-prop values
+ swap "default-method" word-prop add
+ [ method-word ] map ;
+
+: xref-generics ( -- )
+ all-words
+ [ generic? ] subset
+ [ subwords [ xref ] each ] each ;
From 3433adefbe9e8397e5a0f84b4275b50d4da100f0 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 4 Feb 2008 19:58:07 -0600
Subject: [PATCH 50/52] Fix wait-for-pid
---
extra/unix/process/process.factor | 2 +-
extra/unix/unix.factor | 36 +++++++++++++++++++------------
2 files changed, 23 insertions(+), 15 deletions(-)
diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor
index fb4271ea23..8b7144b979 100755
--- a/extra/unix/process/process.factor
+++ b/extra/unix/process/process.factor
@@ -32,4 +32,4 @@ IN: unix.process
fork dup zero? -roll swap curry if ; inline
: wait-for-pid ( pid -- status )
- 0 <int> [ 0 waitpid drop ] keep *int ;
\ No newline at end of file
+ 0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;
\ No newline at end of file
diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor
index 7c3467b052..750a4b5044 100755
--- a/extra/unix/unix.factor
+++ b/extra/unix/unix.factor
@@ -177,31 +177,39 @@ FUNCTION: int kill ( pid_t pid, int sig ) ;
! Flags for waitpid
-: WNOHANG 1 ;
-: WUNTRACED 2 ;
+: WNOHANG 1 ; inline
+: WUNTRACED 2 ; inline
-: WSTOPPED 2 ;
-: WEXITED 4 ;
-: WCONTINUED 8 ;
-: WNOWAIT HEX: 1000000 ;
+: WSTOPPED 2 ; inline
+: WEXITED 4 ; inline
+: WCONTINUED 8 ; inline
+: WNOWAIT HEX: 1000000 ; inline
! Examining status
-: WTERMSIG ( status -- value ) HEX: 7f bitand ;
+: WTERMSIG ( status -- value )
+ HEX: 7f bitand ; inline
-: WIFEXITED ( status -- ? ) WTERMSIG zero? ;
+: WIFEXITED ( status -- ? )
+ WTERMSIG zero? ; inline
-: WEXITSTATUS ( status -- value ) HEX: ff00 bitand -8 shift ;
+: WEXITSTATUS ( status -- value )
+ HEX: ff00 bitand -8 shift ; inline
-: WIFSIGNALED ( status -- ? ) HEX: 7f bitand 1+ -1 shift 0 > ;
+: WIFSIGNALED ( status -- ? )
+ HEX: 7f bitand 1+ -1 shift 0 > ; inline
-: WCOREFLAG ( -- value ) HEX: 80 ;
+: WCOREFLAG ( -- value )
+ HEX: 80 ; inline
-: WCOREDUMP ( status -- ? ) WCOREFLAG bitand zero? not ;
+: WCOREDUMP ( status -- ? )
+ WCOREFLAG bitand zero? not ; inline
-: WIFSTOPPED ( status -- ? ) HEX: ff bitand HEX: 7f = ;
+: WIFSTOPPED ( status -- ? )
+ HEX: ff bitand HEX: 7f = ; inline
-: WSTOPSIG ( status -- value ) WEXITSTATUS ;
+: WSTOPSIG ( status -- value )
+ WEXITSTATUS ; inline
FUNCTION: pid_t wait ( int* status ) ;
FUNCTION: pid_t waitpid ( pid_t wpid, int* status, int options ) ;
From f1989fc8c6142671cc27d5f0d14041b05a104d50 Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@factorcode.org>
Date: Mon, 4 Feb 2008 20:10:00 -0600
Subject: [PATCH 51/52] Fix io.launcher again
---
extra/io/unix/launcher/launcher.factor | 2 +-
1 file changed, 1 insertion(+), 1 deletion(-)
diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor
index b44ac80159..93278e2b1a 100755
--- a/extra/io/unix/launcher/launcher.factor
+++ b/extra/io/unix/launcher/launcher.factor
@@ -111,7 +111,7 @@ M: unix-io process-stream*
2drop t
] [
find-process dup [
- >r *uint r> notify-exit f
+ >r *int WEXITSTATUS r> notify-exit f
] [
2drop f
] if
From b2cd79ebddb28c312dd1f9bce7bdd756cf6a0bbf Mon Sep 17 00:00:00 2001
From: Slava Pestov <slava@oberon.local>
Date: Mon, 4 Feb 2008 20:49:59 -0600
Subject: [PATCH 52/52] Fix deploy
---
extra/tools/deploy/backend/backend.factor | 1 +
1 file changed, 1 insertion(+)
diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor
index d768b6a334..95d19712c0 100755
--- a/extra/tools/deploy/backend/backend.factor
+++ b/extra/tools/deploy/backend/backend.factor
@@ -80,6 +80,7 @@ IN: tools.deploy.backend
] { } make ;
: make-deploy-image ( vm image vocab config -- )
+ make-boot-image
dup staging-image-name exists? [
>r pick r> tuck make-staging-image
] unless