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

Merge git://factorcode.org/git/factor

db4
Aaron Schaefer 2008-02-05 16:45:13 -05:00
parent c68e70877d b2cd79ebdd
commit f932438fef
106 changed files with 2427 additions and 1341 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
core/alien/c-types/c-types-docs.factor
View File

@ -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." }

22
core/alien/c-types/c-types.factor
View File

@ -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 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
@ -107,6 +108,14 @@ M: string stack-size c-type stack-size ;
M: c-type stack-size c-type-size ;
GENERIC: byte-length ( seq -- n ) flushable
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 ]
@ -205,6 +214,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

55
core/bootstrap/image/image.factor
View File

@ -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
@ -248,7 +255,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 [
@ -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 '

10
core/bootstrap/primitives.factor
View File

@ -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

1
core/bootstrap/stage1.factor
View File

@ -32,6 +32,7 @@ vocabs.loader system ;
"io.streams.c" require
"vocabs.loader" require
"syntax" require
"bootstrap.layouts" require

2
core/bootstrap/stage2.factor
View File

@ -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

2
core/classes/classes.factor
View File

@ -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

29
core/classes/union/union.factor
View File

@ -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

2
core/compiler/compiler.factor
View File

@ -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 ;
over crossref? [ compiled-xref ] [ 2drop ] if ;
: compile-succeeded ( word -- effect dependencies )
[

10
core/compiler/test/alien.factor
View File

@ -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 ;

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

@ -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 ;

16
core/effects/effects.factor Normal file → Executable file
View File

@ -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,13 +41,13 @@ 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 ;
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> ;

2
core/float-arrays/float-arrays-docs.factor
View File

@ -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

10
core/generator/generator.factor
View File

@ -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

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

@ -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." }
@ -125,16 +121,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 } "." } ;

3
core/generic/generic-tests.factor
View File

@ -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

95
core/generic/generic.factor
View File

@ -1,16 +1,11 @@
! 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
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,36 @@ 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 ;
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 rot define ;
: <method> ( quot class generic -- method )
check-method
[ <method-word> ] 3keep f \ method construct-boa
dup method-word over "method" set-word-prop ;
: 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 +124,23 @@ M: class forget* ( class -- )
M: assoc update-methods ( assoc -- )
implementors* [ make-generic ] each ;
: define-generic ( word combination -- )
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 ;
: 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 ;

9
core/generic/math/math.factor
View File

