diff --git a/core/alien/c-types/c-types-docs.factor b/core/alien/c-types/c-types-docs.factor index f6418295f7..f4aa297a3a 100755 --- a/core/alien/c-types/c-types-docs.factor +++ b/core/alien/c-types/c-types-docs.factor @@ -34,6 +34,10 @@ HELP: stack-size { $description "Outputs the number of bytes to reserve on the C stack by a value of this C type. In most cases this is equal to " { $link heap-size } ", except on some platforms where C structs are passed by invisible reference, in which case a C struct type only uses as much space as a pointer on the C stack." } { $errors "Throws a " { $link no-c-type } " error if the type does not exist." } ; +HELP: byte-length +{ $values { "seq" "A byte array or float array" } { "n" "a non-negative integer" } } +{ $contract "Outputs the size of the byte array or float array data in bytes as presented to the C library interface." } ; + HELP: c-getter { $values { "name" string } { "quot" "a quotation with stack effect " { $snippet "( c-ptr n -- obj )" } } } { $description "Outputs a quotation which reads values of this C type from a C structure." } diff --git a/core/alien/c-types/c-types.factor b/core/alien/c-types/c-types.factor index 88df823e5b..6c46cb946a 100755 --- a/core/alien/c-types/c-types.factor +++ b/core/alien/c-types/c-types.factor @@ -1,9 +1,10 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: byte-arrays 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 [ 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> dup -roll r> [ execute ] 2curry 2each ; inline diff --git a/core/bootstrap/image/image.factor b/core/bootstrap/image/image.factor index e9ee569fd6..60e73cb249 100755 --- a/core/bootstrap/image/image.factor +++ b/core/bootstrap/image/image.factor @@ -203,7 +203,14 @@ M: f ' ! Words +DEFER: emit-word + +: emit-generic ( generic -- ) + dup "default-method" word-prop method-word emit-word + "methods" word-prop [ nip method-word emit-word ] assoc-each ; + : emit-word ( word -- ) + dup generic? [ dup emit-generic ] when [ dup hashcode ' , dup word-name ' , @@ -224,7 +231,7 @@ M: f ' [ % dup word-vocabulary % " " % word-name % ] "" make throw ; : transfer-word ( word -- word ) - dup target-word [ ] [ word-name no-word ] ?if ; + dup target-word swap or ; : fixup-word ( word -- offset ) transfer-word dup objects get at @@ -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 ' diff --git a/core/bootstrap/primitives.factor b/core/bootstrap/primitives.factor index 545d904c9c..550aac71b0 100755 --- a/core/bootstrap/primitives.factor +++ b/core/bootstrap/primitives.factor @@ -118,11 +118,11 @@ H{ } clone update-map set H{ } clone typemap set num-types get f builtins set -! These symbols are needed by the code that executes below -{ - { "object" "kernel" } - { "null" "kernel" } -} [ create drop ] assoc-each +! Forward definitions +"object" "kernel" create t "class" set-word-prop +"object" "kernel" create union-class "metaclass" set-word-prop + +"null" "kernel" create drop "fixnum" "math" create "fixnum?" "math" create { } define-builtin "fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop diff --git a/core/bootstrap/stage1.factor b/core/bootstrap/stage1.factor index 8af1bfdec9..cc328e9760 100755 --- a/core/bootstrap/stage1.factor +++ b/core/bootstrap/stage1.factor @@ -32,6 +32,7 @@ vocabs.loader system ; "io.streams.c" require "vocabs.loader" require + "syntax" require "bootstrap.layouts" require diff --git a/core/bootstrap/stage2.factor b/core/bootstrap/stage2.factor index 5a5a8d1c67..7a0fab8a99 100755 --- a/core/bootstrap/stage2.factor +++ b/core/bootstrap/stage2.factor @@ -15,7 +15,7 @@ IN: bootstrap.stage2 vm file-name windows? [ "." split1 drop ] when ".image" append "output-image" set-global - "math tools help compiler ui ui.tools io" "include" set-global + "math help compiler tools ui ui.tools io" "include" set-global "" "exclude" set-global parse-command-line diff --git a/core/classes/classes.factor b/core/classes/classes.factor index a6a1db7045..151429bf69 100755 --- a/core/classes/classes.factor +++ b/core/classes/classes.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: classes USING: arrays definitions assocs kernel diff --git a/core/classes/union/union.factor b/core/classes/union/union.factor index 0adbdc080d..332903d36b 100755 --- a/core/classes/union/union.factor +++ b/core/classes/union/union.factor @@ -1,19 +1,34 @@ -! Copyright (C) 2004, 2007 Slava Pestov. +! Copyright (C) 2004, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: words sequences kernel assocs combinators classes -generic.standard namespaces arrays ; +generic.standard namespaces arrays math quotations ; IN: classes.union PREDICATE: class union-class "metaclass" word-prop union-class eq? ; ! Union classes for dispatch on multiple classes. +: small-union-predicate-quot ( members -- quot ) + dup empty? [ + drop [ drop f ] + ] [ + unclip first "predicate" word-prop swap + [ >r "predicate" word-prop [ dup ] swap append r> ] + assoc-map alist>quot + ] if ; + +: big-union-predicate-quot ( members -- quot ) + [ small-union-predicate-quot ] [ dup ] + class-hash-dispatch-quot ; + : union-predicate-quot ( members -- quot ) - 0 (dispatch#) [ - [ [ drop t ] ] { } map>assoc - object bootstrap-word [ drop f ] 2array add* - single-combination - ] with-variable ; + [ [ drop t ] ] { } map>assoc + dup length 4 <= [ + small-union-predicate-quot + ] [ + flatten-methods + big-union-predicate-quot + ] if ; : define-union-predicate ( class -- ) dup predicate-word diff --git a/core/compiler/compiler.factor b/core/compiler/compiler.factor index 1e6d4f8a17..2674734483 100755 --- a/core/compiler/compiler.factor +++ b/core/compiler/compiler.factor @@ -26,7 +26,7 @@ IN: compiler >r dupd save-effect r> f pick compiler-error over compiled-unxref - over word-vocabulary [ compiled-xref ] [ 2drop ] if ; + over crossref? [ compiled-xref ] [ 2drop ] if ; : compile-succeeded ( word -- effect dependencies ) [ diff --git a/core/compiler/test/alien.factor b/core/compiler/test/alien.factor index e737a76e1e..9416fd1415 100755 --- a/core/compiler/test/alien.factor +++ b/core/compiler/test/alien.factor @@ -132,8 +132,8 @@ FUNCTION: int ffi_test_10 int a int b double c int d float e int f int g int h ; [ -34 ] [ 1 2 3.0 4 5.0 6 7 8 ffi_test_10 ] unit-test FUNCTION: void ffi_test_20 double x1, double x2, double x3, - double y1, double y2, double y3, - double z1, double z2, double z3 ; + double y1, double y2, double y3, + double z1, double z2, double z3 ; [ ] [ 1.0 2.0 3.0 4.0 5.0 6.0 7.0 8.0 9.0 ffi_test_20 ] unit-test @@ -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" + [ set-test-struct-12-x ] keep ; + +FUNCTION: double ffi_test_36 ( test-struct-12 x ) ; + +[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test + ! Test callbacks : callback-1 "void" { } "cdecl" [ ] alien-callback ; diff --git a/core/cpu/x86/32/32.factor b/core/cpu/x86/32/32.factor index d3e33c46bd..4ed186d769 100755 --- a/core/cpu/x86/32/32.factor +++ b/core/cpu/x86/32/32.factor @@ -261,6 +261,10 @@ windows? [ cell "ulonglong" c-type set-c-type-align ] unless +macosx? [ + cell "double" c-type set-c-type-align +] when + T{ x86-backend f 4 } compiler-backend set-global : sse2? "Intrinsic" throw ; diff --git a/core/definitions/definitions-tests.factor b/core/definitions/definitions-tests.factor index 13172c0ada..a4cb4de902 100755 --- a/core/definitions/definitions-tests.factor +++ b/core/definitions/definitions-tests.factor @@ -11,7 +11,7 @@ SYMBOL: generic-1 [ generic-1 T{ combination-1 } define-generic - [ ] object \ generic-1 define-method + [ ] object \ generic-1 define-method ] with-compilation-unit [ ] [ diff --git a/core/effects/effects.factor b/core/effects/effects.factor old mode 100644 new mode 100755 index ee929507c8..23e8daf122 --- a/core/effects/effects.factor +++ b/core/effects/effects.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2006, 2007 Slava Pestov. +! Copyright (C) 2006, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: kernel math namespaces sequences strings words assocs combinators ; @@ -41,13 +41,13 @@ M: integer (stack-picture) drop "object" ; ")" % ] "" make ; -: stack-effect ( word -- effect/f ) - dup symbol? [ - drop 0 1 - ] [ - { "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 ; + +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 ; diff --git a/core/float-arrays/float-arrays-docs.factor b/core/float-arrays/float-arrays-docs.factor index 70bbfe296f..cb36aade6b 100644 --- a/core/float-arrays/float-arrays-docs.factor +++ b/core/float-arrays/float-arrays-docs.factor @@ -32,7 +32,7 @@ HELP: ( n initial -- float-array ) HELP: >float-array { $values { "seq" "a sequence" } { "float-array" float-array } } -{ $description "Outputs a freshly-allocated float array whose elements have the same boolean values as a given sequence." } +{ $description "Outputs a freshly-allocated float array whose elements have the same floating-point values as a given sequence." } { $errors "Throws an error if the sequence contains elements other than real numbers." } ; HELP: 1float-array diff --git a/core/generator/generator.factor b/core/generator/generator.factor index de80872b73..3d66241bc3 100755 --- a/core/generator/generator.factor +++ b/core/generator/generator.factor @@ -154,9 +154,17 @@ M: #if generate-node ] generate-1 ] keep ; +: tail-dispatch? ( node -- ? ) + #! Is the dispatch a jump to a tail call to a word? + dup #call? swap node-successor #return? and ; + : dispatch-branches ( node -- ) node-children [ - compiling-word get dispatch-branch %dispatch-label + dup tail-dispatch? [ + node-param + ] [ + compiling-word get dispatch-branch + ] if %dispatch-label ] each ; M: #dispatch generate-node diff --git a/core/generic/generic-docs.factor b/core/generic/generic-docs.factor index 9dfc40a869..631aa7e62d 100755 --- a/core/generic/generic-docs.factor +++ b/core/generic/generic-docs.factor @@ -1,6 +1,6 @@ USING: help.markup help.syntax generic.math generic.standard words classes definitions kernel alien combinators sequences -math ; +math quotations ; IN: generic ARTICLE: "method-order" "Method precedence" @@ -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: { $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 } "." } ; @@ -154,7 +146,7 @@ HELP: with-methods $low-level-note ; HELP: define-method -{ $values { "method" "an instance of " { $link method } } { "class" class } { "generic" generic } } +{ $values { "method" quotation } { "class" class } { "generic" generic } } { $description "Defines a method. This is the runtime equivalent of " { $link POSTPONE: M: } "." } ; HELP: implementors diff --git a/core/generic/generic-tests.factor b/core/generic/generic-tests.factor index dc888ec30c..f0d5bf3063 100755 --- a/core/generic/generic-tests.factor +++ b/core/generic/generic-tests.factor @@ -176,6 +176,9 @@ M: f tag-and-f 4 ; ! define-class hashing issue TUPLE: debug-combination ; +M: debug-combination make-default-method + 2drop [ "Oops" throw ] when ; + M: debug-combination perform-combination drop order [ dup class-hashes ] { } map>assoc sort-keys diff --git a/core/generic/generic.factor b/core/generic/generic.factor index bde5fd31af..2100f49423 100755 --- a/core/generic/generic.factor +++ b/core/generic/generic.factor @@ -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,27 +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 ; - -: ( def -- method ) - { set-method-def } \ method construct ; - -M: f method-def ; -M: f method-loc ; -M: quotation method-def ; -M: quotation method-loc drop f ; +TUPLE: method word def specializer generic loc ; : method ( class generic -- method/f ) "methods" word-prop at ; @@ -53,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 2array ] curry map ; - : 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 ; @@ -71,19 +59,46 @@ TUPLE: check-method class generic ; swap [ "methods" word-prop swap call ] keep make-generic ; inline -: define-method ( method class generic -- ) - >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 ; + +: ( quot class generic -- word ) + [ make-method-def ] 2keep + method-word-name f + dup rot define ; + +: ( quot class generic -- method ) + check-method + [ ] 3keep f \ method construct-boa + dup method-word over "method" set-word-prop ; + +: define-method ( quot class generic -- ) + >r bootstrap-word r> + [ ] 2keep [ set-at ] with-methods ; +: define-default-method ( generic combination -- ) + dupd make-default-method object bootstrap-word pick + "default-method" set-word-prop ; + ! Definition protocol M: method-spec where - dup first2 method method-loc [ ] [ second where ] ?if ; + dup first2 method [ method-loc ] [ second where ] ?if ; M: method-spec set-where first2 method set-method-loc ; M: method-spec definer drop \ M: \ ; ; -M: method-spec definition first2 method method-def ; +M: method-spec definition + first2 method dup [ method-def ] when ; : forget-method ( class generic -- ) check-method [ delete-at ] with-methods ; @@ -109,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 ; diff --git a/core/generic/math/math.factor b/core/generic/math/math.factor old mode 100644 new mode 100755 index 912ece3a30..8cf83b0ba7 --- a/core/generic/math/math.factor +++ b/core/generic/math/math.factor @@ -38,9 +38,13 @@ TUPLE: no-math-method left right generic ; : no-math-method ( left right generic -- * ) \ no-math-method construct-boa throw ; +: default-math-method ( generic -- quot ) + [ no-math-method ] curry [ ] like ; + : applicable-method ( generic class -- quot ) - over method method-def - [ ] [ [ no-math-method ] curry [ ] like ] ?if ; + over method + [ method-word word-def ] + [ default-math-method ] ?if ; : object-method ( generic -- quot ) object bootstrap-word applicable-method ; @@ -66,6 +70,9 @@ TUPLE: no-math-method left right generic ; TUPLE: math-combination ; +M: math-combination make-default-method + drop default-math-method ; + M: math-combination perform-combination drop \ over [ diff --git a/core/generic/standard/standard.factor b/core/generic/standard/standard.factor index 6cc7f7f3e8..d52208ccbf 100755 --- a/core/generic/standard/standard.factor +++ b/core/generic/standard/standard.factor @@ -8,6 +8,10 @@ IN: generic.standard TUPLE: standard-combination # ; +M: standard-combination method-prologue + standard-combination-# object + swap add* [ declare ] curry ; + C: 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 -M: hook-combination perform-combination +M: hook-combination method-prologue + 2drop [ drop ] ; + +: with-hook ( combination quot -- quot' ) 0 (dispatch#) [ - [ - hook-combination-var [ get ] curry % - hook-methods single-combination % - ] [ ] make - ] with-variable ; + swap slip + hook-combination-var [ get ] curry + swap append + ] with-variable ; inline + +M: hook-combination make-default-method + [ error-method ] with-hook ; + +M: hook-combination perform-combination + [ standard-methods single-combination ] with-hook ; : define-simple-generic ( word -- ) T{ standard-combination f 0 } define-generic ; diff --git a/core/inference/backend/backend.factor b/core/inference/backend/backend.factor index 121c555d29..b839b047d6 100755 --- a/core/inference/backend/backend.factor +++ b/core/inference/backend/backend.factor @@ -9,9 +9,13 @@ IN: inference.backend : recursive-label ( word -- label/f ) recursive-state get at ; +: inline? ( word -- ? ) + dup "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 diff --git a/core/inference/transforms/transforms.factor b/core/inference/transforms/transforms.factor index fd15b7da98..ad2bacc789 100755 --- a/core/inference/transforms/transforms.factor +++ b/core/inference/transforms/transforms.factor @@ -54,6 +54,8 @@ M: pair (bitfield-quot) ( spec -- quot ) \ bitfield [ bitfield-quot ] 1 define-transform +\ flags [ flags [ ] curry ] 1 define-transform + ! Tuple operations : [get-slots] ( slots -- quot ) [ [ 1quotation , \ keep , ] each \ drop , ] [ ] make ; diff --git a/core/io/crc32/crc32-docs.factor b/core/io/crc32/crc32-docs.factor index 020f2668b0..3855c77cd8 100644 --- a/core/io/crc32/crc32-docs.factor +++ b/core/io/crc32/crc32-docs.factor @@ -2,16 +2,16 @@ USING: help.markup help.syntax math ; IN: io.crc32 HELP: crc32 -{ $values { "seq" "a sequence" } { "n" integer } } +{ $values { "seq" "a sequence of bytes" } { "n" integer } } { $description "Computes the CRC32 checksum of a sequence of bytes." } ; -HELP: file-crc32 -{ $values { "path" "a pathname string" } { "n" integer } } -{ $description "Computes the CRC32 checksum of a file's contents." } ; +HELP: lines-crc32 +{ $values { "lines" "a sequence of strings" } { "n" integer } } +{ $description "Computes the CRC32 checksum of a sequence of lines of bytes." } ; ARTICLE: "io.crc32" "CRC32 checksum calculation" "The CRC32 checksum algorithm provides a quick but unreliable way to detect changes in data." { $subsection crc32 } -{ $subsection file-crc32 } ; +{ $subsection lines-crc32 } ; ABOUT: "io.crc32" diff --git a/core/io/crc32/crc32.factor b/core/io/crc32/crc32.factor index b83943df48..afe7e4bfb7 100755 --- a/core/io/crc32/crc32.factor +++ b/core/io/crc32/crc32.factor @@ -23,8 +23,6 @@ IN: io.crc32 : crc32 ( seq -- n ) >r HEX: ffffffff dup r> [ (crc32) ] each bitxor ; -: file-crc32 ( path -- n ) file-contents crc32 ; - : lines-crc32 ( seq -- n ) HEX: ffffffff tuck [ [ (crc32) ] each CHAR: \n (crc32) diff --git a/core/io/streams/c/c.factor b/core/io/streams/c/c.factor index b02c3367d4..288ab212d1 100755 --- a/core/io/streams/c/c.factor +++ b/core/io/streams/c/c.factor @@ -74,3 +74,10 @@ M: object M: object "ab" fopen ; + +: show ( msg -- ) + #! A word which directly calls primitives. It is used to + #! print stuff from contexts where the I/O system would + #! otherwise not work (tools.deploy.shaker, the I/O + #! multiplexer thread). + "\r\n" append stdout-handle fwrite stdout-handle fflush ; diff --git a/core/math/bitfields/bitfields.factor b/core/math/bitfields/bitfields.factor index f6a3419784..77cc40180e 100644 --- a/core/math/bitfields/bitfields.factor +++ b/core/math/bitfields/bitfields.factor @@ -1,4 +1,4 @@ -! Copyright (C) 2007 Slava Pestov. +! Copyright (C) 2007, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math sequences words ; IN: math.bitfields @@ -13,3 +13,6 @@ M: pair (bitfield) ( value accum pair -- newaccum ) : bitfield ( values... bitspec -- n ) 0 [ (bitfield) ] reduce ; + +: flags ( values -- n ) + 0 [ dup word? [ execute ] when bitor ] reduce ; diff --git a/core/optimizer/backend/backend.factor b/core/optimizer/backend/backend.factor old mode 100644 new mode 100755 index 4843a9ff26..27b1b1e0ec --- a/core/optimizer/backend/backend.factor +++ b/core/optimizer/backend/backend.factor @@ -245,11 +245,19 @@ M: #dispatch optimize-node* : dispatching-class ( node word -- class ) [ dispatch# node-class# ] keep specific-method ; +: flat-length ( seq -- n ) + [ + dup quotation? over array? or + [ flat-length ] [ drop 1 ] if + ] map sum ; + : will-inline-method ( node word -- method-spec/t quot/t ) #! t indicates failure tuck dispatching-class dup [ swap [ 2array ] 2keep - method method-def + method method-word + dup word-def flat-length 5 >= + [ 1quotation ] [ word-def ] if ] [ 2drop t t ] if ; diff --git a/core/prettyprint/prettyprint-tests.factor b/core/prettyprint/prettyprint-tests.factor index 7f7d946347..5907c22686 100755 --- a/core/prettyprint/prettyprint-tests.factor +++ b/core/prettyprint/prettyprint-tests.factor @@ -21,9 +21,9 @@ IN: temporary [ "hello\\backslash" unparse ] unit-test -[ "\"\\u123456\"" ] -[ "\u123456" unparse ] -unit-test +! [ "\"\\u123456\"" ] +! [ "\u123456" unparse ] +! unit-test [ "\"\\e\"" ] [ "\e" unparse ] diff --git a/core/slots/slots.factor b/core/slots/slots.factor index cd523b05c1..40f0dd3da1 100755 --- a/core/slots/slots.factor +++ b/core/slots/slots.factor @@ -10,7 +10,7 @@ TUPLE: slot-spec type name offset reader writer ; C: slot-spec : define-typecheck ( class generic quot -- ) - over define-simple-generic -rot define-method ; + over define-simple-generic -rot define-method ; : define-slot-word ( class slot word quot -- ) rot >fixnum add* define-typecheck ; diff --git a/core/source-files/source-files.factor b/core/source-files/source-files.factor index 8bbf329491..c974145928 100755 --- a/core/source-files/source-files.factor +++ b/core/source-files/source-files.factor @@ -17,7 +17,7 @@ uses definitions ; : (source-modified?) ( path modified checksum -- ? ) pick file-modified rot [ 0 or ] 2apply > - [ swap file-crc32 number= not ] [ 2drop f ] if ; + [ swap file-lines lines-crc32 = not ] [ 2drop f ] if ; : source-modified? ( path -- ? ) dup source-files get at [ diff --git a/core/strings/strings-tests.factor b/core/strings/strings-tests.factor index 459ec7b153..985c025827 100755 --- a/core/strings/strings-tests.factor +++ b/core/strings/strings-tests.factor @@ -88,8 +88,6 @@ unit-test ! Make sure aux vector is not shared [ "\udeadbe" ] [ - "\udeadbe" clone - CHAR: \u123456 over clone set-first + "\udeadbe" clone + CHAR: \u123456 over clone set-first ] unit-test - - diff --git a/core/syntax/syntax.factor b/core/syntax/syntax.factor index 006f1a225f..67799b92ea 100755 --- a/core/syntax/syntax.factor +++ b/core/syntax/syntax.factor @@ -126,7 +126,7 @@ IN: bootstrap.syntax f set-word location >r scan-word bootstrap-word scan-word - [ parse-definition -rot define-method ] 2keep + [ parse-definition -rot define-method ] 2keep 2array r> remember-definition ] define-syntax diff --git a/core/words/words.factor b/core/words/words.factor index 5dc89212a8..93b1185335 100755 --- a/core/words/words.factor +++ b/core/words/words.factor @@ -116,13 +116,16 @@ SYMBOL: changed-words [ no-compilation-unit ] unless* set-at ; +: crossref? ( word -- ? ) + dup word-vocabulary swap "method" word-prop or ; + : define ( word def -- ) [ ] like over unxref over redefined over set-word-def dup changed-word - dup word-vocabulary [ dup xref ] when drop ; + dup crossref? [ dup xref ] when drop ; : define-declared ( word def effect -- ) pick swap "declared-effect" set-word-prop @@ -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 ; diff --git a/extra/assocs/lib/lib.factor b/extra/assocs/lib/lib.factor index 849f88023f..182f04a367 100755 --- a/extra/assocs/lib/lib.factor +++ b/extra/assocs/lib/lib.factor @@ -1,9 +1,6 @@ -USING: assocs kernel vectors sequences ; +USING: assocs kernel vectors sequences namespaces ; IN: assocs.lib -: insert-at ( value key assoc -- ) - [ ?push ] change-at ; - : >set ( seq -- hash ) [ dup ] H{ } map>assoc ; @@ -19,5 +16,19 @@ IN: assocs.lib : at-default ( key assoc -- value/key ) dupd at [ nip ] when* ; -: at-peek ( key assoc -- value ? ) - at* dup >r [ peek ] when r> ; +: insert-at ( value key assoc -- ) + [ ?push ] change-at ; + +: peek-at* ( key assoc -- obj ? ) + at* dup [ >r peek r> ] when ; + +: peek-at ( key assoc -- obj ) + peek-at* drop ; + +: >multi-assoc ( assoc -- new-assoc ) + [ 1vector ] assoc-map ; + +: multi-assoc-each ( assoc quot -- ) + [ with each ] curry assoc-each ; inline + +: insert ( value variable -- ) namespace insert-at ; diff --git a/extra/automata/automata.factor b/extra/automata/automata.factor index 732033fb75..cd799d477e 100644 --- a/extra/automata/automata.factor +++ b/extra/automata/automata.factor @@ -1,6 +1,6 @@ USING: kernel math math.parser random arrays hashtables assocs sequences - vars strings.lib ; + vars ; IN: automata @@ -108,4 +108,4 @@ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ; ! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ; -! : stop-loop ( -- ) f >loop-flag ; \ No newline at end of file +! : stop-loop ( -- ) f >loop-flag ; diff --git a/extra/benchmark/dispatch5/dispatch5.factor b/extra/benchmark/dispatch5/dispatch5.factor new file mode 100755 index 0000000000..34df715f89 --- /dev/null +++ b/extra/benchmark/dispatch5/dispatch5.factor @@ -0,0 +1,77 @@ +USING: classes kernel sequences vocabs math ; +IN: benchmark.dispatch5 + +MIXIN: g + +TUPLE: x1 ; +INSTANCE: x1 g +TUPLE: x2 ; +INSTANCE: x2 g +TUPLE: x3 ; +INSTANCE: x3 g +TUPLE: x4 ; +INSTANCE: x4 g +TUPLE: x5 ; +INSTANCE: x5 g +TUPLE: x6 ; +INSTANCE: x6 g +TUPLE: x7 ; +INSTANCE: x7 g +TUPLE: x8 ; +INSTANCE: x8 g +TUPLE: x9 ; +INSTANCE: x9 g +TUPLE: x10 ; +INSTANCE: x10 g +TUPLE: x11 ; +INSTANCE: x11 g +TUPLE: x12 ; +INSTANCE: x12 g +TUPLE: x13 ; +INSTANCE: x13 g +TUPLE: x14 ; +INSTANCE: x14 g +TUPLE: x15 ; +INSTANCE: x15 g +TUPLE: x16 ; +INSTANCE: x16 g +TUPLE: x17 ; +INSTANCE: x17 g +TUPLE: x18 ; +INSTANCE: x18 g +TUPLE: x19 ; +INSTANCE: x19 g +TUPLE: x20 ; +INSTANCE: x20 g +TUPLE: x21 ; +INSTANCE: x21 g +TUPLE: x22 ; +INSTANCE: x22 g +TUPLE: x23 ; +INSTANCE: x23 g +TUPLE: x24 ; +INSTANCE: x24 g +TUPLE: x25 ; +INSTANCE: x25 g +TUPLE: x26 ; +INSTANCE: x26 g +TUPLE: x27 ; +INSTANCE: x27 g +TUPLE: x28 ; +INSTANCE: x28 g +TUPLE: x29 ; +INSTANCE: x29 g +TUPLE: x30 ; +INSTANCE: x30 g + +: my-classes ( -- seq ) + "benchmark.dispatch5" words [ tuple-class? ] subset ; + +: a-bunch-of-objects ( -- seq ) + my-classes [ construct-empty ] map ; + +: dispatch-benchmark ( -- ) + 1000000 a-bunch-of-objects + [ f [ g? or ] reduce drop ] curry times ; + +MAIN: dispatch-benchmark diff --git a/extra/bunny/authors.txt b/extra/bunny/authors.txt index 1901f27a24..580f882c8d 100644 --- a/extra/bunny/authors.txt +++ b/extra/bunny/authors.txt @@ -1 +1,2 @@ Slava Pestov +Joe Groff diff --git a/extra/bunny/bunny.factor b/extra/bunny/bunny.factor index 550eb50e0a..7cf6132925 100755 --- a/extra/bunny/bunny.factor +++ b/extra/bunny/bunny.factor @@ -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 ) + 0.0 0.0 0.375 + maybe-download read-model { + set-delegate + set-bunny-gadget-model + } bunny-gadget construct ; -: parse-model ( stream -- vs is ) - [ - 100000 100000 (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 } -rot - [ >r 2dup r> normal ] each drop - [ normalize ] map ; - -: read-model ( stream -- model ) - "Reading model" print flush [ - 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 ; - -: ( model -- gadget ) - - { 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 + over { + [ ] + [ ] + [ ] + } 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" open-window - ] with-ui ; + [ "Bunny" open-window ] with-ui ; MAIN: bunny-window diff --git a/extra/bunny/cel-shaded/cel-shaded.factor b/extra/bunny/cel-shaded/cel-shaded.factor new file mode 100644 index 0000000000..37343a23fb --- /dev/null +++ b/extra/bunny/cel-shaded/cel-shaded.factor @@ -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? ; + +: ( gadget -- draw ) + drop + cel-shading-supported? [ + vertex-shader-source check-gl-shader + cel-shaded-fragment-shader-lib-source check-gl-shader + cel-shaded-fragment-shader-main-source check-gl-shader + 3array 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 ; + diff --git a/extra/bunny/fixed-pipeline/fixed-pipeline.factor b/extra/bunny/fixed-pipeline/fixed-pipeline.factor new file mode 100644 index 0000000000..f3fb68e515 --- /dev/null +++ b/extra/bunny/fixed-pipeline/fixed-pipeline.factor @@ -0,0 +1,25 @@ +USING: alien.c-types continuations kernel +opengl opengl.gl bunny.model ; +IN: bunny.fixed-pipeline + +TUPLE: bunny-fixed-pipeline ; + +: ( gadget -- draw ) + drop + { } bunny-fixed-pipeline construct ; + +M: bunny-fixed-pipeline draw-bunny + drop + GL_LIGHTING glEnable + GL_LIGHT0 glEnable + GL_COLOR_MATERIAL glEnable + GL_LIGHT0 GL_POSITION { 1.0 -1.0 1.0 1.0 } >c-float-array glLightfv + GL_FRONT_AND_BACK GL_SHININESS 100.0 glMaterialf + GL_FRONT_AND_BACK GL_SPECULAR glColorMaterial + GL_FRONT_AND_BACK GL_AMBIENT_AND_DIFFUSE glColorMaterial + 0.6 0.5 0.5 1.0 glColor4f + bunny-geom ; + +M: bunny-fixed-pipeline dispose + drop ; + diff --git a/extra/bunny/model/model.factor b/extra/bunny/model/model.factor new file mode 100644 index 0000000000..b238bd8b99 --- /dev/null +++ b/extra/bunny/model/model.factor @@ -0,0 +1,114 @@ +USING: alien alien.c-types arrays sequences math +math.vectors math.matrices math.parser io io.files kernel opengl +opengl.gl opengl.glu 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 100000 (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 } -rot + [ >r 2dup r> normal ] each drop + [ normalize ] map ; + +: read-model ( stream -- model ) + "Reading model" print flush [ + 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 ; + +: ( model -- geom ) + GL_COMPILE [ first3 draw-triangles ] make-dlist + bunny-dlist construct-boa ; + +: ( model -- geom ) + [ + [ first concat ] [ second concat ] bi + append >float-array + GL_ARRAY_BUFFER swap GL_STATIC_DRAW + ] [ + third concat >c-uint-array + GL_ELEMENT_ARRAY_BUFFER swap GL_STATIC_DRAW + ] + [ 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 ; + +: ( model -- geom ) + "1.5" { "GL_ARB_vertex_buffer_object" } + has-gl-version-or-extensions? + [ ] [ ] if ; diff --git a/extra/bunny/outlined/outlined.factor b/extra/bunny/outlined/outlined.factor new file mode 100644 index 0000000000..d7064ebdde --- /dev/null +++ b/extra/bunny/outlined/outlined.factor @@ -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 check-gl-shader + cel-shaded-fragment-shader-lib-source check-gl-shader + outlined-pass1-fragment-shader-main-source check-gl-shader + 3array check-gl-program ; + +: pass2-program ( -- program ) + outlined-pass2-vertex-shader-source + outlined-pass2-fragment-shader-source ; + +: ( 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 ; diff --git a/extra/bunny/tags.txt b/extra/bunny/tags.txt index cb5fc203e1..339115d3c7 100644 --- a/extra/bunny/tags.txt +++ b/extra/bunny/tags.txt @@ -1 +1,2 @@ demos +opengl diff --git a/extra/cel-shading/cel-shading.factor b/extra/cel-shading/cel-shading.factor deleted file mode 100644 index 64d23275e9..0000000000 --- a/extra/cel-shading/cel-shading.factor +++ /dev/null @@ -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 ) - 0.0 0.0 0.375 - 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 - ; - -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" open-window ] with-ui ; - -MAIN: cel-shading-window diff --git a/extra/cocoa/views/views.factor b/extra/cocoa/views/views.factor index cc948df55f..7b8de9067c 100644 --- a/extra/cocoa/views/views.factor +++ b/extra/cocoa/views/views.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: alien.c-types arrays kernel math namespaces cocoa -cocoa.messages cocoa.classes cocoa.types sequences ; +cocoa.messages cocoa.classes cocoa.types sequences +continuations ; IN: cocoa.views : NSOpenGLPFAAllRenderers 1 ; @@ -35,11 +36,23 @@ IN: cocoa.views : NSOpenGLPFAPixelBuffer 90 ; : NSOpenGLPFAVirtualScreenCount 128 ; + + +: with-software-renderer ( quot -- ) + t +software-renderer+ set + [ f +software-renderer+ set ] + [ ] cleanup ; inline + : ( -- pixelfmt ) NSOpenGLPixelFormat -> alloc [ NSOpenGLPFAWindow , NSOpenGLPFADoubleBuffer , NSOpenGLPFADepthSize , 16 , + +software-renderer+ get [ NSOpenGLPFARobust , ] when 0 , ] { } make >c-int-array -> initWithAttributes: diff --git a/extra/cocoa/windows/windows.factor b/extra/cocoa/windows/windows.factor old mode 100644 new mode 100755 index f1c66f5e58..b45acaf852 --- a/extra/cocoa/windows/windows.factor +++ b/extra/cocoa/windows/windows.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2006, 2007 Slava Pestov ! See http://factorcode.org/license.txt for BSD license. USING: arrays kernel math cocoa cocoa.messages cocoa.classes -sequences ; +sequences math.bitfields ; IN: cocoa.windows : NSBorderlessWindowMask 0 ; inline @@ -15,10 +15,12 @@ IN: cocoa.windows : NSBackingStoreBuffered 2 ; inline : standard-window-type - NSTitledWindowMask - NSClosableWindowMask bitor - NSMiniaturizableWindowMask bitor - NSResizableWindowMask bitor ; inline + { + NSTitledWindowMask + NSClosableWindowMask + NSMiniaturizableWindowMask + NSResizableWindowMask + } flags ; inline : ( rect -- window ) NSWindow -> alloc swap diff --git a/extra/db/db.factor b/extra/db/db.factor new file mode 100644 index 0000000000..b765924cd6 --- /dev/null +++ b/extra/db/db.factor @@ -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 ( 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: db ( str -- statement ) +HOOK: 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 ; + +: ( 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 ) + [ do-query ] with-disposal ; + +: sql-command ( sql -- ) + [ 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 ; diff --git a/extra/postgresql/authors.txt b/extra/db/postgresql/authors.txt similarity index 100% rename from extra/postgresql/authors.txt rename to extra/db/postgresql/authors.txt diff --git a/extra/postgresql/libpq/libpq.factor b/extra/db/postgresql/ffi/ffi.factor similarity index 56% rename from extra/postgresql/libpq/libpq.factor rename to extra/db/postgresql/ffi/ffi.factor index faeb3f9aa4..dbaa70c625 100644 --- a/extra/postgresql/libpq/libpq.factor +++ b/extra/db/postgresql/ffi/ffi.factor @@ -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 ( ) ; diff --git a/extra/db/postgresql/lib/lib.factor b/extra/db/postgresql/lib/lib.factor new file mode 100644 index 0000000000..a940a42ae4 --- /dev/null +++ b/extra/db/postgresql/lib/lib.factor @@ -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 ; diff --git a/extra/db/postgresql/postgresql-tests.factor b/extra/db/postgresql/postgresql-tests.factor new file mode 100644 index 0000000000..c5a5155d12 --- /dev/null +++ b/extra/db/postgresql/postgresql-tests.factor @@ -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" ; +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" + [ + { "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 diff --git a/extra/db/postgresql/postgresql.factor b/extra/db/postgresql/postgresql.factor new file mode 100644 index 0000000000..df778cc80d --- /dev/null +++ b/extra/db/postgresql/postgresql.factor @@ -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 ; +: ( statement -- postgresql-statement ) + postgresql-statement construct-delegate ; + +: ( 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 swap set-delegate ; + +M: postgresql-db dispose ( db -- ) + db-handle PQfinish ; + +: with-postgresql ( host ust pass db quot -- ) + >r 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 + 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 ( sql -- statement ) + { set-statement-sql } statement construct + ; + +M: postgresql-db ( sql -- statement ) + { set-statement-sql } statement construct + ; + +M: postgresql-db begin-transaction ( -- ) + "BEGIN" sql-command ; + +M: postgresql-db commit-transaction ( -- ) + "COMMIT" sql-command ; + +M: postgresql-db rollback-transaction ( -- ) + "ROLLBACK" sql-command ; diff --git a/extra/db/sqlite/authors.txt b/extra/db/sqlite/authors.txt new file mode 100644 index 0000000000..26093b451b --- /dev/null +++ b/extra/db/sqlite/authors.txt @@ -0,0 +1,2 @@ +Chris Double +Doug Coleman diff --git a/extra/db/sqlite/ffi/ffi.factor b/extra/db/sqlite/ffi/ffi.factor new file mode 100644 index 0000000000..609c597b35 --- /dev/null +++ b/extra/db/sqlite/ffi/ffi.factor @@ -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 ) ; diff --git a/extra/db/sqlite/lib/lib.factor b/extra/db/sqlite/lib/lib.factor new file mode 100644 index 0000000000..e5f8425d92 --- /dev/null +++ b/extra/db/sqlite/lib/lib.factor @@ -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*" + [ 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*" "void*" + [ 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? ; diff --git a/extra/db/sqlite/sqlite-tests.factor b/extra/db/sqlite/sqlite-tests.factor new file mode 100644 index 0000000000..f64b8d1104 --- /dev/null +++ b/extra/db/sqlite/sqlite-tests.factor @@ -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" + [ + { { ":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 diff --git a/extra/db/sqlite/sqlite.factor b/extra/db/sqlite/sqlite.factor new file mode 100644 index 0000000000..49462dcc50 --- /dev/null +++ b/extra/db/sqlite/sqlite.factor @@ -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 + +M: sqlite-db db-open ( db -- ) + dup sqlite-db-path sqlite-open + 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 r> with-db ; inline + +TUPLE: sqlite-statement ; +C: sqlite-statement + +TUPLE: sqlite-result-set ; +: ( query -- sqlite-result-set ) + dup statement-handle sqlite-result-set ; + +M: sqlite-db ( str -- obj ) + ; + +M: sqlite-db ( str -- obj ) + db get db-handle over sqlite-prepare + { set-statement-sql set-statement-handle } statement construct + [ 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 ; + +M: sqlite-db begin-transaction ( -- ) + "BEGIN" sql-command ; + +M: sqlite-db commit-transaction ( -- ) + "COMMIT" sql-command ; + +M: sqlite-db rollback-transaction ( -- ) + "ROLLBACK" sql-command ; diff --git a/extra/db/sqlite/test.txt b/extra/db/sqlite/test.txt new file mode 100644 index 0000000000..e4487d30f9 --- /dev/null +++ b/extra/db/sqlite/test.txt @@ -0,0 +1,3 @@ +create table person (name varchar(30), country varchar(30)); +insert into person values('John', 'America'); +insert into person values('Jane', 'New Zealand'); diff --git a/extra/delegate/delegate.factor b/extra/delegate/delegate.factor index 4cd25baeb9..c0da9c51bc 100755 --- a/extra/delegate/delegate.factor +++ b/extra/delegate/delegate.factor @@ -27,7 +27,7 @@ M: tuple-class group-words swap [ slot-spec-writer ] map append ; : define-consult-method ( word class quot -- ) - pick add spin define-method ; + pick add spin define-method ; : define-consult ( class group quot -- ) >r group-words r> diff --git a/extra/http/client/client.factor b/extra/http/client/client.factor index dde2c7d205..8e6d8257a4 100755 --- a/extra/http/client/client.factor +++ b/extra/http/client/client.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: assocs http kernel math math.parser namespaces sequences io io.sockets io.streams.string io.files strings splitting -continuations ; +continuations assocs.lib ; IN: http.client : parse-host ( url -- host port ) @@ -44,7 +44,7 @@ DEFER: http-get-stream #! Should this support Location: headers that are #! relative URLs? pick 100 /i 3 = [ - dispose "Location" swap at nip http-get-stream + dispose "location" swap peek-at nip http-get-stream ] when ; : http-get-stream ( url -- code headers stream ) diff --git a/extra/http/http.factor b/extra/http/http.factor index 1bd9e18d98..755f36a538 100755 --- a/extra/http/http.factor +++ b/extra/http/http.factor @@ -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 ; - diff --git a/extra/http/server/responders/responders.factor b/extra/http/server/responders/responders.factor index 8dcaa7223d..70503236f6 100644 --- a/extra/http/server/responders/responders.factor +++ b/extra/http/server/responders/responders.factor @@ -2,7 +2,7 @@ ! See http://factorcode.org/license.txt for BSD license. USING: arrays assocs hashtables html html.elements splitting http io kernel math math.parser namespaces parser sequences -strings io.server ; +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 -- ) diff --git a/extra/io/buffers/buffers.factor b/extra/io/buffers/buffers.factor index f26fe50d79..ef12543d52 100755 --- a/extra/io/buffers/buffers.factor +++ b/extra/io/buffers/buffers.factor @@ -14,7 +14,7 @@ TUPLE: buffer size ptr fill pos ; dup buffer-ptr free f swap set-buffer-ptr ; : buffer-reset ( n buffer -- ) - [ set-buffer-fill ] keep 0 swap set-buffer-pos ; + 0 swap { set-buffer-fill set-buffer-pos } set-slots ; : buffer-consume ( n buffer -- ) [ buffer-pos + ] keep diff --git a/extra/io/launcher/launcher-docs.factor b/extra/io/launcher/launcher-docs.factor index 072cfcf959..e372f7a41e 100755 --- a/extra/io/launcher/launcher-docs.factor +++ b/extra/io/launcher/launcher-docs.factor @@ -116,6 +116,15 @@ HELP: run-detached "The output value can be passed to " { $link wait-for-process } " to get an exit code." } ; +HELP: kill-process +{ $values { "process" process } } +{ $description "Kills a running process. Does nothing if the process has already exited." } ; + +HELP: kill-process* +{ $values { "handle" "a process handle" } } +{ $contract "Kills a running process." } +{ $notes "User code should call " { $link kill-process } " intead." } ; + HELP: process { $class-description "A class representing an active or finished process." $nl @@ -137,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 } } @@ -166,6 +175,8 @@ $nl "The following words are used to launch processes:" { $subsection run-process } { $subsection run-detached } +"Stopping processes:" +{ $subsection kill-process } "Redirecting standard input and output to a pipe:" { $subsection } { $subsection with-process-stream } diff --git a/extra/io/launcher/launcher.factor b/extra/io/launcher/launcher.factor index 9fb24fb51a..9be90d28de 100755 --- a/extra/io/launcher/launcher.factor +++ b/extra/io/launcher/launcher.factor @@ -84,6 +84,11 @@ HOOK: run-process* io-backend ( desc -- handle ) : run-detached ( desc -- process ) >descriptor H{ { +detached+ t } } union run-process ; +HOOK: kill-process* io-backend ( handle -- ) + +: kill-process ( process -- ) + process-handle [ kill-process* ] when* ; + HOOK: process-stream* io-backend ( desc -- stream process ) TUPLE: process-stream process ; @@ -93,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 [ swap with-stream ] keep - process-stream-process ; inline + process-stream-process wait-for-process ; inline : notify-exit ( status process -- ) [ set-process-status ] keep diff --git a/extra/io/monitor/monitor.factor b/extra/io/monitor/monitor.factor index 4dc5081513..1d8499b392 100755 --- a/extra/io/monitor/monitor.factor +++ b/extra/io/monitor/monitor.factor @@ -1,11 +1,39 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. -USING: io.backend kernel continuations ; +USING: io.backend kernel continuations namespaces sequences +assocs hashtables sorting arrays ; IN: io.monitor +array ; + +PRIVATE> + HOOK: io-backend ( path recursive? -- monitor ) -HOOK: next-change io-backend ( monitor -- path changes ) +: next-change ( monitor -- path changed ) + dup check-monitor + dup monitor-queue dup assoc-empty? [ + drop dup fill-queue next-change + ] [ nip dequeue-change ] if ; SYMBOL: +add-file+ SYMBOL: +remove-file+ diff --git a/extra/io/unix/backend/backend.factor b/extra/io/unix/backend/backend.factor index 1b66c0332e..7112c48551 100755 --- a/extra/io/unix/backend/backend.factor +++ b/extra/io/unix/backend/backend.factor @@ -14,9 +14,9 @@ TUPLE: io-task port callbacks ; : io-task-fd io-task-port port-handle ; -: ( port continuation class -- task ) - >r 1vector io-task construct-boa r> construct-delegate ; - inline +: ( port continuation/f class -- task ) + >r [ 1vector ] [ V{ } clone ] if* io-task construct-boa + r> construct-delegate ; inline TUPLE: input-task ; @@ -194,7 +194,7 @@ TUPLE: mx-port mx ; TUPLE: mx-task ; : ( port -- task ) - f io-task construct-boa mx-task construct-delegate ; + f mx-task ; M: mx-task do-io-task io-task-port mx-port-mx 0 swap wait-for-events f ; diff --git a/extra/io/unix/files/files.factor b/extra/io/unix/files/files.factor index b56e62d3c4..edee598435 100755 --- a/extra/io/unix/files/files.factor +++ b/extra/io/unix/files/files.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2007 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: io.backend io.nonblocking io.unix.backend io.files io -unix kernel math continuations ; +unix kernel math continuations math.bitfields ; IN: io.unix.files : read-flags O_RDONLY ; inline @@ -12,7 +12,7 @@ IN: io.unix.files M: unix-io ( path -- stream ) open-read ; -: write-flags O_WRONLY O_CREAT O_TRUNC bitor bitor ; inline +: write-flags { O_WRONLY O_CREAT O_TRUNC } flags ; inline : open-write ( path -- fd ) write-flags file-mode open dup io-error ; @@ -20,7 +20,7 @@ M: unix-io ( path -- stream ) M: unix-io ( path -- stream ) open-write ; -: append-flags O_WRONLY O_APPEND O_CREAT bitor bitor ; inline +: append-flags { O_WRONLY O_APPEND O_CREAT } flags ; inline : open-append ( path -- fd ) append-flags file-mode open dup io-error diff --git a/extra/io/unix/launcher/launcher.factor b/extra/io/unix/launcher/launcher.factor index 0135b55a7e..93278e2b1a 100755 --- a/extra/io/unix/launcher/launcher.factor +++ b/extra/io/unix/launcher/launcher.factor @@ -57,7 +57,8 @@ MEMO: 'arguments' ( -- parser ) : setup-redirection ( -- ) +stdin+ get read-flags 0 redirect +stdout+ get write-flags 1 redirect - +stderr+ get write-flags 2 redirect ; + +stderr+ get dup +stdout+ eq? + [ drop 1 2 dup2 io-error ] [ write-flags 2 redirect ] if ; : spawn-process ( -- ) [ @@ -74,6 +75,9 @@ M: unix-io run-process* ( desc -- pid ) [ spawn-process ] [ ] with-fork ] with-descriptor ; +M: unix-io kill-process* ( pid -- ) + SIGTERM kill io-error ; + : open-pipe ( -- pair ) 2 "int" dup pipe zero? [ 2 c-int-array> ] [ drop f ] if ; @@ -107,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 diff --git a/extra/io/unix/linux/linux.factor b/extra/io/unix/linux/linux.factor index 6d55decb5a..1707ac9546 100755 --- a/extra/io/unix/linux/linux.factor +++ b/extra/io/unix/linux/linux.factor @@ -1,15 +1,142 @@ ! Copyright (C) 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. +USING: kernel io.backend io.monitor io.monitor.private io.files +io.buffers io.nonblocking io.unix.backend io.unix.select +io.unix.launcher unix.linux.inotify assocs namespaces threads +continuations init math alien.c-types alien ; IN: io.unix.linux -USING: io.backend io.unix.backend io.unix.launcher io.unix.select -namespaces kernel assocs unix.process init ; TUPLE: linux-io ; INSTANCE: linux-io unix-io +TUPLE: linux-monitor path wd callback ; + +: ( path wd -- monitor ) + f (monitor) { + set-linux-monitor-path + set-linux-monitor-wd + set-delegate + } linux-monitor construct ; + +TUPLE: inotify watches ; + +: watches ( -- assoc ) inotify get-global inotify-watches ; + +: wd>monitor ( wd -- monitor ) watches at ; + +: wd>path ( wd -- path ) wd>monitor linux-monitor-path ; + +: ( -- port ) + H{ } clone + inotify_init dup io-error inotify + { set-inotify-watches set-delegate } inotify construct ; + +: inotify-fd inotify get-global port-handle ; + +: (add-watch) ( path mask -- wd ) + inotify-fd -rot inotify_add_watch dup io-error ; + +: check-existing ( wd -- ) + watches key? [ + "Cannot open multiple monitors for the same file" throw + ] when ; + +: add-watch ( path mask -- monitor ) + dupd (add-watch) + dup check-existing + [ dup ] keep watches set-at ; + +: remove-watch ( monitor -- ) + dup linux-monitor-wd watches delete-at + linux-monitor-wd inotify-fd swap inotify_rm_watch io-error ; + +M: linux-io ( path recursive? -- monitor ) + drop IN_CHANGE_EVENTS add-watch ; + +: notify-callback ( monitor -- ) + dup linux-monitor-callback + f rot set-linux-monitor-callback + [ schedule-thread ] when* ; + +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 ] callcc0 + check-monitor ; + +M: linux-monitor dispose ( monitor -- ) + dup check-monitor + t over set-monitor-closed? + dup notify-callback + remove-watch ; + +: ?flag ( n mask symbol -- n ) + pick rot bitand 0 > [ , ] [ drop ] if ; + +: parse-action ( mask -- changed ) + [ + IN_CREATE +add-file+ ?flag + IN_DELETE +remove-file+ ?flag + IN_DELETE_SELF +remove-file+ ?flag + IN_MODIFY +modify-file+ ?flag + IN_ATTRIB +modify-file+ ?flag + IN_MOVED_FROM +rename-file+ ?flag + IN_MOVED_TO +rename-file+ ?flag + IN_MOVE_SELF +rename-file+ ?flag + drop + ] { } make ; + +: parse-file-notify ( buffer -- changed path ) + { + inotify-event-wd + inotify-event-name + inotify-event-mask + } get-slots + parse-action -rot alien>char-string >r wd>path r> path+ ; + +: events-exhausted? ( i buffer -- ? ) + buffer-fill >= ; + +: inotify-event@ ( i buffer -- alien ) + buffer-ptr ; + +: next-event ( i buffer -- i buffer ) + 2dup inotify-event@ + inotify-event-len "inotify-event" heap-size + + swap >r + r> ; + +: parse-file-notifications ( i buffer -- ) + 2dup events-exhausted? [ 2drop ] [ + 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 ; + +: read-notifications ( port -- ) + dup refill drop + 0 over parse-file-notifications + 0 swap buffer-reset ; + +TUPLE: inotify-task ; + +: ( port -- task ) + f inotify-task ; + +: init-inotify ( mx -- ) + + dup inotify set-global + swap register-io-task ; + +M: inotify-task do-io-task ( task -- ) + io-task-port read-notifications f ; + M: linux-io init-io ( -- ) - mx set-global ; + dup mx set-global init-inotify ; T{ linux-io } set-io-backend diff --git a/extra/io/windows/launcher/launcher.factor b/extra/io/windows/launcher/launcher.factor index ec53d9152c..f3f78fbb88 100755 --- a/extra/io/windows/launcher/launcher.factor +++ b/extra/io/windows/launcher/launcher.factor @@ -48,10 +48,10 @@ TUPLE: CreateProcess-args } get-slots CreateProcess win32-error=0/f ; : escape-argument ( str -- newstr ) - [ [ dup CHAR: " = [ CHAR: \\ , ] when , ] each ] "" make ; + CHAR: \s over member? [ "\"" swap "\"" 3append ] when ; : join-arguments ( args -- cmd-line ) - " " join ; + [ escape-argument ] map " " join ; : app-name/cmd-line ( -- app-name cmd-line ) +command+ get [ @@ -122,8 +122,7 @@ TUPLE: CreateProcess-args +stderr+ get dup +stdout+ eq? [ drop - CreateProcess-args-lpStartupInfo - STARTUPINFO-hStdOutput + CreateProcess-args-lpStartupInfo STARTUPINFO-hStdOutput ] [ GENERIC_WRITE CREATE_ALWAYS redirect swap inherited-stderr ?closed @@ -162,6 +161,10 @@ M: windows-io run-process* ( desc -- handle ) ] with-descriptor ] with-destructors ; +M: windows-io kill-process* ( handle -- ) + PROCESS_INFORMATION-hProcess + 255 TerminateProcess win32-error=0/f ; + : dispose-process ( process-information -- ) #! From MSDN: "Handles in PROCESS_INFORMATION must be closed #! with CloseHandle when they are no longer needed." diff --git a/extra/io/windows/nt/monitor/monitor.factor b/extra/io/windows/nt/monitor/monitor.factor index 8e0e63923d..d418dff270 100755 --- a/extra/io/windows/nt/monitor/monitor.factor +++ b/extra/io/windows/nt/monitor/monitor.factor @@ -3,12 +3,10 @@ USING: alien.c-types destructors io.windows io.windows.nt.backend kernel math windows windows.kernel32 windows.types libc assocs alien namespaces continuations -io.monitor io.nonblocking io.buffers io.files io sequences -hashtables sorting arrays combinators ; +io.monitor io.monitor.private io.nonblocking io.buffers io.files +io sequences hashtables sorting arrays combinators ; IN: io.windows.nt.monitor -TUPLE: monitor path recursive? queue closed? ; - : open-directory ( path -- handle ) FILE_LIST_DIRECTORY share-mode @@ -22,23 +20,26 @@ TUPLE: monitor path recursive? queue closed? ; dup add-completion f ; +TUPLE: win32-monitor path recursive? ; + +: ( path recursive? port -- monitor ) + (monitor) { + set-win32-monitor-path + set-win32-monitor-recursive? + set-delegate + } win32-monitor construct ; + M: windows-nt-io ( path recursive? -- monitor ) [ - >r dup open-directory monitor r> { - set-monitor-path - set-delegate - set-monitor-recursive? - } monitor construct + over open-directory win32-monitor + ] with-destructors ; -: check-closed ( monitor -- ) - port-type closed eq? [ "Monitor closed" throw ] when ; - : begin-reading-changes ( monitor -- overlapped ) dup port-handle win32-file-handle over buffer-ptr pick buffer-size - roll monitor-recursive? 1 0 ? + roll win32-monitor-recursive? 1 0 ? FILE_NOTIFY_CHANGE_ALL 0 (make-overlapped) @@ -49,6 +50,7 @@ M: windows-nt-io ( path recursive? -- monitor ) [ dup begin-reading-changes swap [ save-callback ] 2keep + dup check-monitor ! we may have closed it... get-overlapped-result ] with-port-timeout ] with-destructors ; @@ -63,30 +65,20 @@ M: windows-nt-io ( path recursive? -- monitor ) { [ t ] [ +modify-file+ ] } } cond nip ; -: changed-file ( directory buffer -- changed path ) +: parse-file-notify ( directory buffer -- changed path ) { FILE_NOTIFY_INFORMATION-FileName FILE_NOTIFY_INFORMATION-FileNameLength FILE_NOTIFY_INFORMATION-Action - } get-slots >r memory>u16-string path+ r> parse-action swap ; + } get-slots parse-action 1array -rot + memory>u16-string path+ ; : (changed-files) ( directory buffer -- ) - 2dup changed-file namespace [ swap add ] change-at + 2dup parse-file-notify changed-file dup FILE_NOTIFY_INFORMATION-NextEntryOffset dup zero? [ 3drop ] [ swap (changed-files) ] if ; -: changed-files ( directory buffer len -- assoc ) - [ zero? [ 2drop ] [ (changed-files) ] if ] H{ } make-assoc ; - -: fill-queue ( monitor -- ) - dup monitor-path over buffer-ptr pick read-changes - changed-files +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 ; - -M: windows-nt-io next-change ( monitor -- path changes ) - dup check-closed - dup monitor-queue dup assoc-empty? [ - drop dup fill-queue next-change - ] [ - nip delete-any prune natural-sort >array - ] if ; diff --git a/extra/io/windows/windows.factor b/extra/io/windows/windows.factor index 419864b624..ee3f744bb0 100755 --- a/extra/io/windows/windows.factor +++ b/extra/io/windows/windows.factor @@ -5,7 +5,7 @@ io.buffers io.files io.nonblocking io.sockets io.binary io.sockets.impl windows.errors strings io.streams.duplex kernel math namespaces sequences windows windows.kernel32 windows.shell32 windows.types windows.winsock splitting -continuations ; +continuations math.bitfields ; IN: io.windows TUPLE: windows-nt-io ; @@ -31,8 +31,11 @@ M: windows-io normalize-directory ( string -- string ) "\\" ?tail drop "\\*" append ; : share-mode ( -- fixnum ) - FILE_SHARE_READ FILE_SHARE_WRITE bitor - FILE_SHARE_DELETE bitor ; foldable + { + FILE_SHARE_READ + FILE_SHARE_WRITE + FILE_SHARE_DELETE + } flags ; foldable : default-security-attributes ( -- obj ) "SECURITY_ATTRIBUTES" diff --git a/extra/line-art/line-art.factor b/extra/line-art/line-art.factor deleted file mode 100644 index 1a0ae6993f..0000000000 --- a/extra/line-art/line-art.factor +++ /dev/null @@ -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 ) - 40.0 -5.0 0.275 - 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 - ; -: (line-art-step2-program) ( -- step2 ) - line-art-step2-vertex-shader-source line-art-step2-fragment-shader-source - ; - -: (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" open-window ] with-ui ; - -MAIN: line-art-window diff --git a/extra/macros/zoo/authors.txt b/extra/macros/zoo/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/extra/macros/zoo/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/extra/macros/zoo/zoo.factor b/extra/macros/zoo/zoo.factor deleted file mode 100644 index 21edc39f19..0000000000 --- a/extra/macros/zoo/zoo.factor +++ /dev/null @@ -1,38 +0,0 @@ - -USING: kernel quotations arrays sequences sequences.private macros ; - -IN: macros.zoo - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! MACRO: narray ( n -- quot ) -! dup [ f ] curry -! swap [ -! [ swap [ set-nth-unsafe ] keep ] curry -! ] map concat append ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! MACRO: map-call-with ( quots -- ) -! [ [ [ keep ] curry ] map concat ] keep length [ nip narray ] curry compose ; - -! MACRO: map-call-with2 ( quots -- ) -! dup >r -! [ [ 2dup >r >r ] swap append [ r> r> ] append ] map concat -! [ 2drop ] append -! r> length [ narray ] curry append ; - -! MACRO: map-exec-with ( words -- ) [ 1quotation ] map [ map-call-with ] curry ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -! Conceptual implementation: - -! : pcall ( seq quots -- seq ) [ call ] 2map ; - -! MACRO: pcall ( quots -- ) -! [ [ unclip ] swap append ] map -! [ [ r> swap add >r ] append ] map -! concat -! [ { } >r ] swap append ! pre -! [ drop r> ] append ; ! post diff --git a/extra/opengl/authors.txt b/extra/opengl/authors.txt index e1907c6d91..55ac3c728e 100644 --- a/extra/opengl/authors.txt +++ b/extra/opengl/authors.txt @@ -1,2 +1,3 @@ Slava Pestov Eduardo Cavazos +Joe Groff diff --git a/extra/opengl-demo-support/authors.txt b/extra/opengl/capabilities/authors.txt similarity index 100% rename from extra/opengl-demo-support/authors.txt rename to extra/opengl/capabilities/authors.txt diff --git a/extra/opengl/capabilities/capabilities-docs.factor b/extra/opengl/capabilities/capabilities-docs.factor new file mode 100644 index 0000000000..e73b7a3f0b --- /dev/null +++ b/extra/opengl/capabilities/capabilities-docs.factor @@ -0,0 +1,59 @@ +USING: help.markup help.syntax io kernel math quotations +opengl.gl multiline assocs ; +IN: opengl.capabilities + +HELP: gl-version +{ $values { "version" "The version string from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; + +HELP: gl-vendor-version +{ $values { "version" "The vendor-specific version information from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; + +HELP: has-gl-version? +{ $values { "version" "A version string" } { "?" "A boolean value" } } +{ $description "Compares the version string returned by " { $link gl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; + +HELP: require-gl-version +{ $values { "version" "A version string" } } +{ $description "Throws an exception if " { $link has-gl-version? } " returns false for " { $snippet "version" } "." } ; + +HELP: glsl-version +{ $values { "version" "The GLSL version string from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that removes the vendor-specific information from the version string." } ; + +HELP: glsl-vendor-version +{ $values { "version" "The vendor-specific GLSL version information from the OpenGL implementation" } } +{ $description "Wrapper for " { $snippet "GL_SHADING_LANGUAGE_VERSION glGetString" } " that returns only the vendor-specific information from the version string." } ; + +HELP: has-glsl-version? +{ $values { "version" "A version string" } { "?" "A boolean value" } } +{ $description "Compares the version string returned by " { $link glsl-version } " to " { $snippet "version" } ". Returns true if the implementation version meets or exceeds " { $snippet "version" } "." } ; + +HELP: require-glsl-version +{ $values { "version" "A version string" } } +{ $description "Throws an exception if " { $link has-glsl-version? } " returns false for " { $snippet "version" } "." } ; + +HELP: gl-extensions +{ $values { "seq" "A sequence of strings naming the implementation-supported OpenGL extensions" } } +{ $description "Wrapper for " { $snippet "GL_EXTENSIONS glGetString" } " that returns a sequence of extension names supported by the OpenGL implementation." } ; + +HELP: has-gl-extensions? +{ $values { "extensions" "A sequence of extension name strings" } { "?" "A boolean value" } } +{ $description "Returns true if the set of " { $snippet "extensions" } " is a subset of the implementation-supported extensions returned by " { $link gl-extensions } "." } ; + +HELP: has-gl-version-or-extensions? +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } +{ $description "Returns true if either " { $link has-gl-version? } " or " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; + +HELP: require-gl-extensions +{ $values { "extensions" "A sequence of extension name strings" } } +{ $description "Throws an exception if " { $link has-gl-extensions? } " returns false for " { $snippet "extensions" } "." } ; + +HELP: require-gl-version-or-extensions +{ $values { "version" "A version string" } { "extensions" "A sequence of extension name strings" } } +{ $description "Throws an exception if neither " { $link has-gl-version? } " nor " { $link has-gl-extensions? } " returns true for " { $snippet "version" } " or " { $snippet "extensions" } ", respectively. Intended for use when required OpenGL functionality can be verified either by a minimum version or a set of equivalent extensions." } ; + +{ require-gl-version require-glsl-version require-gl-extensions require-gl-version-or-extensions has-gl-version? has-glsl-version? has-gl-extensions? has-gl-version-or-extensions? gl-version glsl-version gl-extensions } related-words + +ABOUT: "gl-utilities" diff --git a/extra/opengl/capabilities/capabilities.factor b/extra/opengl/capabilities/capabilities.factor new file mode 100644 index 0000000000..d9eb6fd679 --- /dev/null +++ b/extra/opengl/capabilities/capabilities.factor @@ -0,0 +1,67 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel namespaces sequences splitting opengl.gl +continuations math.parser math arrays ; +IN: opengl.capabilities + +: (require-gl) ( thing require-quot make-error-quot -- ) + >r dupd call + [ r> 2drop ] + [ r> " " make throw ] + if ; inline + +: gl-extensions ( -- seq ) + GL_EXTENSIONS glGetString " " split ; +: has-gl-extensions? ( extensions -- ? ) + gl-extensions swap [ over member? ] all? nip ; +: (make-gl-extensions-error) ( required-extensions -- ) + gl-extensions swap seq-diff + "Required OpenGL extensions not supported:\n" % + [ " " % % "\n" % ] each ; +: require-gl-extensions ( extensions -- ) + [ has-gl-extensions? ] + [ (make-gl-extensions-error) ] + (require-gl) ; + +: version-seq ( version-string -- version-seq ) + "." split [ string>number ] map ; + +: version<=> ( version1 version2 -- n ) + swap version-seq swap version-seq <=> ; + +: (gl-version) ( -- version vendor ) + GL_VERSION glGetString " " split1 ; +: gl-version ( -- version ) + (gl-version) drop ; +: gl-vendor-version ( -- version ) + (gl-version) nip ; +: has-gl-version? ( version -- ? ) + gl-version version<=> 0 <= ; +: (make-gl-version-error) ( required-version -- ) + "Required OpenGL version " % % " not supported (" % gl-version % " available)" % ; +: require-gl-version ( version -- ) + [ has-gl-version? ] + [ (make-gl-version-error) ] + (require-gl) ; + +: (glsl-version) ( -- version vendor ) + GL_SHADING_LANGUAGE_VERSION glGetString " " split1 ; +: glsl-version ( -- version ) + (glsl-version) drop ; +: glsl-vendor-version ( -- version ) + (glsl-version) nip ; +: has-glsl-version? ( version -- ? ) + glsl-version version<=> 0 <= ; +: require-glsl-version ( version -- ) + [ has-glsl-version? ] + [ "Required GLSL version " % % " not supported (" % glsl-version % " available)" % ] + (require-gl) ; + +: has-gl-version-or-extensions? ( version extensions -- ? ) + has-gl-extensions? swap has-gl-version? or ; + +: require-gl-version-or-extensions ( version extensions -- ) + 2array [ first2 has-gl-version-or-extensions? ] [ + dup first (make-gl-version-error) "\n" % + second (make-gl-extensions-error) "\n" % + ] (require-gl) ; diff --git a/extra/opengl/capabilities/summary.txt b/extra/opengl/capabilities/summary.txt new file mode 100644 index 0000000000..d31b63b8d4 --- /dev/null +++ b/extra/opengl/capabilities/summary.txt @@ -0,0 +1 @@ +Testing for OpenGL versions and extensions \ No newline at end of file diff --git a/extra/opengl/capabilities/tags.txt b/extra/opengl/capabilities/tags.txt new file mode 100644 index 0000000000..77282be3a9 --- /dev/null +++ b/extra/opengl/capabilities/tags.txt @@ -0,0 +1,2 @@ +opengl +bindings diff --git a/extra/opengl/demo-support/authors.txt b/extra/opengl/demo-support/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl/demo-support/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl-demo-support/opengl-demo-support.factor b/extra/opengl/demo-support/demo-support.factor similarity index 99% rename from extra/opengl-demo-support/opengl-demo-support.factor rename to extra/opengl/demo-support/demo-support.factor index ecc6458d41..59b7a3bcc3 100644 --- a/extra/opengl-demo-support/opengl-demo-support.factor +++ b/extra/opengl/demo-support/demo-support.factor @@ -1,6 +1,6 @@ USING: arrays combinators.lib kernel math math.functions math.vectors namespaces opengl opengl.gl sequences ui ui.gadgets ui.gestures ui.render ; -IN: opengl-demo-support +IN: opengl.demo-support : NEAR-PLANE 1.0 64.0 / ; inline : FAR-PLANE 4.0 ; inline diff --git a/extra/opengl-demo-support/summary.txt b/extra/opengl/demo-support/summary.txt similarity index 100% rename from extra/opengl-demo-support/summary.txt rename to extra/opengl/demo-support/summary.txt diff --git a/extra/opengl-demo-support/tags.txt b/extra/opengl/demo-support/tags.txt similarity index 100% rename from extra/opengl-demo-support/tags.txt rename to extra/opengl/demo-support/tags.txt diff --git a/extra/opengl/framebuffers/authors.txt b/extra/opengl/framebuffers/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl/framebuffers/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl/framebuffers/framebuffer-docs.factor b/extra/opengl/framebuffers/framebuffer-docs.factor new file mode 100644 index 0000000000..c5507dcce1 --- /dev/null +++ b/extra/opengl/framebuffers/framebuffer-docs.factor @@ -0,0 +1,35 @@ +USING: help.markup help.syntax io kernel math quotations +opengl.gl multiline assocs ; +IN: opengl.framebuffers + +HELP: gen-framebuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenFramebuffersEXT } " to handle the common case of generating a single framebuffer ID." } ; + +HELP: gen-renderbuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glGenRenderbuffersEXT } " to handle the common case of generating a single render buffer ID." } ; + +HELP: delete-framebuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteFramebuffersEXT } " to handle the common case of deleting a single framebuffer ID." } ; + +HELP: delete-renderbuffer +{ $values { "id" integer } } +{ $description "Wrapper for " { $link glDeleteRenderbuffersEXT } " to handle the common case of deleting a single render buffer ID." } ; + +{ gen-framebuffer delete-framebuffer } related-words +{ gen-renderbuffer delete-renderbuffer } related-words + +HELP: framebuffer-incomplete? +{ $values { "status/f" "The framebuffer error code, or " { $snippet "f" } " if the framebuffer is render-complete." } } +{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " to see if it is incomplete, i.e., it is not ready to be rendered to." } ; + +HELP: check-framebuffer +{ $description "Checks the framebuffer currently bound by " { $link glBindFramebufferEXT } " or " { $link with-framebuffer } " with " { $link framebuffer-incomplete? } ", and throws a descriptive error if the framebuffer is incomplete." } ; + +HELP: with-framebuffer +{ $values { "id" "The id of a framebuffer object." } { "quot" "a quotation" } } +{ $description "Binds framebuffer " { $snippet "id" } " in the dynamic extent of " { $snippet "quot" } ", restoring the window framebuffer when finished." } ; + +ABOUT: "gl-utilities" \ No newline at end of file diff --git a/extra/opengl/framebuffers/framebuffers.factor b/extra/opengl/framebuffers/framebuffers.factor new file mode 100644 index 0000000000..346789e1c5 --- /dev/null +++ b/extra/opengl/framebuffers/framebuffers.factor @@ -0,0 +1,43 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: opengl opengl.gl combinators continuations kernel +alien.c-types ; +IN: opengl.framebuffers + +: gen-framebuffer ( -- id ) + [ glGenFramebuffersEXT ] (gen-gl-object) ; +: gen-renderbuffer ( -- id ) + [ glGenRenderbuffersEXT ] (gen-gl-object) ; + +: delete-framebuffer ( id -- ) + [ glDeleteFramebuffersEXT ] (delete-gl-object) ; +: delete-renderbuffer ( id -- ) + [ glDeleteRenderbuffersEXT ] (delete-gl-object) ; + +: framebuffer-incomplete? ( -- status/f ) + GL_FRAMEBUFFER_EXT glCheckFramebufferStatusEXT + dup GL_FRAMEBUFFER_COMPLETE_EXT = f rot ? ; + +: framebuffer-error ( status -- * ) + { + { GL_FRAMEBUFFER_COMPLETE_EXT [ "framebuffer complete" ] } + { GL_FRAMEBUFFER_UNSUPPORTED_EXT [ "framebuffer configuration unsupported" ] } + { GL_FRAMEBUFFER_INCOMPLETE_ATTACHMENT_EXT [ "framebuffer incomplete (incomplete attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_MISSING_ATTACHMENT_EXT [ "framebuffer incomplete (missing attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_DIMENSIONS_EXT [ "framebuffer incomplete (dimension mismatch)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_FORMATS_EXT [ "framebuffer incomplete (format mismatch)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_DRAW_BUFFER_EXT [ "framebuffer incomplete (draw buffer(s) have no attachment)" ] } + { GL_FRAMEBUFFER_INCOMPLETE_READ_BUFFER_EXT [ "framebuffer incomplete (read buffer has no attachment)" ] } + [ drop gl-error "unknown framebuffer error" ] + } case throw ; + +: check-framebuffer ( -- ) + framebuffer-incomplete? [ framebuffer-error ] when* ; + +: with-framebuffer ( id quot -- ) + GL_FRAMEBUFFER_EXT rot glBindFramebufferEXT + [ GL_FRAMEBUFFER_EXT 0 glBindFramebufferEXT ] [ ] cleanup ; inline + +: framebuffer-attachment ( attachment -- id ) + GL_FRAMEBUFFER_EXT swap GL_FRAMEBUFFER_ATTACHMENT_OBJECT_NAME_EXT + 0 [ glGetFramebufferAttachmentParameterivEXT ] keep *uint ; diff --git a/extra/opengl/framebuffers/summary.txt b/extra/opengl/framebuffers/summary.txt new file mode 100644 index 0000000000..3ef713ac13 --- /dev/null +++ b/extra/opengl/framebuffers/summary.txt @@ -0,0 +1 @@ +Rendering to offscreen textures using the GL_EXT_framebuffer_object extension \ No newline at end of file diff --git a/extra/opengl/framebuffers/tags.txt b/extra/opengl/framebuffers/tags.txt new file mode 100644 index 0000000000..77282be3a9 --- /dev/null +++ b/extra/opengl/framebuffers/tags.txt @@ -0,0 +1,2 @@ +opengl +bindings diff --git a/extra/opengl/opengl-docs.factor b/extra/opengl/opengl-docs.factor index cc8221baa1..97120237ec 100644 --- a/extra/opengl/opengl-docs.factor +++ b/extra/opengl/opengl-docs.factor @@ -1,5 +1,5 @@ USING: help.markup help.syntax io kernel math quotations -opengl.gl ; +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 } " - 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 } " - 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 } " - Compile GLSL code into a fragment shader object "} - } -} ; - -HELP: -{ $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: -{ $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 " } "." } ; - -HELP: -{ $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 " } "." } ; - -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 } ", " { $link } " - 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: -{ $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: -{ $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 } " 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." } ; - -{ } 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" diff --git a/extra/opengl/opengl.factor b/extra/opengl/opengl.factor index 4ea91b867b..5afb6ef070 100755 --- a/extra/opengl/opengl.factor +++ b/extra/opengl/opengl.factor @@ -1,11 +1,11 @@ -! Copyright (C) 2005, 2007 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! Portions copyright (C) 2007 Eduardo Cavazos. ! Portions copyright (C) 2008 Joe Groff. ! See http://factorcode.org/license.txt for BSD license. 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 ; +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 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 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* ; +: ( 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 ) + ; 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 [ 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 @@ -233,7 +231,8 @@ TUPLE: sprite loc dim dim2 dlist texture ; dup sprite-dlist delete-dlist sprite-texture delete-texture ; -: free-sprites ( sprites -- ) [ [ free-sprite ] when* ] each ; +: free-sprites ( sprites -- ) + [ nip [ free-sprite ] when* ] assoc-each ; : with-translation ( loc quot -- ) GL_MODELVIEW [ >r gl-translate r> call ] do-matrix ; inline @@ -249,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 [ - swap call - ] keep free ; inline - -: ( 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 [ glGetShaderiv ] keep *int ; - -: gl-shader-ok? ( shader -- ? ) - GL_COMPILE_STATUS gl-shader-get-int c-true? ; - -: ( source -- vertex-shader ) - GL_VERTEX_SHADER ; inline - -: (vertex-shader?) ( object -- ? ) - dup (gl-shader?) - [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ] - [ drop f ] if ; - -: ( source -- fragment-shader ) - GL_FRAGMENT_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 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 - -: ( 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 [ 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 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" 0 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?) ; - -: ( vertex-shader-source fragment-shader-source -- program ) - >r check-gl-shader - r> check-gl-shader - 2array 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) ; diff --git a/extra/opengl/shaders/authors.txt b/extra/opengl/shaders/authors.txt new file mode 100644 index 0000000000..6a0dc7293a --- /dev/null +++ b/extra/opengl/shaders/authors.txt @@ -0,0 +1 @@ +Joe Groff \ No newline at end of file diff --git a/extra/opengl/shaders/shaders-docs.factor b/extra/opengl/shaders/shaders-docs.factor new file mode 100644 index 0000000000..e065367323 --- /dev/null +++ b/extra/opengl/shaders/shaders-docs.factor @@ -0,0 +1,112 @@ +USING: help.markup help.syntax io kernel math quotations +opengl.gl multiline assocs ; +IN: opengl.shaders + +HELP: gl-shader +{ $class-description { $snippet "gl-shader" } " is a predicate class comprising values returned by OpenGL to represent shader objects. The following words are provided for creating and manipulating these objects:" + { $list + { { $link } " - 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 } " - 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 } " - Compile GLSL code into a fragment shader object "} + } +} ; + +HELP: +{ $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: +{ $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 " } "." } ; + +HELP: +{ $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 " } "." } ; + +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 } ", " { $link } " - 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: +{ $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: +{ $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 } " 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." } ; + +{ } related-words + +HELP: gl-program-ok? +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Returns a boolean value indicating whether the given program object linked successfully. Link errors and warnings are available in the program's info log, which can be gotten using " { $link gl-program-info-log } "." } ; + +HELP: check-gl-program +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Throws an error containing the " { $link gl-program-info-log } " for the program object if it failed to link. Otherwise, the program object is left on the stack." } ; + +HELP: gl-program-info-log +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Retrieves the info log for " { $snippet "program" } ", including any errors or warnings generated in linking the program object." } ; + +HELP: delete-gl-program +{ $values { "program" "A " { $link gl-program } " object" } } +{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ; + +HELP: with-gl-program +{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } } +{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack as the associated quotation is called.\n\nExample:" } +{ $code <" +! From bunny.cel-shaded +: (draw-cel-shaded-bunny) ( geom program -- ) + { + { "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] } + { "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] } + { "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] } + { "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] } + { "shininess" [ 100.0 glUniform1f ] } + } [ bunny-geom ] with-gl-program ; +"> } ; + +ABOUT: "gl-utilities" diff --git a/extra/opengl/shaders/shaders.factor b/extra/opengl/shaders/shaders.factor new file mode 100644 index 0000000000..0ff708d6d4 --- /dev/null +++ b/extra/opengl/shaders/shaders.factor @@ -0,0 +1,134 @@ +! Copyright (C) 2008 Joe Groff. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel opengl.gl alien.c-types continuations namespaces +assocs alien libc opengl math sequences combinators.lib +macros arrays ; +IN: opengl.shaders + +: with-gl-shader-source-ptr ( string quot -- ) + swap string>char-alien malloc-byte-array [ + swap call + ] keep free ; inline + +: ( 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 [ glGetShaderiv ] keep *int ; + +: gl-shader-ok? ( shader -- ? ) + GL_COMPILE_STATUS gl-shader-get-int c-bool> ; + +: ( source -- vertex-shader ) + GL_VERTEX_SHADER ; inline + +: (vertex-shader?) ( object -- ? ) + dup (gl-shader?) + [ GL_SHADER_TYPE gl-shader-get-int GL_VERTEX_SHADER = ] + [ drop f ] if ; + +: ( source -- fragment-shader ) + GL_FRAGMENT_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 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 + +: ( 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 [ 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 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" + [ 0 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?) ; + +: ( vertex-shader-source fragment-shader-source -- program ) + >r check-gl-shader + r> check-gl-shader + 2array check-gl-program ; + diff --git a/extra/opengl/shaders/summary.txt b/extra/opengl/shaders/summary.txt new file mode 100644 index 0000000000..c55f76668f --- /dev/null +++ b/extra/opengl/shaders/summary.txt @@ -0,0 +1 @@ +OpenGL Shading Language (GLSL) support \ No newline at end of file diff --git a/extra/opengl/shaders/tags.txt b/extra/opengl/shaders/tags.txt new file mode 100644 index 0000000000..ce0345edc9 --- /dev/null +++ b/extra/opengl/shaders/tags.txt @@ -0,0 +1,3 @@ +opengl +glsl +bindings \ No newline at end of file diff --git a/extra/partial-apply/partial-apply.factor b/extra/partial-apply/partial-apply.factor new file mode 100644 index 0000000000..0340e53025 --- /dev/null +++ b/extra/partial-apply/partial-apply.factor @@ -0,0 +1,26 @@ + +USING: kernel sequences quotations math parser + shuffle combinators.cleave combinators.lib sequences.lib ; + +IN: partial-apply + +! Basic conceptual implementation. Todo: get it to compile. + +: apply-n ( obj quot i -- quot ) 1+ [ -nrot ] curry swap compose curry ; + +SYMBOL: _ + +SYMBOL: ~ + +: blank-positions ( quot -- seq ) + [ length 2 - ] [ _ indices ] bi [ - ] map-with ; + +: partial-apply ( pattern -- quot ) + [ blank-positions length nrev ] + [ peek 1quotation ] + [ blank-positions ] + tri + [ apply-n ] each ; + +: $[ \ ] [ >quotation ] parse-literal \ partial-apply parsed ; parsing + diff --git a/extra/postgresql/postgresql-tests.factor b/extra/postgresql/postgresql-tests.factor deleted file mode 100644 index c725882b67..0000000000 --- a/extra/postgresql/postgresql-tests.factor +++ /dev/null @@ -1,42 +0,0 @@ -! You will need to run 'createdb factor-test' to create the database. -! Set username and password in the 'connect' word. - -IN: postgresql-test -USING: kernel postgresql alien continuations io prettyprint -sequences namespaces ; - - -: test-connection ( host port pgopts pgtty db user pass -- bool ) - [ [ ] with-postgres ] catch "Error connecting!" "Connected!" ? print ; - -! just a basic demo - -"localhost" "" "" "" "test" "postgres" "" [ - "drop table animal" do-command - - "create table animal (id serial not null primary key, species varchar(256), name varchar(256), age integer)" do-command - "insert into animal (species, name, age) values ('lion', 'Mufasa', 5)" - do-command - - "select * from animal where name = 'Mufasa'" [ ] do-query - "select * from animal where name = 'Mufasa'" - [ - result>seq length 1 = [ "...there can only be one Mufasa..." throw ] unless - ] do-query - - "insert into animal (species, name, age) values ('lion', 'Simba', 1)" - do-command - - "select * from animal" - [ - "Animal table:" print - result>seq print-table - ] do-query - - ! intentional errors - ! [ "select asdf from animal" - ! [ ] do-query ] catch [ "caught: " write print ] when* - ! "select asdf from animal" [ ] do-query - ! "aofijweafew" do-command -] with-postgres - diff --git a/extra/postgresql/postgresql.factor b/extra/postgresql/postgresql.factor deleted file mode 100644 index 9d85b6a77e..0000000000 --- a/extra/postgresql/postgresql.factor +++ /dev/null @@ -1,61 +0,0 @@ -! Copyright (C) 2007 Doug Coleman. -! See http://factorcode.org/license.txt for BSD license. - -! adapted from libpq-fe.h version 7.4.7 -! tested on debian linux with postgresql 7.4.7 - -USING: arrays alien alien.syntax continuations io -kernel math namespaces postgresql.libpq prettyprint -quotations sequences debugger ; -IN: postgresql - -SYMBOL: db -SYMBOL: query-res - -: connect-postgres ( host port pgopts pgtty db user pass -- conn ) - PQsetdbLogin - dup PQstatus zero? [ "couldn't connect to database" throw ] unless ; - -: with-postgres ( host port pgopts pgtty db user pass quot -- ) - [ >r connect-postgres db set r> - [ db get PQfinish ] [ ] cleanup ] with-scope ; inline - -: postgres-error ( ret -- ret ) - dup zero? [ PQresultErrorMessage throw ] when ; - -: (do-query) ( PGconn query -- PGresult* ) - ! For queries that do not return rows, PQexec() returns PGRES_COMMAND_OK - ! For queries that return rows, PQexec() returns PGRES_TUPLES_OK - PQexec - dup PQresultStatus PGRES_COMMAND_OK = - over PQresultStatus PGRES_TUPLES_OK = - or [ - [ PQresultErrorMessage CHAR: \n swap remove ] keep PQclear throw - ] unless ; - -: (do-command) ( PGconn query -- PGresult* ) - [ (do-query) ] catch - [ - swap - "non-fatal error: " print - "\tQuery: " write "'" write write "'" print - "\t" write print - ] when* drop ; - -: do-command ( str -- ) - 1quotation \ (do-command) add db get swap call ; - -: prepare ( str quot word -- conn quot ) - rot 1quotation swap append swap append db get swap ; - -: do-query ( str quot -- ) - [ (do-query) query-res set ] prepare catch - [ rethrow ] [ query-res get PQclear ] if* ; - -: result>seq ( -- seq ) - query-res get [ PQnfields ] keep PQntuples - [ swap [ query-res get -rot PQgetvalue ] with map ] with map ; - -: print-table ( seq -- ) - [ [ write bl ] each "\n" write ] each ; - diff --git a/extra/project-euler/032/032.factor b/extra/project-euler/032/032.factor index d10326a076..2baa6f8714 100644 --- a/extra/project-euler/032/032.factor +++ b/extra/project-euler/032/032.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2008 Aaron Schaefer. ! See http://factorcode.org/license.txt for BSD license. USING: combinators.lib hashtables kernel math math.combinatorics math.parser - math.ranges project-euler.common sequences sorting ; + math.ranges project-euler.common sequences ; IN: project-euler.032 ! http://projecteuler.net/index.php?section=problems&id=32 @@ -63,9 +63,6 @@ PRIVATE> : source-032a ( -- seq ) 50 [1,b] 2000 [1,b] cartesian-product ; -: pandigital? ( n -- ? ) - number>string natural-sort "123456789" = ; - ! multiplicand/multiplier/product : mmp ( pair -- n ) first2 2dup * [ number>string ] 3apply 3append 10 string>integer ; diff --git a/extra/project-euler/037/037.factor b/extra/project-euler/037/037.factor new file mode 100644 index 0000000000..f2d5d17c4d --- /dev/null +++ b/extra/project-euler/037/037.factor @@ -0,0 +1,52 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.parser math.primes sequences ; +IN: project-euler.037 + +! http://projecteuler.net/index.php?section=problems&id=37 + +! DESCRIPTION +! ----------- + +! The number 3797 has an interesting property. Being prime itself, it is +! possible to continuously remove digits from left to right, and remain prime +! at each stage: 3797, 797, 97, and 7. Similarly we can work from right to +! left: 3797, 379, 37, and 3. + +! Find the sum of the only eleven primes that are both truncatable from left to +! right and right to left. + +! NOTE: 2, 3, 5, and 7 are not considered to be truncatable primes. + + +! SOLUTION +! -------- + + [ + dup prime? [ r-trunc? ] [ drop f ] if + ] [ + drop t + ] if ; + +: reverse-digits ( n -- m ) + number>string reverse 10 string>integer ; + +: l-trunc? ( n -- ? ) + reverse-digits 10 /i reverse-digits dup 0 > [ + dup prime? [ l-trunc? ] [ drop f ] if + ] [ + drop t + ] if ; + +PRIVATE> + +: euler037 ( -- answer ) + 23 1000000 primes-between [ r-trunc? ] subset [ l-trunc? ] subset sum ; + +! [ euler037 ] 100 ave-time +! 768 ms run / 9 ms GC ave time - 100 trials + +MAIN: euler037 diff --git a/extra/project-euler/038/038.factor b/extra/project-euler/038/038.factor new file mode 100644 index 0000000000..cbe6f2363c --- /dev/null +++ b/extra/project-euler/038/038.factor @@ -0,0 +1,55 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.parser math.ranges project-euler.common sequences ; +IN: project-euler.038 + +! http://projecteuler.net/index.php?section=problems&id=38 + +! DESCRIPTION +! ----------- + +! Take the number 192 and multiply it by each of 1, 2, and 3: + +! 192 × 1 = 192 +! 192 × 2 = 384 +! 192 × 3 = 576 + +! By concatenating each product we get the 1 to 9 pandigital, 192384576. We +! will call 192384576 the concatenated product of 192 and (1,2,3) + +! The same can be achieved by starting with 9 and multiplying by 1, 2, 3, 4, +! and 5, giving the pandigital, 918273645, which is the concatenated product of +! 9 and (1,2,3,4,5). + +! What is the largest 1 to 9 pandigital 9-digit number that can be formed as +! the concatenated product of an integer with (1,2, ... , n) where n > 1? + + +! SOLUTION +! -------- + +! Only need to search 4-digit numbers starting with 9 since a 2-digit number +! starting with 9 would produce 8 or 11 digits, and a 3-digit number starting +! with 9 would produce 7 or 11 digits. + + [ + 2drop 10 swap digits>integer + ] [ + [ * number>digits over push-all ] 2keep 1+ (concat-product) + ] if ; + +: concat-product ( n -- m ) + V{ } clone swap 1 (concat-product) ; + +PRIVATE> + +: euler038 ( -- answer ) + 9123 9876 [a,b] [ concat-product ] map [ pandigital? ] subset supremum ; + +! [ euler038 ] 100 ave-time +! 37 ms run / 1 ms GC ave time - 100 trials + +MAIN: euler038 diff --git a/extra/project-euler/039/039.factor b/extra/project-euler/039/039.factor new file mode 100644 index 0000000000..67578dc5f2 --- /dev/null +++ b/extra/project-euler/039/039.factor @@ -0,0 +1,65 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib kernel math math.ranges namespaces + project-euler.common sequences ; +IN: project-euler.039 + +! http://projecteuler.net/index.php?section=problems&id=39 + +! DESCRIPTION +! ----------- + +! If p is the perimeter of a right angle triangle with integral length sides, +! {a,b,c}, there are exactly three solutions for p = 120. + +! {20,48,52}, {24,45,51}, {30,40,50} + +! For which value of p < 1000, is the number of solutions maximised? + + +! SOLUTION +! -------- + +! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html +! Identical implementation as problem #75 + +! Basically, this makes an array of 1000 zeros, recursively creates primitive +! triples using the three transforms and then increments the array at index +! [a+b+c] by one for each triple's sum AND its multiples under 1000 (to account +! for non-primitive triples). The answer is just the index that has the highest +! number. + +SYMBOL: p-count + + p-count get + [ [ 1+ ] change-nth ] curry each ; + +: (count-perimeters) ( seq -- ) + dup sum max-p < [ + dup sum adjust-p-count + [ u-transform ] keep [ a-transform ] keep d-transform + [ (count-perimeters) ] 3apply + ] [ + drop + ] if ; + +: count-perimeters ( n -- ) + 0 p-count set { 3 4 5 } (count-perimeters) ; + +PRIVATE> + +: euler039 ( -- answer ) + [ + 1000 count-perimeters p-count get [ supremum ] keep index + ] with-scope ; + +! [ euler039 ] 100 ave-time +! 2 ms run / 0 ms GC ave time - 100 trials + +MAIN: euler039 diff --git a/extra/project-euler/040/040.factor b/extra/project-euler/040/040.factor new file mode 100644 index 0000000000..8984559265 --- /dev/null +++ b/extra/project-euler/040/040.factor @@ -0,0 +1,51 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: kernel math math.parser sequences strings ; +IN: project-euler.040 + +! http://projecteuler.net/index.php?section=problems&id=40 + +! DESCRIPTION +! ----------- + +! An irrational decimal fraction is created by concatenating the positive +! integers: + +! 0.123456789101112131415161718192021... + +! It can be seen that the 12th digit of the fractional part is 1. + +! If dn represents the nth digit of the fractional part, find the value of the +! following expression. + +! d1 × d10 × d100 × d1000 × d10000 × d100000 × d1000000 + + +! SOLUTION +! -------- + + [ + pick number>string over push-all rot 1+ -rot (concat-upto) + ] [ + 2nip + ] if ; + +: concat-upto ( n -- str ) + SBUF" " clone 1 -rot (concat-upto) ; + +: nth-integer ( n str -- m ) + [ 1- ] dip nth 1string 10 string>integer ; + +PRIVATE> + +: euler040 ( -- answer ) + 1000000 concat-upto { 1 10 100 1000 10000 100000 1000000 } + [ swap nth-integer ] with map product ; + +! [ euler040 ] 100 ave-time +! 1002 ms run / 43 ms GC ave time - 100 trials + +MAIN: euler040 diff --git a/extra/project-euler/075/075.factor b/extra/project-euler/075/075.factor new file mode 100644 index 0000000000..8399235c0d --- /dev/null +++ b/extra/project-euler/075/075.factor @@ -0,0 +1,78 @@ +! Copyright (c) 2008 Aaron Schaefer. +! See http://factorcode.org/license.txt for BSD license. +USING: arrays combinators.lib kernel math math.ranges namespaces + project-euler.common sequences ; +IN: project-euler.075 + +! http://projecteuler.net/index.php?section=problems&id=75 + +! DESCRIPTION +! ----------- + +! It turns out that 12 cm is the smallest length of wire can be bent to form a +! right angle triangle in exactly one way, but there are many more examples. + +! 12 cm: (3,4,5) +! 24 cm: (6,8,10) +! 30 cm: (5,12,13) +! 36 cm: (9,12,15) +! 40 cm: (8,15,17) +! 48 cm: (12,16,20) + +! In contrast, some lengths of wire, like 20 cm, cannot be bent to form a right +! angle triangle, and other lengths allow more than one solution to be found; +! for example, using 120 cm it is possible to form exactly three different +! right angle triangles. + +! 120 cm: (30,40,50), (20,48,52), (24,45,51) + +! Given that L is the length of the wire, for how many values of L ≤ 1,000,000 +! can exactly one right angle triangle be formed? + + +! SOLUTION +! -------- + +! Algorithm adapted from http://mathworld.wolfram.com/PythagoreanTriple.html +! Identical implementation as problem #39 + +! Basically, this makes an array of 1000000 zeros, recursively creates +! primitive triples using the three transforms and then increments the array at +! index [a+b+c] by one for each triple's sum AND its multiples under 1000000 +! (to account for non-primitive triples). The answer is just the total number +! of indexes that are equal to one. + +SYMBOL: p-count + + p-count get + [ [ 1+ ] change-nth ] curry each ; + +: (count-perimeters) ( seq -- ) + dup sum max-p < [ + dup sum adjust-p-count + [ u-transform ] keep [ a-transform ] keep d-transform + [ (count-perimeters) ] 3apply + ] [ + drop + ] if ; + +: count-perimeters ( n -- ) + 0 p-count set { 3 4 5 } (count-perimeters) ; + +PRIVATE> + +: euler075 ( -- answer ) + [ + 1000000 count-perimeters p-count get [ 1 = ] count + ] with-scope ; + +! [ euler075 ] 100 ave-time +! 1873 ms run / 123 ms GC ave time - 100 trials + +MAIN: euler075 diff --git a/extra/project-euler/common/common.factor b/extra/project-euler/common/common.factor index 2e718ab5a2..50adbe4953 100644 --- a/extra/project-euler/common/common.factor +++ b/extra/project-euler/common/common.factor @@ -1,5 +1,6 @@ USING: arrays combinators.lib kernel math math.functions math.miller-rabin - math.parser math.primes.factors math.ranges namespaces sequences ; + math.matrices math.parser math.primes.factors math.ranges namespaces + sequences sorting ; IN: project-euler.common ! A collection of words used by more than one Project Euler solution @@ -12,9 +13,11 @@ IN: project-euler.common ! log10 - #25, #134 ! max-path - #18, #67 ! number>digits - #16, #20, #30, #34 +! pandigital? - #32, #38 ! propagate-all - #18, #67 ! sum-proper-divisors - #21 ! tau* - #12 +! [uad]-transform - #39, #75 : nth-pair ( n seq -- nth next ) @@ -44,6 +47,9 @@ IN: project-euler.common dup perfect-square? [ sqrt >fixnum neg , ] [ drop ] if ] { } make sum ; +: transform ( triple matrix -- new-triple ) + [ 1array ] dip m. first ; + PRIVATE> : cartesian-product ( seq1 seq2 -- seq1xseq2 ) @@ -67,6 +73,9 @@ PRIVATE> : number>digits ( n -- seq ) number>string string>digits ; +: pandigital? ( n -- ? ) + number>string natural-sort "123456789" = ; + ! Not strictly needed, but it is nice to be able to dump the triangle after the ! propagation : propagate-all ( triangle -- newtriangle ) @@ -97,3 +106,12 @@ PRIVATE> dup sqrt >fixnum [1,b] [ dupd mod zero? [ [ 2 + ] dip ] when ] each drop * ; + +! These transforms are for generating primitive Pythagorean triples +: u-transform ( triple -- new-triple ) + { { 1 2 2 } { -2 -1 -2 } { 2 2 3 } } transform ; +: a-transform ( triple -- new-triple ) + { { 1 2 2 } { 2 1 2 } { 2 2 3 } } transform ; +: d-transform ( triple -- new-triple ) + { { -1 -2 -2 } { 2 1 2 } { 2 2 3 } } transform ; + diff --git a/extra/project-euler/project-euler.factor b/extra/project-euler/project-euler.factor index feef9dbfa8..eb9d7d1300 100644 --- a/extra/project-euler/project-euler.factor +++ b/extra/project-euler/project-euler.factor @@ -1,7 +1,7 @@ ! Copyright (c) 2007, 2008 Aaron Schaefer, Samuel Tardieu. ! See http://factorcode.org/license.txt for BSD license. -USING: definitions io io.files kernel math.parser sequences vocabs - vocabs.loader project-euler.ave-time project-euler.common math +USING: definitions io io.files kernel math math.parser project-euler.ave-time + sequences vocabs vocabs.loader project-euler.001 project-euler.002 project-euler.003 project-euler.004 project-euler.005 project-euler.006 project-euler.007 project-euler.008 project-euler.009 project-euler.010 project-euler.011 project-euler.012 @@ -11,8 +11,9 @@ USING: definitions io io.files kernel math.parser sequences vocabs project-euler.025 project-euler.026 project-euler.027 project-euler.028 project-euler.029 project-euler.030 project-euler.031 project-euler.032 project-euler.033 project-euler.034 project-euler.035 project-euler.036 - project-euler.067 project-euler.134 project-euler.169 project-euler.173 - project-euler.175 ; + project-euler.037 project-euler.038 project-euler.039 project-euler.040 + project-euler.067 project-euler.075 project-euler.134 project-euler.169 + project-euler.173 project-euler.175 ; IN: project-euler : ?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 ; diff --git a/extra/shuffle/shuffle.factor b/extra/shuffle/shuffle.factor index f9f8b030a8..f139a4864e 100644 --- a/extra/shuffle/shuffle.factor +++ b/extra/shuffle/shuffle.factor @@ -30,3 +30,8 @@ MACRO: ntuck ( n -- ) 2 + [ dup , -nrot ] bake ; : 4drop ( a b c d -- ) 3drop drop ; inline : tuckd ( x y z -- z x y z ) 2 ntuck ; inline + +MACRO: nrev ( n -- quot ) + [ 1+ ] map + reverse + [ [ -nrot ] curry ] map concat ; diff --git a/extra/strings/lib/authors.txt b/extra/strings/lib/authors.txt deleted file mode 100755 index 6cfd5da273..0000000000 --- a/extra/strings/lib/authors.txt +++ /dev/null @@ -1 +0,0 @@ -Eduardo Cavazos diff --git a/extra/strings/lib/lib.factor b/extra/strings/lib/lib.factor deleted file mode 100644 index 719881b768..0000000000 --- a/extra/strings/lib/lib.factor +++ /dev/null @@ -1,14 +0,0 @@ -USING: math arrays sequences kernel splitting strings ; -IN: strings.lib - -! : char>digit ( c -- i ) 48 - ; - -! : string>digits ( s -- seq ) [ char>digit ] { } map-as ; - -! : >Upper ( str -- str ) -! dup empty? [ -! unclip ch>upper 1string swap append -! ] unless ; - -! : >Upper-dashes ( str -- str ) -! "-" split [ >Upper ] map "-" join ; diff --git a/extra/strings/lib/tags.txt b/extra/strings/lib/tags.txt deleted file mode 100644 index 42d711b32b..0000000000 --- a/extra/strings/lib/tags.txt +++ /dev/null @@ -1 +0,0 @@ -collections diff --git a/extra/tools/crossref/crossref.factor b/extra/tools/crossref/crossref.factor old mode 100644 new mode 100755 index dfb421c8f8..663df61926 --- a/extra/tools/crossref/crossref.factor +++ b/extra/tools/crossref/crossref.factor @@ -14,8 +14,7 @@ IN: tools.crossref : (method-usage) ( word generic -- methods ) tuck methods - [ second quot-uses key? ] with subset - 0 + [ second uses member? ] with subset keys swap [ 2array ] curry map ; : method-usage ( word seq -- methods ) diff --git a/extra/tools/deploy/backend/backend.factor b/extra/tools/deploy/backend/backend.factor index f2bd03475f..95d19712c0 100755 --- a/extra/tools/deploy/backend/backend.factor +++ b/extra/tools/deploy/backend/backend.factor @@ -16,8 +16,11 @@ IN: tools.deploy.backend : copy-lines ( stream -- ) [ (copy-lines) ] with-disposal ; -: run-with-output ( descriptor -- ) - +: run-with-output ( arguments -- ) + [ + +arguments+ set + +stdout+ +stderr+ set + ] H{ } make-assoc 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 diff --git a/extra/tools/deploy/shaker/shaker.factor b/extra/tools/deploy/shaker/shaker.factor index f2b951ad16..16507232ae 100755 --- a/extra/tools/deploy/shaker/shaker.factor +++ b/extra/tools/deploy/shaker/shaker.factor @@ -8,11 +8,6 @@ debugger io.streams.c io.streams.duplex io.files io.backend quotations words.private tools.deploy.config compiler.units ; IN: tools.deploy.shaker -: show ( msg -- ) - #! Use primitives directly so that we can print stuff even - #! after most of the image has been stripped away - "\r\n" append stdout-handle fwrite stdout-handle fflush ; - : strip-init-hooks ( -- ) "Stripping startup hooks" show "command-line" init-hooks get delete-at diff --git a/extra/ui/freetype/freetype.factor b/extra/ui/freetype/freetype.factor index 0d7522332f..2dade0f58e 100755 --- a/extra/ui/freetype/freetype.factor +++ b/extra/ui/freetype/freetype.factor @@ -36,13 +36,13 @@ M: font hashcode* drop font hashcode* ; : close-freetype ( -- ) global [ - open-fonts [ values [ close-font ] each f ] change + open-fonts [ [ drop close-font ] assoc-each f ] change freetype [ FT_Done_FreeType f ] change ] bind ; M: freetype-renderer free-fonts ( world -- ) dup world-handle select-gl-context - world-fonts values [ second free-sprites ] each ; + world-fonts [ nip second free-sprites ] assoc-each ; : ttf-name ( font style -- name ) 2array H{ @@ -100,7 +100,7 @@ SYMBOL: dpi swap set-font-height ; : ( handle -- font ) - V{ } clone + H{ } clone { set-font-handle set-font-widths } font construct dup init-font ; @@ -119,7 +119,7 @@ M: freetype-renderer open-font ( font -- open-font ) : char-width ( open-font char -- w ) over font-widths [ dupd load-glyph glyph-hori-advance ft-ceil - ] cache-nth nip ; + ] cache nip ; M: freetype-renderer string-width ( open-font string -- w ) 0 -rot [ char-width + ] with each ; @@ -175,7 +175,7 @@ M: freetype-renderer string-height ( open-font string -- h ) [ bitmap>texture ] keep [ init-sprite ] keep ; : draw-char ( open-font char sprites -- ) - [ dupd ] cache-nth nip + [ dupd ] cache nip sprite-dlist glCallList ; : (draw-string) ( open-font sprites string loc -- ) @@ -186,7 +186,7 @@ M: freetype-renderer string-height ( open-font string -- h ) ] do-enabled ; : font-sprites ( open-font world -- pair ) - world-fonts [ open-font V{ } clone 2array ] cache ; + world-fonts [ open-font H{ } clone 2array ] cache ; M: freetype-renderer draw-string ( font string loc -- ) >r >r world get font-sprites first2 r> r> (draw-string) ; diff --git a/extra/ui/windows/windows.factor b/extra/ui/windows/windows.factor index c3ef328b29..c831a959d0 100755 --- a/extra/ui/windows/windows.factor +++ b/extra/ui/windows/windows.factor @@ -6,7 +6,8 @@ math math.vectors namespaces prettyprint sequences strings vectors words windows.kernel32 windows.gdi32 windows.user32 windows.opengl32 windows.messages windows.types windows.nt windows threads timers libc combinators continuations -command-line shuffle opengl ui.render unicode.case ascii ; +command-line shuffle opengl ui.render unicode.case ascii +math.bitfields ; IN: ui.windows TUPLE: windows-ui-backend ; @@ -370,7 +371,7 @@ M: windows-ui-backend (close-window) class-name-ptr get-global pick GetClassInfoEx zero? [ "WNDCLASSEX" heap-size over set-WNDCLASSEX-cbSize - CS_HREDRAW CS_VREDRAW bitor CS_OWNDC bitor over set-WNDCLASSEX-style + { CS_HREDRAW CS_VREDRAW CS_OWNDC } flags over set-WNDCLASSEX-style ui-wndproc over set-WNDCLASSEX-lpfnWndProc 0 over set-WNDCLASSEX-cbClsExtra 0 over set-WNDCLASSEX-cbWndExtra @@ -387,7 +388,7 @@ M: windows-ui-backend (close-window) make-adjusted-RECT >r class-name-ptr get-global f r> >r >r >r ex-style r> r> - WS_CLIPSIBLINGS WS_CLIPCHILDREN bitor style bitor + { WS_CLIPSIBLINGS WS_CLIPCHILDREN style } flags CW_USEDEFAULT dup r> get-RECT-dimensions f f f GetModuleHandle f CreateWindowEx dup win32-error=0/f ; diff --git a/extra/unicode/case/case.factor b/extra/unicode/case/case.factor index ee9e2a0381..8129ec17f8 100755 --- a/extra/unicode/case/case.factor +++ b/extra/unicode/case/case.factor @@ -1,6 +1,6 @@ USING: kernel unicode.data sequences sequences.next namespaces assocs.lib unicode.normalize math unicode.categories combinators -assocs ; +assocs strings splitting ; IN: unicode.case : ch>lower ( ch -- lower ) simple-lower at-default ; diff --git a/extra/unix/linux/ifreq/ifreq.factor b/extra/unix/linux/ifreq/ifreq.factor old mode 100644 new mode 100755 index c75ee9a5e4..31adc5c237 --- a/extra/unix/linux/ifreq/ifreq.factor +++ b/extra/unix/linux/ifreq/ifreq.factor @@ -58,10 +58,4 @@ IN: unix.linux.ifreq rot string>char-alien over set-struct-ifreq-ifr-ifrn swap over set-struct-ifreq-ifr-ifru - AF_INET SOCK_DGRAM 0 socket SIOCSIFMETRIC rot ioctl drop ; - -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -USING: words quotations sequences math macros ; - -MACRO: flags ( seq -- ) 0 swap [ execute bitor ] each 1quotation ; \ No newline at end of file + AF_INET SOCK_DGRAM 0 socket SIOCSIFMETRIC rot ioctl drop ; \ No newline at end of file diff --git a/extra/unix/linux/inotify/inotify.factor b/extra/unix/linux/inotify/inotify.factor new file mode 100644 index 0000000000..b7b721efc7 --- /dev/null +++ b/extra/unix/linux/inotify/inotify.factor @@ -0,0 +1,57 @@ +! Copyright (C) 2008 Slava Pestov. +! See http://factorcode.org/license.txt for BSD license. +USING: alien.syntax math math.bitfields ; +IN: unix.linux.inotify + +C-STRUCT: inotify-event + { "int" "wd" } ! watch descriptor + { "uint" "mask" } ! watch mask + { "uint" "cookie" } ! cookie to synchronize two events + { "uint" "len" } ! length (including nulls) of name + { "char[0]" "name" } ! stub for possible name + ; + +: IN_ACCESS HEX: 1 ; inline ! File was accessed +: IN_MODIFY HEX: 2 ; inline ! File was modified +: IN_ATTRIB HEX: 4 ; inline ! Metadata changed +: IN_CLOSE_WRITE HEX: 8 ; inline ! Writtable file was closed +: IN_CLOSE_NOWRITE HEX: 10 ; inline ! Unwrittable file closed +: IN_OPEN HEX: 20 ; inline ! File was opened +: IN_MOVED_FROM HEX: 40 ; inline ! File was moved from X +: IN_MOVED_TO HEX: 80 ; inline ! File was moved to Y +: IN_CREATE HEX: 100 ; inline ! Subfile was created +: IN_DELETE HEX: 200 ; inline ! Subfile was deleted +: IN_DELETE_SELF HEX: 400 ; inline ! Self was deleted +: IN_MOVE_SELF HEX: 800 ; inline ! Self was moved + +: IN_UNMOUNT HEX: 2000 ; inline ! Backing fs was unmounted +: IN_Q_OVERFLOW HEX: 4000 ; inline ! Event queued overflowed +: IN_IGNORED HEX: 8000 ; inline ! File was ignored + +: IN_CLOSE IN_CLOSE_WRITE IN_CLOSE_NOWRITE bitor ; inline ! close +: IN_MOVE IN_MOVED_FROM IN_MOVED_TO bitor ; inline ! moves + +: IN_ONLYDIR HEX: 1000000 ; inline ! only watch the path if it is a directory +: IN_DONT_FOLLOW HEX: 2000000 ; inline ! don't follow a sym link +: IN_MASK_ADD HEX: 20000000 ; inline ! add to the mask of an already existing watch +: IN_ISDIR HEX: 40000000 ; inline ! event occurred against dir +: IN_ONESHOT HEX: 80000000 ; inline ! only send event once + +: IN_CHANGE_EVENTS + { + IN_MODIFY IN_ATTRIB IN_MOVED_FROM + IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF + IN_MOVE_SELF + } flags ; foldable + +: IN_ALL_EVENTS + { + IN_ACCESS IN_MODIFY IN_ATTRIB IN_CLOSE_WRITE + IN_CLOSE_NOWRITE IN_OPEN IN_MOVED_FROM + IN_MOVED_TO IN_DELETE IN_CREATE IN_DELETE_SELF + IN_MOVE_SELF + } flags ; foldable + +FUNCTION: int inotify_init ( ) ; +FUNCTION: int inotify_add_watch ( int fd, char* name, uint mask ) ; +FUNCTION: int inotify_rm_watch ( int fd, uint wd ) ; diff --git a/extra/unix/linux/linux.factor b/extra/unix/linux/linux.factor index d25ff71d65..0a3eb7ee5f 100644 --- a/extra/unix/linux/linux.factor +++ b/extra/unix/linux/linux.factor @@ -1,10 +1,8 @@ -! Copyright (C) 2005 Slava Pestov. +! Copyright (C) 2005, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. IN: unix USING: alien.syntax ; -TYPEDEF: ulong off_t - ! Linux. : O_RDONLY HEX: 0000 ; inline diff --git a/extra/unix/process/process.factor b/extra/unix/process/process.factor index fb4271ea23..8b7144b979 100755 --- a/extra/unix/process/process.factor +++ b/extra/unix/process/process.factor @@ -32,4 +32,4 @@ IN: unix.process fork dup zero? -roll swap curry if ; inline : wait-for-pid ( pid -- status ) - 0 [ 0 waitpid drop ] keep *int ; \ No newline at end of file + 0 [ 0 waitpid drop ] keep *int WEXITSTATUS ; \ No newline at end of file diff --git a/extra/unix/solaris/solaris.factor b/extra/unix/solaris/solaris.factor index b4aa8285eb..2bca20c6b6 100644 --- a/extra/unix/solaris/solaris.factor +++ b/extra/unix/solaris/solaris.factor @@ -3,8 +3,6 @@ IN: unix USING: alien.syntax system kernel ; -TYPEDEF: ulong off_t - ! Solaris. : O_RDONLY HEX: 0000 ; inline diff --git a/extra/unix/unix.factor b/extra/unix/unix.factor index f5c484568e..750a4b5044 100755 --- a/extra/unix/unix.factor +++ b/extra/unix/unix.factor @@ -19,11 +19,13 @@ TYPEDEF: uint time_t TYPEDEF: uint uid_t TYPEDEF: ulong size_t TYPEDEF: ulong u_long -TYPEDEF: ulonglong off_t TYPEDEF: ushort mode_t TYPEDEF: ushort nlink_t TYPEDEF: void* caddr_t +TYPEDEF: ulong off_t +TYPEDEF-IF: bsd? ulonglong off_t + C-STRUCT: tm { "int" "sec" } ! Seconds: 0-59 (K&R says 0-61?) { "int" "min" } ! Minutes: 0-59 @@ -168,37 +170,46 @@ FUNCTION: time_t time ( time_t* t ) ; FUNCTION: int unlink ( char* path ) ; FUNCTION: int utimes ( char* path, timeval[2] times ) ; -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! wait and waitpid -! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +: SIGKILL 9 ; inline +: SIGTERM 15 ; inline + +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 ) ; diff --git a/extra/windows/advapi32/advapi32.factor b/extra/windows/advapi32/advapi32.factor old mode 100644 new mode 100755 index fd2a9fb8af..d3413b5695 --- a/extra/windows/advapi32/advapi32.factor +++ b/extra/windows/advapi32/advapi32.factor @@ -1,4 +1,4 @@ -USING: alien.syntax kernel math windows.types ; +USING: alien.syntax kernel math windows.types math.bitfields ; IN: windows.advapi32 LIBRARY: advapi32 @@ -483,20 +483,28 @@ FUNCTION: BOOL LookupPrivilegeValueW ( LPCTSTR lpSystemName, : TOKEN_QUERY_SOURCE HEX: 0010 ; inline : TOKEN_ADJUST_DEFAULT HEX: 0080 ; inline : TOKEN_READ STANDARD_RIGHTS_READ TOKEN_QUERY bitor ; -: TOKEN_WRITE STANDARD_RIGHTS_WRITE - TOKEN_ADJUST_PRIVILEGES bitor - TOKEN_ADJUST_GROUPS bitor - TOKEN_ADJUST_DEFAULT bitor ; foldable -: TOKEN_ALL_ACCESS STANDARD_RIGHTS_REQUIRED - TOKEN_ASSIGN_PRIMARY bitor - TOKEN_DUPLICATE bitor - TOKEN_IMPERSONATE bitor - TOKEN_QUERY bitor - TOKEN_QUERY_SOURCE bitor - TOKEN_ADJUST_PRIVILEGES bitor - TOKEN_ADJUST_GROUPS bitor - TOKEN_ADJUST_SESSIONID bitor - TOKEN_ADJUST_DEFAULT bitor ; foldable + +: TOKEN_WRITE + { + STANDARD_RIGHTS_WRITE + TOKEN_ADJUST_PRIVILEGES + TOKEN_ADJUST_GROUPS + TOKEN_ADJUST_DEFAULT + } flags ; foldable + +: TOKEN_ALL_ACCESS + { + STANDARD_RIGHTS_REQUIRED + TOKEN_ASSIGN_PRIMARY + TOKEN_DUPLICATE + TOKEN_IMPERSONATE + TOKEN_QUERY + TOKEN_QUERY_SOURCE + TOKEN_ADJUST_PRIVILEGES + TOKEN_ADJUST_GROUPS + TOKEN_ADJUST_SESSIONID + TOKEN_ADJUST_DEFAULT + } flags ; foldable FUNCTION: BOOL OpenProcessToken ( HANDLE ProcessHandle, DWORD DesiredAccess, diff --git a/extra/windows/kernel32/kernel32.factor b/extra/windows/kernel32/kernel32.factor index 77c7666bfd..45bd6bfae9 100755 --- a/extra/windows/kernel32/kernel32.factor +++ b/extra/windows/kernel32/kernel32.factor @@ -707,7 +707,19 @@ FUNCTION: BOOL DeleteFileW ( LPCTSTR lpFileName ) ; ! FUNCTION: DosPathToSessionPathA ! FUNCTION: DosPathToSessionPathW ! FUNCTION: DuplicateConsoleHandle -! FUNCTION: DuplicateHandle + +FUNCTION: BOOL DuplicateHandle ( + HANDLE hSourceProcessHandle, + HANDLE hSourceHandle, + HANDLE hTargetProcessHandle, + LPHANDLE lpTargetHandle, + DWORD dwDesiredAccess, + BOOL bInheritHandle, + DWORD dwOptions ) ; + +: DUPLICATE_CLOSE_SOURCE 1 ; +: DUPLICATE_SAME_ACCESS 2 ; + ! FUNCTION: EncodePointer ! FUNCTION: EncodeSystemPointer ! FUNCTION: EndUpdateResourceA @@ -1453,7 +1465,7 @@ FUNCTION: DWORD SleepEx ( DWORD dwMilliSeconds, BOOL bAlertable ) ; FUNCTION: BOOL SystemTimeToFileTime ( SYSTEMTIME* lpSystemTime, LPFILETIME lpFileTime ) ; ! FUNCTION: SystemTimeToTzSpecificLocalTime ! FUNCTION: TerminateJobObject -! FUNCTION: TerminateProcess +FUNCTION: BOOL TerminateProcess ( HANDLE hProcess, DWORD uExit ) ; ! FUNCTION: TerminateThread ! FUNCTION: TermsrvAppInstallMode ! FUNCTION: Thread32First diff --git a/extra/windows/opengl32/opengl32.factor b/extra/windows/opengl32/opengl32.factor index a8d8ad8153..c38579c95e 100755 --- a/extra/windows/opengl32/opengl32.factor +++ b/extra/windows/opengl32/opengl32.factor @@ -1,7 +1,8 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.c-types alien.syntax parser namespaces kernel -math windows.types windows.types init assocs sequences libc ; +math math.bitfields windows.types windows.types init assocs +sequences libc ; IN: windows.opengl32 ! PIXELFORMATDESCRIPTOR flags @@ -70,10 +71,8 @@ IN: windows.opengl32 : WGL_SWAP_UNDERLAY14 HEX: 20000000 ; inline : WGL_SWAP_UNDERLAY15 HEX: 40000000 ; inline - - : pfd-dwFlags - PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL bitor PFD_DOUBLEBUFFER bitor ; + { PFD_DRAW_TO_WINDOW PFD_SUPPORT_OPENGL PFD_DOUBLEBUFFER } flags ; ! TODO: compare to http://www.nullterminator.net/opengl32.html : make-pfd ( bits -- pfd ) diff --git a/extra/windows/user32/user32.factor b/extra/windows/user32/user32.factor old mode 100644 new mode 100755 index c8f6a82fb5..39879bf91d --- a/extra/windows/user32/user32.factor +++ b/extra/windows/user32/user32.factor @@ -1,7 +1,7 @@ ! Copyright (C) 2005, 2006 Doug Coleman. ! See http://factorcode.org/license.txt for BSD license. USING: alien alien.syntax parser namespaces kernel math -windows.types shuffle ; +windows.types shuffle math.bitfields ; IN: windows.user32 ! HKL for ActivateKeyboardLayout @@ -32,9 +32,18 @@ IN: windows.user32 : WS_MAXIMIZEBOX HEX: 00010000 ; inline ! Common window styles -: WS_OVERLAPPEDWINDOW WS_OVERLAPPED WS_CAPTION WS_SYSMENU WS_THICKFRAME WS_MINIMIZEBOX WS_MAXIMIZEBOX bitor bitor bitor bitor bitor ; foldable inline +: WS_OVERLAPPEDWINDOW + { + WS_OVERLAPPED + WS_CAPTION + WS_SYSMENU + WS_THICKFRAME + WS_MINIMIZEBOX + WS_MAXIMIZEBOX + } flags ; foldable -: WS_POPUPWINDOW WS_POPUP WS_BORDER WS_SYSMENU bitor bitor ; foldable inline +: WS_POPUPWINDOW + { WS_POPUP WS_BORDER WS_SYSMENU } flags ; foldable : WS_CHILDWINDOW WS_CHILD ; inline @@ -66,10 +75,9 @@ IN: windows.user32 : WS_EX_STATICEDGE HEX: 00020000 ; inline : WS_EX_APPWINDOW HEX: 00040000 ; inline : WS_EX_OVERLAPPEDWINDOW ( -- n ) - WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable inline + WS_EX_WINDOWEDGE WS_EX_CLIENTEDGE bitor ; foldable : WS_EX_PALETTEWINDOW ( -- n ) - WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW bitor - WS_EX_TOPMOST bitor ; foldable inline + { WS_EX_WINDOWEDGE WS_EX_TOOLWINDOW WS_EX_TOPMOST } flags ; foldable : CS_VREDRAW HEX: 0001 ; inline : CS_HREDRAW HEX: 0002 ; inline diff --git a/extra/windows/winsock/winsock.factor b/extra/windows/winsock/winsock.factor index ffab6786b5..cc19cdc2a3 100755 --- a/extra/windows/winsock/winsock.factor +++ b/extra/windows/winsock/winsock.factor @@ -1,8 +1,8 @@ ! Copyright (C) 2006 Mackenzie Straight, Doug Coleman. -USING: alien alien.c-types alien.syntax arrays byte-arrays kernel -math sequences windows.types windows.kernel32 windows.errors structs -windows ; +USING: alien alien.c-types alien.syntax arrays byte-arrays +kernel math sequences windows.types windows.kernel32 +windows.errors structs windows math.bitfields ; IN: windows.winsock USE: libc @@ -74,7 +74,7 @@ TYPEDEF: void* SOCKET : AI_PASSIVE 1 ; inline : AI_CANONNAME 2 ; inline : AI_NUMERICHOST 4 ; inline -: AI_MASK AI_PASSIVE AI_CANONNAME bitor AI_NUMERICHOST bitor ; +: AI_MASK { AI_PASSIVE AI_CANONNAME AI_NUMERICHOST } flags ; : NI_NUMERICHOST 1 ; : NI_NUMERICSERV 2 ; diff --git a/extra/x/widgets/wm/frame/frame.factor b/extra/x/widgets/wm/frame/frame.factor old mode 100644 new mode 100755 index ecf628b9c7..4e3b4e7c93 --- a/extra/x/widgets/wm/frame/frame.factor +++ b/extra/x/widgets/wm/frame/frame.factor @@ -21,14 +21,16 @@ SYMBOL: swap new* >>child new* "white" <-- set-foreground >>gc - SubstructureRedirectMask - ExposureMask bitor - ButtonPressMask bitor - ButtonReleaseMask bitor - ButtonMotionMask bitor - EnterWindowMask bitor - ! experimental masks - SubstructureNotifyMask bitor + { + SubstructureRedirectMask + ExposureMask + ButtonPressMask + ButtonReleaseMask + ButtonMotionMask + EnterWindowMask + ! experimental masks + SubstructureNotifyMask + } flags >>mask <- init-widget diff --git a/extra/x11/windows/windows.factor b/extra/x11/windows/windows.factor old mode 100644 new mode 100755 index 94695720ea..f9158c2956 --- a/extra/x11/windows/windows.factor +++ b/extra/x11/windows/windows.factor @@ -1,29 +1,30 @@ ! 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 : create-window-mask ( -- n ) - CWBackPixel CWBorderPixel bitor - CWColormap bitor CWEventMask bitor ; + { CWBackPixel CWBorderPixel CWColormap CWEventMask } flags ; : create-colormap ( visinfo -- colormap ) dpy get root get rot XVisualInfo-visual AllocNone XCreateColormap ; : event-mask ( -- n ) - ExposureMask - StructureNotifyMask bitor - KeyPressMask bitor - KeyReleaseMask bitor - ButtonPressMask bitor - ButtonReleaseMask bitor - PointerMotionMask bitor - FocusChangeMask bitor - EnterWindowMask bitor - LeaveWindowMask bitor - PropertyChangeMask bitor ; + { + ExposureMask + StructureNotifyMask + KeyPressMask + KeyReleaseMask + ButtonPressMask + ButtonReleaseMask + PointerMotionMask + FocusChangeMask + EnterWindowMask + LeaveWindowMask + PropertyChangeMask + } flags ; : window-attributes ( visinfo -- attributes ) "XSetWindowAttributes" diff --git a/extra/x11/xim/xim.factor b/extra/x11/xim/xim.factor old mode 100644 new mode 100755 diff --git a/extra/x11/xlib/xlib.factor b/extra/x11/xlib/xlib.factor old mode 100644 new mode 100755 index 8dd8a55acc..70006c9f64 --- a/extra/x11/xlib/xlib.factor +++ b/extra/x11/xlib/xlib.factor @@ -12,7 +12,7 @@ ! and note the section. USING: kernel arrays alien alien.c-types alien.syntax -math words sequences namespaces continuations ; +math math.bitfields words sequences namespaces continuations ; IN: x11.xlib LIBRARY: xlib @@ -1088,8 +1088,8 @@ FUNCTION: Status XWithdrawWindow ( : PAspect 1 7 shift ; inline : PBaseSize 1 8 shift ; inline : PWinGravity 1 9 shift ; inline -: PAllHints [ PPosition PSize PMinSize PMaxSize PResizeInc PAspect ] -0 [ execute bitor ] reduce ; inline +: PAllHints + { PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable C-STRUCT: XSizeHints { "long" "flags" } diff --git a/misc/Factor.tmbundle/Support/lib/tm_factor.rb b/misc/Factor.tmbundle/Support/lib/tm_factor.rb index 54272e5e36..2775a12ae9 100644 --- a/misc/Factor.tmbundle/Support/lib/tm_factor.rb +++ b/misc/Factor.tmbundle/Support/lib/tm_factor.rb @@ -33,6 +33,6 @@ def doc_using_statements(document) end def line_current_word(line, point) - left = line.rindex(/\s|^/, point - 1) + 1; right = line.index(/\s|$/, point) - 1 + left = line.rindex(/\s/, point - 1) || 0; right = line.index(/\s/, point) || line.length line[left..right] end diff --git a/misc/factor.sh b/misc/factor.sh index 39a15f93dc..032b0b3184 100755 --- a/misc/factor.sh +++ b/misc/factor.sh @@ -289,7 +289,7 @@ install_libraries() { } usage() { - echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap" + echo "usage: $0 install|install-x11|self-update|quick-update|update|bootstrap|wget-bootstrap" } case "$1" in @@ -299,5 +299,6 @@ case "$1" in quick-update) update; refresh_image ;; update) update; update_bootstrap ;; bootstrap) get_config_info; bootstrap ;; + wget-bootstrap) get_config_info; delete_boot_images; get_boot_image; bootstrap ;; *) usage ;; esac diff --git a/vm/ffi_test.c b/vm/ffi_test.c old mode 100644 new mode 100755 index f6e70fd6ac..9cec5ccbad --- a/vm/ffi_test.c +++ b/vm/ffi_test.c @@ -245,3 +245,8 @@ double ffi_test_35(struct test_struct_11 x, int y) { return (x.x + x.y) * y; } + +double ffi_test_36(struct test_struct_12 x) +{ + return x.x; +} diff --git a/vm/ffi_test.h b/vm/ffi_test.h old mode 100644 new mode 100755 index 27e402b74f..aac5d32f93 --- a/vm/ffi_test.h +++ b/vm/ffi_test.h @@ -57,3 +57,7 @@ struct test_struct_10 { float x; int y; }; DLLEXPORT double ffi_test_34(struct test_struct_10 x, int y); struct test_struct_11 { int x; int y; }; DLLEXPORT double ffi_test_35(struct test_struct_11 x, int y); + +struct test_struct_12 { int a; double x; }; + +DLLEXPORT double ffi_test_36(struct test_struct_12 x); diff --git a/vm/os-genunix.c b/vm/os-genunix.c old mode 100644 new mode 100755 index 92598eec41..f582483ce7 --- a/vm/os-genunix.c +++ b/vm/os-genunix.c @@ -13,6 +13,7 @@ void init_signals(void) void early_init(void) { } #define SUFFIX ".image" +#define SUFFIX_LEN 6 const char *default_image_path(void) { @@ -21,7 +22,14 @@ const char *default_image_path(void) if(!path) return "factor.image"; - char *new_path = safe_realloc(path,PATH_MAX + strlen(SUFFIX) + 1); - strcat(new_path,SUFFIX); + /* We can't call strlen() here because with gcc 4.1.2 this + causes an internal compiler error. */ + int len = 0; + const char *iter = path; + while(*iter) { len++; iter++; } + + char *new_path = safe_malloc(PATH_MAX + SUFFIX_LEN + 1); + memcpy(new_path,path,len + 1); + memcpy(new_path + len,SUFFIX,SUFFIX_LEN + 1); return new_path; } diff --git a/vm/os-linux.c b/vm/os-linux.c index 8f3f8408f3..935add6714 100644 --- a/vm/os-linux.c +++ b/vm/os-linux.c @@ -17,3 +17,18 @@ const char *vm_executable_path(void) return safe_strdup(path); } } + +int inotify_init(void) +{ + return syscall(SYS_inotify_init); +} + +int inotify_add_watch(int fd, const char *name, u32 mask) +{ + return syscall(SYS_inotify_add_watch, fd, name, mask); +} + +int inotify_rm_watch(int fd, u32 wd) +{ + return syscall(SYS_inotify_rm_watch, fd, wd); +} diff --git a/vm/os-linux.h b/vm/os-linux.h index 21e34c98f8..1a1e088359 100644 --- a/vm/os-linux.h +++ b/vm/os-linux.h @@ -1,6 +1,12 @@ +#include + #define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN) #define DIRECTORY_P(file) ((file)->d_type == DT_DIR) #ifndef environ extern char **environ; #endif + +int inotify_init(void); +int inotify_add_watch(int fd, const char *name, u32 mask); +int inotify_rm_watch(int fd, u32 wd); diff --git a/vm/types.c b/vm/types.c index 24b5e7ff07..78e74535b8 100755 --- a/vm/types.c +++ b/vm/types.c @@ -463,16 +463,10 @@ F_STRING* allot_string_internal(CELL capacity) { F_STRING *string = allot_object(STRING_TYPE,string_size(capacity)); - /* strings are null-terminated in memory, even though they also - have a length field. The null termination allows us to add - the sizeof(F_STRING) to a Factor string to get a C-style - char* string for C library calls. */ string->length = tag_fixnum(capacity); string->hashcode = F; string->aux = F; - set_string_nth(string,capacity,0); - return string; } @@ -645,14 +639,7 @@ F_BYTE_ARRAY *allot_c_string(CELL capacity, CELL size) } \ type *to_##type##_string(F_STRING *s, bool check) \ { \ - if(sizeof(type) == sizeof(char)) \ - { \ - if(check && !check_string(s,sizeof(type))) \ - general_error(ERROR_C_STRING,tag_object(s),F,NULL); \ - return (type*)(s + 1); \ - } \ - else \ - return (type*)(string_to_##type##_alien(s,check) + 1); \ + return (type*)(string_to_##type##_alien(s,check) + 1); \ } \ type *unbox_##type##_string(void) \ { \ diff --git a/vm/types.h b/vm/types.h index e5003ea069..62b2e06dd0 100755 --- a/vm/types.h +++ b/vm/types.h @@ -11,7 +11,7 @@ INLINE CELL string_capacity(F_STRING* str) INLINE CELL string_size(CELL size) { - return sizeof(F_STRING) + size + 1; + return sizeof(F_STRING) + size; } DEFINE_UNTAG(F_BYTE_ARRAY,BYTE_ARRAY_TYPE,byte_array) diff --git a/vm/utilities.c b/vm/utilities.c old mode 100644 new mode 100755 index 60a4ecb268..ebc8e87977 --- a/vm/utilities.c +++ b/vm/utilities.c @@ -8,13 +8,6 @@ void *safe_malloc(size_t size) return ptr; } -void *safe_realloc(const void *ptr, size_t size) -{ - void *new_ptr = realloc((void *)ptr,size); - if(!new_ptr) fatal_error("Out of memory in safe_realloc", 0); - return new_ptr; -} - F_CHAR *safe_strdup(const F_CHAR *str) { F_CHAR *ptr = STRDUP(str); diff --git a/vm/utilities.h b/vm/utilities.h old mode 100644 new mode 100755 index 483e395345..89a8ba57a3 --- a/vm/utilities.h +++ b/vm/utilities.h @@ -1,3 +1,2 @@ void *safe_malloc(size_t size); -void *safe_realloc(const void *ptr, size_t size); F_CHAR *safe_strdup(const F_CHAR *str);