@ -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 [

53
core/generic/standard/standard.factor
View File

@ -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 ;

10
core/inference/backend/backend.factor
View File

@ -9,9 +9,13 @@ IN: inference.backend
: recursive-label ( word -- label/f )
recursive-state get at ;
: inline? ( word -- ? )
dup "method" word-prop
[ method-generic 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

10
core/io/crc32/crc32-docs.factor
View File

@ -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"

2
core/io/crc32/crc32.factor
View File

@ -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)

7
core/io/streams/c/c.factor
View File

@ -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 ;

10
core/optimizer/backend/backend.factor Normal file → Executable file
View File

@ -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 ;

2
core/source-files/source-files.factor
View File

@ -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 [

8
core/words/words.factor
View File

@ -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
@ -154,7 +157,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> ;

23
extra/assocs/lib/lib.factor
View File

@ -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 ;

4
extra/automata/automata.factor
View File

@ -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 ;
! : stop-loop ( -- ) f >loop-flag ;

77
extra/benchmark/dispatch5/dispatch5.factor Executable file
View File

@ -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

1
extra/bunny/authors.txt
View File

@ -1 +1,2 @@
Slava Pestov
Joe Groff

149
extra/bunny/bunny.factor
View File

@ -1,112 +1,69 @@
! 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 tools.time system combinators.lib combinators.cleave
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 ;
TUPLE: bunny-gadget model geom draw-seq draw-n ;
: (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* ;
: <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 ;
: parse-model ( stream -- vs is )
[
100000 <vector> 100000 <vector> (parse-model)
] with-stream
[
over length # " vertices, " %
dup length # " triangles" %
] "" make print ;
: bunny-gadget-draw ( gadget -- draw )
{ bunny-gadget-draw-n bunny-gadget-draw-seq }
get-slots nth ;
: 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-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 ;
: 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-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.02 -0.105 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

93
extra/bunny/cel-shaded/cel-shaded.factor Normal file
View File

@ -0,0 +1,93 @@
USING: arrays bunny.model combinators.lib continuations
kernel multiline opengl opengl.shaders opengl.capabilities
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 -- )
{
{ "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) ;
M: bunny-cel-shaded dispose
bunny-cel-shaded-program delete-gl-program ;

25
extra/bunny/fixed-pipeline/fixed-pipeline.factor Normal file
View File

@ -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 ;

114
extra/bunny/model/model.factor Normal file
View File

@ -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 opengl.capabilities 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 } [
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 ;

240
extra/bunny/outlined/outlined.factor Normal file
View File

@ -0,0 +1,240 @@
USING: arrays bunny.model bunny.cel-shaded
combinators.lib continuations kernel math multiline
opengl opengl.shaders opengl.framebuffers opengl.gl
opengl.capabilities 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 ;
: 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 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)
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 {
{ "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
[ (pass1) ] keep (pass2) ;
M: bunny-outlined dispose
{
[ bunny-outlined-pass1-program [ delete-gl-program ] when* ]
[ bunny-outlined-pass2-program [ delete-gl-program ] when* ]
[ dispose-framebuffer ]
} call-with ;

1
extra/bunny/tags.txt
View File

@ -1 +1,2 @@
demos
opengl

89
extra/cel-shading/cel-shading.factor
View File

@ -1,89 +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 ;
: <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);
}
;
: 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
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 ;
M: cel-shading-gadget ungraft* ( gadget -- )
cel-shading-gadget-program [ delete-gl-program ] when* ;
: 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
cel-shading-gadget-model first3 draw-bunny
] with-gl-program ;
: cel-shading-window ( -- )
[ <cel-shading-gadget> "Cel Shading" open-window ] with-ui ;
MAIN: cel-shading-window

15
extra/cocoa/views/views.factor
View File

@ -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:

104
extra/db/db.factor Normal file
View File

@ -0,0 +1,104 @@
! 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? ;
TUPLE: simple-statement ;
TUPLE: prepared-statement ;
HOOK: <simple-statement> db ( str -- statement )
HOOK: <prepared-statement> db ( str -- statement )
GENERIC: prepare-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
] [
bind-statement*
] if
tuck set-statement-params
t swap set-statement-bound? ;
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 -- ? )
: 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>
{
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 -- )
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-query ( query -- result-set )
query-results [ [ sql-row ] query-map ] with-disposal ;
: do-bound-query ( obj query -- rows )
[ bind-statement ] keep do-query ;
: do-bound-command ( obj query -- )
[ bind-statement ] keep execute-statement ;
: sql-query ( sql -- rows )
<simple-statement> [ do-query ] with-disposal ;
: sql-command ( sql -- )
<simple-statement> [ execute-statement ] with-disposal ;
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 ;

0
extra/postgresql/authors.txt → extra/db/postgresql/authors.txt
View File

226
extra/postgresql/libpq/libpq.factor → extra/db/postgresql/ffi/ffi.factor
View File

@ -1,12 +1,10 @@
! 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: postgresql.libpq
IN: db.postgresql.ffi
<<
"postgresql" {
@ -17,45 +15,44 @@ IN: postgresql.libpq
>>
! 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
: 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
: 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
: 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
: 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
: PQERRORS_TERSE HEX: 0 ; inline
: PQERRORS_DEFAULT HEX: 1 ; inline
: PQERRORS_VERBOSE HEX: 2 ; inline
TYPEDEF: int size_t
TYPEDEF: int ConnStatusType
@ -81,7 +78,6 @@ LIBRARY: postgresql
! Exported functions of libpq
! === in fe-connect.c ===
! make a new client connection to the backend
! Asynchronous (non-blocking)
@ -91,12 +87,12 @@ 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 ) ;
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 ;
f f PQsetdbLogin ;
! close the current connection and free the PGconn data structure
FUNCTION: void PQfinish ( PGconn* conn ) ;
@ -112,7 +108,7 @@ FUNCTION: void PQconninfoFree ( PQconninfoOption* connOptions ) ;
! parameters
!
! Asynchronous (non-blocking)
FUNCTION: int PQresetStart ( PGconn* conn ) ;
FUNCTION: int PQresetStart ( PGconn* conn ) ;
FUNCTION: PostgresPollingStatusType PQresetPoll ( PGconn* conn ) ;
! Synchronous (blocking)
@ -125,7 +121,7 @@ FUNCTION: PGcancel* PQgetCancel ( PGconn* conn ) ;
FUNCTION: void PQfreeCancel ( PGcancel* cancel ) ;
! issue a cancel request
FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
FUNCTION: int PQrequestCancel ( PGconn* conn ) ;
! Accessor functions for PGconn objects
FUNCTION: char* PQdb ( PGconn* conn ) ;
@ -138,14 +134,14 @@ 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 ) ;
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 ) ;
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
@ -156,7 +152,7 @@ FUNCTION: void PQinitSSL ( int do_init ) ;
! Set verbosity for PQerrorMessage and PQresultErrorMessage
FUNCTION: PGVerbosity PQsetErrorVerbosity ( PGconn* conn,
PGVerbosity verbosity ) ;
PGVerbosity verbosity ) ;
! Enable/disable tracing
FUNCTION: void PQtrace ( PGconn* conn, FILE* debug_port ) ;
@ -171,11 +167,11 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
! Override default notice handling routines
! FUNCTION: PQnoticeReceiver PQsetNoticeReceiver ( PGconn* conn,
! PQnoticeReceiver proc,
! void* arg ) ;
! PQnoticeReceiver proc,
! void* arg ) ;
! FUNCTION: PQnoticeProcessor PQsetNoticeProcessor ( PGconn* conn,
! PQnoticeProcessor proc,
! void* arg ) ;
! PQnoticeProcessor proc,
! void* arg ) ;
! END BROKEN
! === in fe-exec.c ===
@ -183,83 +179,83 @@ FUNCTION: void PQuntrace ( PGconn* conn ) ;
! 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 ) ;
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 ) ;
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 ) ;
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 ) ;
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 ) ;
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 ) ;
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 ) ;
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 ) ;
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 ) ;
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 ) ;
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 ) ;
@ -313,7 +309,7 @@ FUNCTION: uchar* PQunescapeBytea ( uchar* strtext,
! 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 ) ;
size_t* bytealen ) ;
! === in fe-print.c ===
@ -332,30 +328,28 @@ FUNCTION: void PQprintTuples ( PGresult* res,
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 ) ;
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 ) ;
FUNCTION: int PQmblen ( uchar* s, int encoding ) ;
! Determine display length of multibyte encoded char at *s
FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
! Get encoding id from environment variable PGCLIENTENCODING
FUNCTION: int PQenv2encoding ( ) ;
FUNCTION: int PQenv2encoding ( ) ;

44
extra/db/postgresql/lib/lib.factor Normal file
View File

@ -0,0 +1,44 @@
! 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 alien alien.c-types ;
IN: db.postgresql.lib
: 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? ;
: 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-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 ;

110
extra/db/postgresql/postgresql-tests.factor Normal file
View File

@ -0,0 +1,110 @@
! You will need to run 'createdb factor-test' to create the database.
! Set username and password in the 'connect' word.
USING: kernel db.postgresql alien continuations io prettyprint
sequences namespaces tools.test db ;
IN: temporary
IN: scratchpad
: test-db ( -- postgresql-db )
"localhost" "postgres" "" "factor-test" <postgresql-db> ;
IN: temporary
[ ] [ test-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
"insert into person values('John', 'America');" sql-command
"insert into person values('Jane', 'New Zealand');" sql-command
] with-db
] unit-test
[
{
{ "John" "America" }
{ "Jane" "New Zealand" }
}
] [
test-db [
"select * from person" sql-query
] with-db
] unit-test
[
{ { "John" "America" } }
] [
test-db [
"select * from person where name = $1 and country = $2"
<simple-statement> [
{ "Jane" "New Zealand" }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ "John" "America" }
swap do-bound-query
] with-disposal
] with-db
] unit-test
[
{
{ "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 [
[
"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
[ 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
[ 5 ] [
test-db [
"select * from person" sql-query length
] with-db
] unit-test

105
extra/db/postgresql/postgresql.factor Normal file
View File

@ -0,0 +1,105 @@
! Copyright (C) 2007, 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
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 ;
TUPLE: postgresql-result-set ;
: <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 bind-statement* ( seq statement -- )
set-statement-params ;
M: postgresql-statement rebind-statement ( seq statement -- )
bind-statement* ;
M: postgresql-result-set #rows ( result-set -- n )
result-set-handle PQntuples ;
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 ;
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-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
f swap set-statement-handle ;
M: postgresql-result-set dispose ( result-set -- )
dup result-set-handle PQclear
0 0 f roll {
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
length f PQprepare postgresql-error
] keep set-statement-handle ;
M: postgresql-db <simple-statement> ( sql -- statement )
{ set-statement-sql } statement construct
<postgresql-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 ;

2
extra/db/sqlite/authors.txt Normal file
View File

@ -0,0 +1,2 @@
Chris Double
Doug Coleman

130
extra/db/sqlite/ffi/ffi.factor Normal file
View File

@ -0,0 +1,130 @@
! 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_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 ) ;

85
extra/db/sqlite/lib/lib.factor Normal file
View File

@ -0,0 +1,85 @@
! 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
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? ;

110
extra/db/sqlite/sqlite-tests.factor Normal file
View File

@ -0,0 +1,110 @@
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"
IN: scratchpad
: test.db "extra/db/sqlite/test.db" resource-path ;
IN: temporary
: (create-db) ( -- str )
[
"sqlite3 -init " %
test.db %
" " %
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" sql-query
] with-sqlite
] unit-test
[
{ { "John" "America" } }
] [
test.db [
"select * from person where name = :name and country = :country"
<simple-statement> [
{ { ":name" "Jane" } { ":country" "New Zealand" } }
over do-bound-query
{ { "Jane" "New Zealand" } } =
[ "test fails" throw ] unless
{ { ":name" "John" } { ":country" "America" } }
swap do-bound-query
] with-disposal
] with-sqlite
] unit-test
[
{
{ "1" "John" "America" }
{ "2" "Jane" "New Zealand" }
}
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[
] [
test.db [
"insert into person(name, country) values('Jimmy', 'Canada')"
sql-command
] with-sqlite
] unit-test
[
{
{ "1" "John" "America" }
{ "2" "Jane" "New Zealand" }
{ "3" "Jimmy" "Canada" }
}
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
[
test.db [
[
"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
] unit-test-fails
[ 3 ] [
test.db [
"select * from person" sql-query length
] with-sqlite
] 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-sqlite
] unit-test
[ 5 ] [
test.db [
"select * from person" sql-query length
] with-sqlite
] unit-test

74
extra/db/sqlite/sqlite.factor Normal file
View File

@ -0,0 +1,74 @@
! 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 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
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 <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-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 statement-handle sqlite-reset
statement-handle swap sqlite-bind-assoc ;
M: sqlite-statement execute-statement ( statement -- )
statement-handle sqlite-next drop ;
M: sqlite-result-set #columns ( result-set -- n )
result-set-handle sqlite-#columns ;
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-db begin-transaction ( -- )
"BEGIN" sql-command ;
M: sqlite-db commit-transaction ( -- )
"COMMIT" sql-command ;
M: sqlite-db rollback-transaction ( -- )
"ROLLBACK" sql-command ;

3
extra/db/sqlite/test.txt Normal file
View File

@ -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');

2
extra/delegate/delegate.factor
View File

@ -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>

4
extra/http/client/client.factor
View File

@ -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 at nip http-get-stream
dispose "location" swap peek-at nip http-get-stream
] when ;
: http-get-stream ( url -- code headers stream )

6
extra/http/http.factor
View File

@ -1,11 +1,12 @@
! 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 ;
sequences strings splitting ascii io.utf8 assocs.lib
namespaces unicode.case ;
IN: http
: header-line ( line -- )
": " split1 dup [ swap set ] [ 2drop ] if ;
": " split1 dup [ swap >lower insert ] [ 2drop ] if ;
: (read-header) ( -- )
readln dup
@ -71,4 +72,3 @@ IN: http
hash>query %
] if
] "" make ;

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

@ -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 assocs.lib ;
IN: http.server.responders
@ -10,8 +10,11 @@ IN: http.server.responders
SYMBOL: vhosts
SYMBOL: responders
: >header ( value key -- multi-hash )
H{ } clone [ insert-at ] keep ;
: print-header ( alist -- )
[ swap write ": " write print ] assoc-each nl ;
[ swap write ": " write print ] multi-assoc-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 ;
H{ { "Content-Type" V{ "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 ;
] multi-assoc-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 -- )

4
extra/io/launcher/launcher-docs.factor
View File

@ -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 } }

4
extra/io/launcher/launcher.factor
View File

@ -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

4
extra/io/monitor/monitor.factor
View File

@ -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+

6
extra/io/unix/launcher/launcher.factor
View File

@ -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 ( -- )
[
@ -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

27
extra/io/unix/linux/linux.factor
View File

@ -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

14
extra/io/windows/launcher/launcher.factor
View File

@ -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

7
extra/io/windows/nt/monitor/monitor.factor
View File

@ -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 ;

255
extra/line-art/line-art.factor
View File

@ -1,255 +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, 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;
}
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);
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);
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
] [ ] [ :c ] cleanup ;
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

1
extra/opengl/authors.txt
View File

@ -1,2 +1,3 @@
Slava Pestov
Eduardo Cavazos
Joe Groff

0
extra/opengl-demo-support/authors.txt → extra/opengl/capabilities/authors.txt
View File

59
extra/opengl/capabilities/capabilities-docs.factor Normal file
View File

@ -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"

67
extra/opengl/capabilities/capabilities.factor Normal file
View File

@ -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) ;

1
extra/opengl/capabilities/summary.txt Normal file
View File

@ -0,0 +1 @@
Testing for OpenGL versions and extensions

2
extra/opengl/capabilities/tags.txt Normal file
View File

@ -0,0 +1,2 @@
opengl
bindings

1
extra/opengl/demo-support/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

2
extra/opengl-demo-support/opengl-demo-support.factor → extra/opengl/demo-support/demo-support.factor
View File

@ -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

0
extra/opengl-demo-support/summary.txt → extra/opengl/demo-support/summary.txt
View File

0
extra/opengl-demo-support/tags.txt → extra/opengl/demo-support/tags.txt
View File

1
extra/opengl/framebuffers/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

35
extra/opengl/framebuffers/framebuffer-docs.factor Normal file
View File

@ -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"

43
extra/opengl/framebuffers/framebuffers.factor Normal file
View File

@ -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 ;

1
extra/opengl/framebuffers/summary.txt Normal file
View File

@ -0,0 +1 @@
Rendering to offscreen textures using the GL_EXT_framebuffer_object extension

2
extra/opengl/framebuffers/tags.txt Normal file
View File

@ -0,0 +1,2 @@
opengl
bindings

193
extra/opengl/opengl-docs.factor
View File

@ -1,5 +1,5 @@
USING: help.markup help.syntax io kernel math quotations
opengl.gl ;
opengl.gl multiline assocs vocabs.loader sequences ;
IN: opengl
HELP: gl-color
@ -57,15 +57,7 @@ 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-buffer
HELP: gen-gl-buffer
{ $values { "id" integer } }
{ $description "Wrapper for " { $link glGenBuffers } " to handle the common case of generating a single buffer ID." } ;
@ -73,33 +65,12 @@ 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-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
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." } ;
{ gen-gl-buffer delete-gl-buffer } related-words
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" } ")" } }
@ -148,160 +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" } { "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" } "." } ;
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: 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? 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 }
@ -314,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 }
@ -324,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"

241
extra/opengl/opengl.factor
View File

@ -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 ;
@ -30,6 +30,21 @@ IN: opengl
: do-enabled ( what quot -- )
over glEnable dip glDisable ; inline
: do-enabled-client-state ( what quot -- )
over glEnableClientState dip glDisableClientState ; inline
: 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 -- )
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
@ -99,58 +114,41 @@ 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-buffer ( -- id )
: gen-gl-buffer ( -- id )
[ glGenBuffers ] (gen-gl-object) ;
: (delete-gl-object) ( id quot -- )
>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-buffer ( id -- )
: delete-gl-buffer ( id -- )
[ glDeleteBuffers ] (delete-gl-object) ;
: framebuffer-incomplete? ( -- status/f )
GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT
dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ;
: with-gl-buffer ( binding id quot -- )
-rot dupd glBindBuffer
[ slip ] [ 0 glBindBuffer ] [ ] cleanup ; inline
: 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 ;
: 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
: check-framebuffer ( -- )
framebuffer-incomplete? [ framebuffer-error ] when* ;
: <gl-buffer> ( target data hint -- id )
pick gen-gl-buffer [ [
>r dup byte-length swap r> glBufferData
] with-gl-buffer ] keep ;
: with-framebuffer ( id quot -- )
GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT
[ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline
: buffer-offset ( int -- alien )
<alien> ; 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
@ -250,178 +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 >byte-array 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> over glGetShaderInfoLog
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> over glGetAttachedShaders
] 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
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 subseq? ;
: (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) ;
: 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) ;

1
extra/opengl/shaders/authors.txt Normal file
View File

@ -0,0 +1 @@
Joe Groff

112
extra/opengl/shaders/shaders-docs.factor Normal file
View File

@ -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"

134
extra/opengl/shaders/shaders.factor Normal file
View File

@ -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 ;

1
extra/opengl/shaders/summary.txt Normal file
View File

@ -0,0 +1 @@
OpenGL Shading Language (GLSL) support

3
extra/opengl/shaders/tags.txt Normal file
View File

@ -0,0 +1,3 @@
opengl
glsl
bindings

26
extra/partial-apply/partial-apply.factor Normal file
View File

@ -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

42
extra/postgresql/postgresql-tests.factor
View File

@ -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

61
extra/postgresql/postgresql.factor
View File

@ -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 ;

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

@ -140,3 +140,16 @@ 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 ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! List the positions of obj in seq
: indices ( seq obj -- seq )
>r dup length swap r>
[ = [ ] [ drop f ] if ] curry
2map
[ ] subset ;

5
extra/shuffle/shuffle.factor
View File

@ -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 ;

3
extra/tools/crossref/crossref.factor Normal file → Executable file
View File

@ -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 )

8
extra/tools/deploy/backend/backend.factor
View File

@ -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 ;
@ -77,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

5
extra/tools/deploy/shaker/shaker.factor
View File

@ -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

2
extra/unicode/case/case.factor
View File

@ -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 ;

4
extra/unix/linux/linux.factor
View File

@ -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

2
extra/unix/process/process.factor
View File

@ -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 ;
0 <int> [ 0 waitpid drop ] keep *int WEXITSTATUS ;

2
extra/unix/solaris/solaris.factor
View File

@ -3,8 +3,6 @@
IN: unix
USING: alien.syntax system kernel ;
TYPEDEF: ulong off_t
! Solaris.
: O_RDONLY HEX: 0000 ; inline

40
extra/unix/unix.factor
View File

@ -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
@ -175,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 ) ;

16
extra/x11/windows/windows.factor
View File

@ -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>

22
extra/x11/xlib/xlib.factor
View File

@ -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

2
misc/Factor.tmbundle/Support/lib/tm_factor.rb
View File

@ -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

Some files were not shown because too many files have changed in this diff Show More