Merge git://factorcode.org/git/factor
commit
d80b707c43
|
@ -1,9 +1,10 @@
|
|||
! Copyright (C) 2004, 2007 Slava Pestov.
|
||||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: byte-arrays float-arrays arrays generator.registers assocs
|
||||
kernel kernel.private libc math namespaces parser sequences
|
||||
strings words assocs splitting math.parser cpu.architecture
|
||||
alien alien.accessors quotations system compiler.units ;
|
||||
USING: bit-arrays byte-arrays float-arrays arrays
|
||||
generator.registers assocs kernel kernel.private libc math
|
||||
namespaces parser sequences strings words assocs splitting
|
||||
math.parser cpu.architecture alien alien.accessors quotations
|
||||
system compiler.units ;
|
||||
IN: alien.c-types
|
||||
|
||||
TUPLE: c-type
|
||||
|
@ -109,10 +110,12 @@ M: c-type stack-size c-type-size ;
|
|||
|
||||
GENERIC: byte-length ( seq -- n ) flushable
|
||||
|
||||
M: float-array byte-length length "double" heap-size * ;
|
||||
M: bit-array byte-length length 7 + -3 shift ;
|
||||
|
||||
M: byte-array byte-length length ;
|
||||
|
||||
M: float-array byte-length length "double" heap-size * ;
|
||||
|
||||
: c-getter ( name -- quot )
|
||||
c-type c-type-getter [
|
||||
[ "Cannot read struct fields with type" throw ]
|
||||
|
|
|
@ -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 '
|
||||
|
|
|
@ -118,11 +118,11 @@ H{ } clone update-map set
|
|||
H{ } clone typemap set
|
||||
num-types get f <array> builtins set
|
||||
|
||||
! These symbols are needed by the code that executes below
|
||||
{
|
||||
{ "object" "kernel" }
|
||||
{ "null" "kernel" }
|
||||
} [ create drop ] assoc-each
|
||||
! Forward definitions
|
||||
"object" "kernel" create t "class" set-word-prop
|
||||
"object" "kernel" create union-class "metaclass" set-word-prop
|
||||
|
||||
"null" "kernel" create drop
|
||||
|
||||
"fixnum" "math" create "fixnum?" "math" create { } define-builtin
|
||||
"fixnum" "math" create ">fixnum" "math" create 1quotation "coercer" set-word-prop
|
||||
|
|
|
@ -32,6 +32,7 @@ vocabs.loader system ;
|
|||
|
||||
"io.streams.c" require
|
||||
"vocabs.loader" require
|
||||
|
||||
"syntax" require
|
||||
"bootstrap.layouts" require
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -26,7 +26,7 @@ IN: compiler
|
|||
>r dupd save-effect r>
|
||||
f pick compiler-error
|
||||
over compiled-unxref
|
||||
over word-vocabulary [ compiled-xref ] [ 2drop ] if ;
|
||||
compiled-xref ;
|
||||
|
||||
: compile-succeeded ( word -- effect dependencies )
|
||||
[
|
||||
|
|
|
@ -270,6 +270,16 @@ FUNCTION: double ffi_test_35 test-struct-11 x int y ;
|
|||
3 ffi_test_35
|
||||
] unit-test
|
||||
|
||||
C-STRUCT: test-struct-12 { "int" "a" } { "double" "x" } ;
|
||||
|
||||
: make-struct-12
|
||||
"test-struct-12" <c-object>
|
||||
[ set-test-struct-12-x ] keep ;
|
||||
|
||||
FUNCTION: double ffi_test_36 ( test-struct-12 x ) ;
|
||||
|
||||
[ 1.23456 ] [ 1.23456 make-struct-12 ffi_test_36 ] unit-test
|
||||
|
||||
! Test callbacks
|
||||
|
||||
: callback-1 "void" { } "cdecl" [ ] alien-callback ;
|
||||
|
|
|
@ -11,7 +11,7 @@ SYMBOL: generic-1
|
|||
[
|
||||
generic-1 T{ combination-1 } define-generic
|
||||
|
||||
[ ] <method> object \ generic-1 define-method
|
||||
[ ] object \ generic-1 define-method
|
||||
] with-compilation-unit
|
||||
|
||||
[ ] [
|
||||
|
|
|
@ -42,12 +42,16 @@ M: integer (stack-picture) drop "object" ;
|
|||
] "" make ;
|
||||
|
||||
: stack-effect ( word -- effect/f )
|
||||
dup symbol? [
|
||||
drop 0 1 <effect>
|
||||
] [
|
||||
{ "declared-effect" "inferred-effect" }
|
||||
swap word-props [ at ] curry map [ ] find nip
|
||||
] if ;
|
||||
{
|
||||
{ [ dup symbol? ] [ drop 0 1 <effect> ] }
|
||||
{ [ dup "parent-generic" word-prop ] [
|
||||
"parent-generic" word-prop stack-effect
|
||||
] }
|
||||
{ [ t ] [
|
||||
{ "declared-effect" "inferred-effect" }
|
||||
swap word-props [ at ] curry map [ ] find nip
|
||||
] }
|
||||
} cond ;
|
||||
|
||||
M: effect clone
|
||||
[ effect-in clone ] keep effect-out clone <effect> ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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"
|
||||
|
@ -125,16 +125,12 @@ HELP: method
|
|||
{ $description "Looks up a method definition." }
|
||||
{ $class-description "Instances of this class are methods. A method consists of a quotation together with a source location where it was defined." } ;
|
||||
|
||||
{ method method-def method-loc define-method POSTPONE: M: } related-words
|
||||
{ method define-method POSTPONE: M: } related-words
|
||||
|
||||
HELP: <method>
|
||||
{ $values { "def" "a quotation" } { "method" "a new method definition" } }
|
||||
{ $description "Creates a new "{ $link method } " instance." } ;
|
||||
|
||||
HELP: sort-methods
|
||||
{ $values { "assoc" "an assoc mapping classes to methods" } { "newassoc" "an association list mapping classes to quotations" } }
|
||||
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
|
||||
|
||||
HELP: methods
|
||||
{ $values { "word" generic } { "assoc" "an association list mapping classes to quotations" } }
|
||||
{ $description "Outputs a sequence of pairs, where the first element of each pair is a class and the second element is the corresponding method quotation. The methods are sorted by class order; see " { $link sort-classes } "." } ;
|
||||
|
@ -154,7 +150,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
|
||||
|
|
|
@ -5,12 +5,7 @@ definitions kernel.private classes classes.private
|
|||
quotations arrays vocabs ;
|
||||
IN: generic
|
||||
|
||||
PREDICATE: word generic "combination" word-prop >boolean ;
|
||||
|
||||
M: generic definer drop f f ;
|
||||
|
||||
M: generic definition drop f ;
|
||||
|
||||
! Method combination protocol
|
||||
GENERIC: perform-combination ( word combination -- quot )
|
||||
|
||||
M: object perform-combination
|
||||
|
@ -22,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 ;
|
||||
|
||||
: <method> ( 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,41 @@ 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 ;
|
||||
|
||||
: <method-word> ( quot class generic -- word )
|
||||
[ make-method-def ] 2keep
|
||||
[ method-word-name f <word> dup ] keep
|
||||
"parent-generic" set-word-prop
|
||||
dup rot define ;
|
||||
|
||||
: <method> ( quot class generic -- method )
|
||||
check-method
|
||||
[ <method-word> ] 3keep f \ method construct-boa ;
|
||||
|
||||
: define-method ( quot class generic -- )
|
||||
>r bootstrap-word r>
|
||||
[ <method> ] 2keep
|
||||
[ set-at ] with-methods ;
|
||||
|
||||
: define-default-method ( generic combination -- )
|
||||
dupd make-default-method object bootstrap-word pick <method>
|
||||
"default-method" set-word-prop ;
|
||||
|
||||
! Definition protocol
|
||||
M: method-spec where
|
||||
dup first2 method method-loc [ ] [ second where ] ?if ;
|
||||
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 +119,14 @@ M: class forget* ( class -- )
|
|||
|
||||
M: assoc update-methods ( assoc -- )
|
||||
implementors* [ make-generic ] each ;
|
||||
|
||||
: init-methods ( word -- )
|
||||
dup "methods" word-prop
|
||||
H{ } assoc-like
|
||||
"methods" set-word-prop ;
|
||||
|
||||
: define-generic ( word combination -- )
|
||||
2dup "combination" set-word-prop
|
||||
dupd define-default-method
|
||||
dup init-methods
|
||||
make-generic ;
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -8,6 +8,10 @@ IN: generic.standard
|
|||
|
||||
TUPLE: standard-combination # ;
|
||||
|
||||
M: standard-combination method-prologue
|
||||
standard-combination-# object
|
||||
<array> swap add [ declare ] curry ;
|
||||
|
||||
C: <standard-combination> standard-combination
|
||||
|
||||
SYMBOL: (dispatch#)
|
||||
|
@ -31,10 +35,10 @@ TUPLE: no-method object generic ;
|
|||
: no-method ( object generic -- * )
|
||||
\ no-method construct-boa throw ;
|
||||
|
||||
: error-method ( word -- method )
|
||||
: error-method ( word -- quot )
|
||||
picker swap [ no-method ] curry append ;
|
||||
|
||||
: empty-method ( word -- method )
|
||||
: empty-method ( word -- quot )
|
||||
[
|
||||
picker % [ delegate dup ] %
|
||||
unpicker over add ,
|
||||
|
@ -65,13 +69,15 @@ TUPLE: no-method object generic ;
|
|||
] if ;
|
||||
|
||||
: default-method ( word -- pair )
|
||||
empty-method object bootstrap-word swap 2array ;
|
||||
"default-method" word-prop method-word
|
||||
object bootstrap-word swap 2array ;
|
||||
|
||||
: method-alist>quot ( alist base-class -- quot )
|
||||
bootstrap-word swap simplify-alist
|
||||
class-predicates alist>quot ;
|
||||
|
||||
: small-generic ( methods -- def )
|
||||
[ 1quotation ] assoc-map
|
||||
object method-alist>quot ;
|
||||
|
||||
: hash-methods ( methods -- buckets )
|
||||
|
@ -83,9 +89,12 @@ TUPLE: no-method object generic ;
|
|||
] if
|
||||
] distribute-buckets ;
|
||||
|
||||
: class-hash-dispatch-quot ( methods quot picker -- quot )
|
||||
>r >r hash-methods r> map
|
||||
hash-dispatch-quot r> [ class-hash ] rot 3append ;
|
||||
|
||||
: big-generic ( methods -- quot )
|
||||
hash-methods [ small-generic ] map
|
||||
hash-dispatch-quot picker [ class-hash ] rot 3append ;
|
||||
[ small-generic ] picker class-hash-dispatch-quot ;
|
||||
|
||||
: vtable-class ( n -- class )
|
||||
type>class [ hi-tag bootstrap-word ] unless* ;
|
||||
|
@ -100,7 +109,8 @@ TUPLE: no-method object generic ;
|
|||
|
||||
: build-type-vtable ( alist-seq -- alist-seq )
|
||||
dup length [
|
||||
vtable-class swap simplify-alist
|
||||
vtable-class
|
||||
swap [ word-def ] assoc-map simplify-alist
|
||||
class-predicates alist>quot
|
||||
] 2map ;
|
||||
|
||||
|
@ -137,30 +147,35 @@ TUPLE: no-method object generic ;
|
|||
: standard-methods ( word -- alist )
|
||||
dup methods swap default-method add* ;
|
||||
|
||||
M: standard-combination make-default-method
|
||||
standard-combination-# (dispatch#)
|
||||
[ empty-method ] with-variable ;
|
||||
|
||||
M: standard-combination perform-combination
|
||||
standard-combination-# (dispatch#) [
|
||||
[ standard-methods ] keep "inline" word-prop
|
||||
[ small-generic ] [ single-combination ] if
|
||||
] with-variable ;
|
||||
|
||||
: default-hook-method ( word -- pair )
|
||||
error-method object bootstrap-word swap 2array ;
|
||||
|
||||
: hook-methods ( word -- methods )
|
||||
dup methods [ [ drop ] swap append ] assoc-map
|
||||
swap default-hook-method add* ;
|
||||
|
||||
TUPLE: hook-combination var ;
|
||||
|
||||
C: <hook-combination> hook-combination
|
||||
|
||||
M: hook-combination perform-combination
|
||||
M: hook-combination method-prologue
|
||||
2drop [ drop ] ;
|
||||
|
||||
: with-hook ( combination quot -- quot' )
|
||||
0 (dispatch#) [
|
||||
[
|
||||
hook-combination-var [ get ] curry %
|
||||
hook-methods single-combination %
|
||||
] [ ] make
|
||||
] with-variable ;
|
||||
swap slip
|
||||
hook-combination-var [ get ] curry
|
||||
swap append
|
||||
] with-variable ; inline
|
||||
|
||||
M: hook-combination make-default-method
|
||||
[ error-method ] with-hook ;
|
||||
|
||||
M: hook-combination perform-combination
|
||||
[ standard-methods single-combination ] with-hook ;
|
||||
|
||||
: define-simple-generic ( word -- )
|
||||
T{ standard-combination f 0 } define-generic ;
|
||||
|
|
|
@ -9,9 +9,13 @@ IN: inference.backend
|
|||
: recursive-label ( word -- label/f )
|
||||
recursive-state get at ;
|
||||
|
||||
: inline? ( word -- ? )
|
||||
dup "parent-generic" word-prop
|
||||
[ inline? ] [ "inline" word-prop ] ?if ;
|
||||
|
||||
: local-recursive-state ( -- assoc )
|
||||
recursive-state get dup keys
|
||||
[ dup word? [ "inline" word-prop ] when not ] find drop
|
||||
[ dup word? [ inline? ] when not ] find drop
|
||||
[ head-slice ] when* ;
|
||||
|
||||
: inline-recursive-label ( word -- label/f )
|
||||
|
@ -157,7 +161,7 @@ TUPLE: too-many-r> ;
|
|||
meta-d get push-all ;
|
||||
|
||||
: if-inline ( word true false -- )
|
||||
>r >r dup "inline" word-prop r> r> if ; inline
|
||||
>r >r dup inline? r> r> if ; inline
|
||||
|
||||
: consume/produce ( effect node -- )
|
||||
over effect-in over consume-values
|
||||
|
@ -331,7 +335,7 @@ TUPLE: unbalanced-branches-error quots in out ;
|
|||
#merge node, ; inline
|
||||
|
||||
: make-call-node ( word effect -- )
|
||||
swap dup "inline" word-prop
|
||||
swap dup inline?
|
||||
over dup recursive-label eq? not and [
|
||||
meta-d get clone -rot
|
||||
recursive-label #call-label [ consume/produce ] keep
|
||||
|
|
|
@ -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"
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -74,3 +74,10 @@ M: object <file-writer>
|
|||
|
||||
M: object <file-appender>
|
||||
"ab" fopen <c-writer> <plain-writer> ;
|
||||
|
||||
: show ( msg -- )
|
||||
#! A word which directly calls primitives. It is used to
|
||||
#! print stuff from contexts where the I/O system would
|
||||
#! otherwise not work (tools.deploy.shaker, the I/O
|
||||
#! multiplexer thread).
|
||||
"\r\n" append stdout-handle fwrite stdout-handle fflush ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -10,7 +10,7 @@ TUPLE: slot-spec type name offset reader writer ;
|
|||
C: <slot-spec> slot-spec
|
||||
|
||||
: define-typecheck ( class generic quot -- )
|
||||
<method> 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 ;
|
||||
|
|
|
@ -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 [
|
||||
|
|
|
@ -126,7 +126,7 @@ IN: bootstrap.syntax
|
|||
f set-word
|
||||
location >r
|
||||
scan-word bootstrap-word scan-word
|
||||
[ parse-definition <method> -rot define-method ] 2keep
|
||||
[ parse-definition -rot define-method ] 2keep
|
||||
2array r> remember-definition
|
||||
] define-syntax
|
||||
|
||||
|
|
|
@ -154,7 +154,8 @@ SYMBOL: changed-words
|
|||
} reset-props ;
|
||||
|
||||
: reset-generic ( word -- )
|
||||
dup reset-word { "methods" "combination" } reset-props ;
|
||||
dup reset-word
|
||||
{ "methods" "combination" "default-method" } reset-props ;
|
||||
|
||||
: gensym ( -- word )
|
||||
"G:" \ gensym counter number>string append f <word> ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
|
||||
USING: kernel math math.parser random arrays hashtables assocs sequences
|
||||
vars strings.lib ;
|
||||
vars ;
|
||||
|
||||
IN: automata
|
||||
|
||||
|
@ -108,4 +108,4 @@ last-line> height> [ drop step-capped-line dup ] map >bitmap >last-line ;
|
|||
|
||||
! : start-loop ( -- ) t >loop-flag [ loop ] in-thread ;
|
||||
|
||||
! : stop-loop ( -- ) f >loop-flag ;
|
||||
! : stop-loop ( -- ) f >loop-flag ;
|
||||
|
|
|
@ -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
|
|
@ -0,0 +1,104 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs classes continuations kernel math
|
||||
namespaces sequences sequences.lib tuples words ;
|
||||
IN: db
|
||||
|
||||
TUPLE: db handle ;
|
||||
C: <db> db ( handle -- obj )
|
||||
|
||||
! HOOK: db-create db ( str -- )
|
||||
! HOOK: db-drop db ( str -- )
|
||||
GENERIC: db-open ( db -- )
|
||||
GENERIC: db-close ( db -- )
|
||||
|
||||
TUPLE: statement sql params handle bound? ;
|
||||
|
||||
TUPLE: simple-statement ;
|
||||
TUPLE: prepared-statement ;
|
||||
|
||||
HOOK: <simple-statement> db ( str -- statement )
|
||||
HOOK: <prepared-statement> db ( str -- statement )
|
||||
|
||||
GENERIC: prepare-statement ( statement -- )
|
||||
GENERIC: bind-statement* ( obj statement -- )
|
||||
GENERIC: rebind-statement ( obj statement -- )
|
||||
|
||||
GENERIC: execute-statement ( statement -- )
|
||||
|
||||
: bind-statement ( obj statement -- )
|
||||
2dup dup statement-bound? [
|
||||
rebind-statement
|
||||
] [
|
||||
bind-statement*
|
||||
] if
|
||||
tuck set-statement-params
|
||||
t swap set-statement-bound? ;
|
||||
|
||||
TUPLE: result-set sql params handle n max ;
|
||||
|
||||
GENERIC: query-results ( query -- result-set )
|
||||
|
||||
GENERIC: #rows ( result-set -- n )
|
||||
GENERIC: #columns ( result-set -- n )
|
||||
GENERIC# row-column 1 ( result-set n -- obj )
|
||||
GENERIC: advance-row ( result-set -- ? )
|
||||
|
||||
: init-result-set ( result-set -- )
|
||||
dup #rows over set-result-set-max
|
||||
-1 swap set-result-set-n ;
|
||||
|
||||
: <result-set> ( query handle tuple -- result-set )
|
||||
>r >r { statement-sql statement-params } get-slots r>
|
||||
{
|
||||
set-result-set-sql
|
||||
set-result-set-params
|
||||
set-result-set-handle
|
||||
} result-set construct r> construct-delegate ;
|
||||
|
||||
: sql-row ( result-set -- seq )
|
||||
dup #columns [ row-column ] with map ;
|
||||
|
||||
: query-each ( statement quot -- )
|
||||
over advance-row [
|
||||
2drop
|
||||
] [
|
||||
[ call ] 2keep query-each
|
||||
] if ; inline
|
||||
|
||||
: query-map ( statement quot -- seq )
|
||||
accumulator >r query-each r> { } like ; inline
|
||||
|
||||
: with-db ( db quot -- )
|
||||
[
|
||||
over db-open
|
||||
[ db swap with-variable ] curry with-disposal
|
||||
] with-scope ;
|
||||
|
||||
: do-query ( query -- result-set )
|
||||
query-results [ [ sql-row ] query-map ] with-disposal ;
|
||||
|
||||
: do-bound-query ( obj query -- rows )
|
||||
[ bind-statement ] keep do-query ;
|
||||
|
||||
: do-bound-command ( obj query -- )
|
||||
[ bind-statement ] keep execute-statement ;
|
||||
|
||||
: sql-query ( sql -- rows )
|
||||
<simple-statement> [ do-query ] with-disposal ;
|
||||
|
||||
: sql-command ( sql -- )
|
||||
<simple-statement> [ execute-statement ] with-disposal ;
|
||||
|
||||
SYMBOL: in-transaction
|
||||
HOOK: begin-transaction db ( -- )
|
||||
HOOK: commit-transaction db ( -- )
|
||||
HOOK: rollback-transaction db ( -- )
|
||||
|
||||
: in-transaction? ( -- ? ) in-transaction get ;
|
||||
|
||||
: with-transaction ( quot -- )
|
||||
t in-transaction [
|
||||
begin-transaction
|
||||
[ ] [ rollback-transaction ] cleanup commit-transaction
|
||||
] with-variable ;
|
|
@ -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 ( ) ;
|
|
@ -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 ;
|
|
@ -0,0 +1,110 @@
|
|||
! You will need to run 'createdb factor-test' to create the database.
|
||||
! Set username and password in the 'connect' word.
|
||||
|
||||
USING: kernel db.postgresql alien continuations io prettyprint
|
||||
sequences namespaces tools.test db ;
|
||||
IN: temporary
|
||||
|
||||
IN: scratchpad
|
||||
: test-db ( -- postgresql-db )
|
||||
"localhost" "postgres" "" "factor-test" <postgresql-db> ;
|
||||
IN: temporary
|
||||
|
||||
[ ] [ test-db [ ] with-db ] unit-test
|
||||
|
||||
[ ] [
|
||||
test-db [
|
||||
[ "drop table person;" sql-command ] catch drop
|
||||
"create table person (name varchar(30), country varchar(30));"
|
||||
sql-command
|
||||
|
||||
"insert into person values('John', 'America');" sql-command
|
||||
"insert into person values('Jane', 'New Zealand');" sql-command
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [
|
||||
test-db [
|
||||
"select * from person" sql-query
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ { "John" "America" } }
|
||||
] [
|
||||
test-db [
|
||||
"select * from person where name = $1 and country = $2"
|
||||
<simple-statement> [
|
||||
{ "Jane" "New Zealand" }
|
||||
over do-bound-query
|
||||
|
||||
{ { "Jane" "New Zealand" } } =
|
||||
[ "test fails" throw ] unless
|
||||
|
||||
{ "John" "America" }
|
||||
swap do-bound-query
|
||||
] with-disposal
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
{ "Jimmy" "Canada" }
|
||||
}
|
||||
] [ test-db [ "select * from person" sql-query ] with-db ] unit-test
|
||||
|
||||
[
|
||||
test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"oops" throw
|
||||
] with-transaction
|
||||
] with-db
|
||||
] unit-test-fails
|
||||
|
||||
[ 3 ] [
|
||||
test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test-db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
] with-transaction
|
||||
] with-db
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
test-db [
|
||||
"select * from person" sql-query length
|
||||
] with-db
|
||||
] unit-test
|
|
@ -0,0 +1,105 @@
|
|||
! Copyright (C) 2007, 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs alien alien.syntax continuations io
|
||||
kernel math namespaces prettyprint quotations
|
||||
sequences debugger db db.postgresql.lib db.postgresql.ffi ;
|
||||
IN: db.postgresql
|
||||
|
||||
TUPLE: postgresql-db host port pgopts pgtty db user pass ;
|
||||
TUPLE: postgresql-statement ;
|
||||
TUPLE: postgresql-result-set ;
|
||||
: <postgresql-statement> ( statement -- postgresql-statement )
|
||||
postgresql-statement construct-delegate ;
|
||||
|
||||
: <postgresql-db> ( host user pass db -- obj )
|
||||
{
|
||||
set-postgresql-db-host
|
||||
set-postgresql-db-user
|
||||
set-postgresql-db-pass
|
||||
set-postgresql-db-db
|
||||
} postgresql-db construct ;
|
||||
|
||||
M: postgresql-db db-open ( db -- )
|
||||
dup {
|
||||
postgresql-db-host
|
||||
postgresql-db-port
|
||||
postgresql-db-pgopts
|
||||
postgresql-db-pgtty
|
||||
postgresql-db-db
|
||||
postgresql-db-user
|
||||
postgresql-db-pass
|
||||
} get-slots connect-postgres <db> swap set-delegate ;
|
||||
|
||||
M: postgresql-db dispose ( db -- )
|
||||
db-handle PQfinish ;
|
||||
|
||||
: with-postgresql ( host ust pass db quot -- )
|
||||
>r <postgresql-db> r> with-disposal ;
|
||||
|
||||
M: postgresql-statement bind-statement* ( seq statement -- )
|
||||
set-statement-params ;
|
||||
|
||||
M: postgresql-statement rebind-statement ( seq statement -- )
|
||||
bind-statement* ;
|
||||
|
||||
M: postgresql-result-set #rows ( result-set -- n )
|
||||
result-set-handle PQntuples ;
|
||||
|
||||
M: postgresql-result-set #columns ( result-set -- n )
|
||||
result-set-handle PQnfields ;
|
||||
|
||||
M: postgresql-result-set row-column ( result-set n -- obj )
|
||||
>r dup result-set-handle swap result-set-n r> PQgetvalue ;
|
||||
|
||||
M: postgresql-statement execute-statement ( statement -- )
|
||||
query-results dispose ;
|
||||
|
||||
: increment-n ( result-set -- n )
|
||||
dup result-set-n 1+ dup rot set-result-set-n ;
|
||||
|
||||
M: postgresql-statement query-results ( query -- result-set )
|
||||
dup statement-params [
|
||||
over [ bind-statement ] keep
|
||||
do-postgresql-bound-statement
|
||||
] [
|
||||
dup do-postgresql-statement
|
||||
] if*
|
||||
postgresql-result-set <result-set>
|
||||
dup init-result-set ;
|
||||
|
||||
M: postgresql-result-set advance-row ( result-set -- ? )
|
||||
dup increment-n swap result-set-max >= ;
|
||||
|
||||
M: postgresql-statement dispose ( query -- )
|
||||
dup statement-handle PQclear
|
||||
f swap set-statement-handle ;
|
||||
|
||||
M: postgresql-result-set dispose ( result-set -- )
|
||||
dup result-set-handle PQclear
|
||||
0 0 f roll {
|
||||
set-result-set-n set-result-set-max set-result-set-handle
|
||||
} set-slots ;
|
||||
|
||||
M: postgresql-statement prepare-statement ( statement -- )
|
||||
[
|
||||
>r db get db-handle "" r>
|
||||
dup statement-sql swap statement-params
|
||||
length f PQprepare postgresql-error
|
||||
] keep set-statement-handle ;
|
||||
|
||||
M: postgresql-db <simple-statement> ( sql -- statement )
|
||||
{ set-statement-sql } statement construct
|
||||
<postgresql-statement> ;
|
||||
|
||||
M: postgresql-db <prepared-statement> ( sql -- statement )
|
||||
{ set-statement-sql } statement construct
|
||||
<postgresql-statement> ;
|
||||
|
||||
M: postgresql-db begin-transaction ( -- )
|
||||
"BEGIN" sql-command ;
|
||||
|
||||
M: postgresql-db commit-transaction ( -- )
|
||||
"COMMIT" sql-command ;
|
||||
|
||||
M: postgresql-db rollback-transaction ( -- )
|
||||
"ROLLBACK" sql-command ;
|
|
@ -0,0 +1,2 @@
|
|||
Chris Double
|
||||
Doug Coleman
|
|
@ -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 ) ;
|
|
@ -0,0 +1,85 @@
|
|||
! Copyright (C) 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types assocs kernel math math.parser sequences
|
||||
db.sqlite.ffi ;
|
||||
IN: db.sqlite.lib
|
||||
|
||||
TUPLE: sqlite-error n message ;
|
||||
|
||||
: sqlite-check-result ( result -- )
|
||||
dup SQLITE_OK = [
|
||||
drop
|
||||
] [
|
||||
dup sqlite-error-messages nth
|
||||
sqlite-error construct-boa throw
|
||||
] if ;
|
||||
|
||||
: sqlite-open ( filename -- db )
|
||||
"void*" <c-object>
|
||||
[ sqlite3_open sqlite-check-result ] keep *void* ;
|
||||
|
||||
: sqlite-close ( db -- )
|
||||
sqlite3_close sqlite-check-result ;
|
||||
|
||||
: sqlite-last-insert-rowid ( db -- rowid )
|
||||
sqlite3_last_insert_rowid ;
|
||||
|
||||
: sqlite-prepare ( db sql -- statement )
|
||||
#! TODO: Support multiple statements in the SQL string.
|
||||
dup length "void*" <c-object> "void*" <c-object>
|
||||
[ sqlite3_prepare sqlite-check-result ] 2keep
|
||||
drop *void* ;
|
||||
|
||||
: sqlite-bind-text ( statement index text -- )
|
||||
dup number? [ number>string ] when
|
||||
dup length SQLITE_TRANSIENT sqlite3_bind_text sqlite-check-result ;
|
||||
|
||||
: sqlite-bind-parameter-index ( statement name -- index )
|
||||
sqlite3_bind_parameter_index ;
|
||||
|
||||
: sqlite-bind-text-by-name ( statement name text -- )
|
||||
>r dupd sqlite-bind-parameter-index r> sqlite-bind-text ;
|
||||
|
||||
: sqlite-bind-assoc ( statement assoc -- )
|
||||
swap [
|
||||
-rot sqlite-bind-text-by-name
|
||||
] curry assoc-each ;
|
||||
|
||||
: sqlite-finalize ( statement -- )
|
||||
sqlite3_finalize sqlite-check-result ;
|
||||
|
||||
: sqlite-reset ( statement -- )
|
||||
sqlite3_reset sqlite-check-result ;
|
||||
|
||||
: sqlite-#columns ( query -- int )
|
||||
sqlite3_column_count ;
|
||||
|
||||
: sqlite-column ( statement index -- string )
|
||||
sqlite3_column_text ;
|
||||
|
||||
: sqlite-row ( statement -- seq )
|
||||
dup sqlite-#columns [ sqlite-column ] with map ;
|
||||
|
||||
! 2dup sqlite3_column_type .
|
||||
! SQLITE_INTEGER 1
|
||||
! SQLITE_FLOAT 2
|
||||
! SQLITE_TEXT 3
|
||||
! SQLITE_BLOB 4
|
||||
! SQLITE_NULL 5
|
||||
|
||||
: step-complete? ( step-result -- bool )
|
||||
dup SQLITE_ROW = [
|
||||
drop f
|
||||
] [
|
||||
dup SQLITE_DONE = [ drop t ] [ sqlite-check-result t ] if
|
||||
] if ;
|
||||
|
||||
: sqlite-step ( prepared -- )
|
||||
dup sqlite3_step step-complete? [
|
||||
drop
|
||||
] [
|
||||
sqlite-step
|
||||
] if ;
|
||||
|
||||
: sqlite-next ( prepared -- ? )
|
||||
sqlite3_step step-complete? ;
|
|
@ -0,0 +1,110 @@
|
|||
USING: io io.files io.launcher kernel namespaces
|
||||
prettyprint tools.test db.sqlite db db.sql sequences
|
||||
continuations ;
|
||||
IN: temporary
|
||||
|
||||
! "sqlite3 -init test.txt test.db"
|
||||
|
||||
IN: scratchpad
|
||||
: test.db "extra/db/sqlite/test.db" resource-path ;
|
||||
|
||||
IN: temporary
|
||||
: (create-db) ( -- str )
|
||||
[
|
||||
"sqlite3 -init " %
|
||||
test.db %
|
||||
" " %
|
||||
test.db %
|
||||
] "" make ;
|
||||
|
||||
: create-db ( -- ) (create-db) run-process drop ;
|
||||
|
||||
[ ] [ test.db delete-file ] unit-test
|
||||
|
||||
[ ] [ create-db ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "John" "America" }
|
||||
{ "Jane" "New Zealand" }
|
||||
}
|
||||
] [
|
||||
test.db [
|
||||
"select * from person" sql-query
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{ { "John" "America" } }
|
||||
] [
|
||||
test.db [
|
||||
"select * from person where name = :name and country = :country"
|
||||
<simple-statement> [
|
||||
{ { ":name" "Jane" } { ":country" "New Zealand" } }
|
||||
over do-bound-query
|
||||
|
||||
{ { "Jane" "New Zealand" } } =
|
||||
[ "test fails" throw ] unless
|
||||
|
||||
{ { ":name" "John" } { ":country" "America" } }
|
||||
swap do-bound-query
|
||||
] with-disposal
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "1" "John" "America" }
|
||||
{ "2" "Jane" "New Zealand" }
|
||||
}
|
||||
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test.db [
|
||||
"insert into person(name, country) values('Jimmy', 'Canada')"
|
||||
sql-command
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ "1" "John" "America" }
|
||||
{ "2" "Jane" "New Zealand" }
|
||||
{ "3" "Jimmy" "Canada" }
|
||||
}
|
||||
] [ test.db [ "select rowid, * from person" sql-query ] with-sqlite ] unit-test
|
||||
|
||||
[
|
||||
test.db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')" sql-command
|
||||
"oops" throw
|
||||
] with-transaction
|
||||
] with-sqlite
|
||||
] unit-test-fails
|
||||
|
||||
[ 3 ] [
|
||||
test.db [
|
||||
"select * from person" sql-query length
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[
|
||||
] [
|
||||
test.db [
|
||||
[
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
"insert into person(name, country) values('Jose', 'Mexico')"
|
||||
sql-command
|
||||
] with-transaction
|
||||
] with-sqlite
|
||||
] unit-test
|
||||
|
||||
[ 5 ] [
|
||||
test.db [
|
||||
"select * from person" sql-query length
|
||||
] with-sqlite
|
||||
] unit-test
|
|
@ -0,0 +1,74 @@
|
|||
! Copyright (C) 2005, 2008 Chris Double, Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien arrays assocs classes compiler db db.sql
|
||||
hashtables io.files kernel math math.parser namespaces
|
||||
prettyprint sequences strings tuples alien.c-types
|
||||
continuations db.sqlite.lib db.sqlite.ffi ;
|
||||
IN: db.sqlite
|
||||
|
||||
TUPLE: sqlite-db path ;
|
||||
C: <sqlite-db> sqlite-db
|
||||
|
||||
M: sqlite-db db-open ( db -- )
|
||||
dup sqlite-db-path sqlite-open <db>
|
||||
swap set-delegate ;
|
||||
|
||||
M: sqlite-db dispose ( obj -- )
|
||||
dup db-handle sqlite-close
|
||||
f over set-db-handle
|
||||
f swap set-delegate ;
|
||||
|
||||
: with-sqlite ( path quot -- )
|
||||
>r <sqlite-db> r> with-db ; inline
|
||||
|
||||
TUPLE: sqlite-statement ;
|
||||
C: <sqlite-statement> sqlite-statement
|
||||
|
||||
TUPLE: sqlite-result-set ;
|
||||
: <sqlite-result-set> ( query -- sqlite-result-set )
|
||||
dup statement-handle sqlite-result-set <result-set> ;
|
||||
|
||||
M: sqlite-db <simple-statement> ( str -- obj )
|
||||
<prepared-statement> ;
|
||||
|
||||
M: sqlite-db <prepared-statement> ( str -- obj )
|
||||
db get db-handle over sqlite-prepare
|
||||
{ set-statement-sql set-statement-handle } statement construct
|
||||
<sqlite-statement> [ set-delegate ] keep ;
|
||||
|
||||
M: sqlite-statement dispose ( statement -- )
|
||||
statement-handle sqlite-finalize ;
|
||||
|
||||
M: sqlite-result-set dispose ( result-set -- )
|
||||
f swap set-result-set-handle ;
|
||||
|
||||
M: sqlite-statement bind-statement* ( assoc statement -- )
|
||||
statement-handle swap sqlite-bind-assoc ;
|
||||
|
||||
M: sqlite-statement rebind-statement ( assoc statement -- )
|
||||
dup statement-handle sqlite-reset
|
||||
statement-handle swap sqlite-bind-assoc ;
|
||||
|
||||
M: sqlite-statement execute-statement ( statement -- )
|
||||
statement-handle sqlite-next drop ;
|
||||
|
||||
M: sqlite-result-set #columns ( result-set -- n )
|
||||
result-set-handle sqlite-#columns ;
|
||||
|
||||
M: sqlite-result-set row-column ( result-set n -- obj )
|
||||
>r result-set-handle r> sqlite-column ;
|
||||
|
||||
M: sqlite-result-set advance-row ( result-set -- handle ? )
|
||||
result-set-handle sqlite-next ;
|
||||
|
||||
M: sqlite-statement query-results ( query -- result-set )
|
||||
dup statement-handle sqlite-result-set <result-set> ;
|
||||
|
||||
M: sqlite-db begin-transaction ( -- )
|
||||
"BEGIN" sql-command ;
|
||||
|
||||
M: sqlite-db commit-transaction ( -- )
|
||||
"COMMIT" sql-command ;
|
||||
|
||||
M: sqlite-db rollback-transaction ( -- )
|
||||
"ROLLBACK" sql-command ;
|
|
@ -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');
|
|
@ -27,7 +27,7 @@ M: tuple-class group-words
|
|||
swap [ slot-spec-writer ] map append ;
|
||||
|
||||
: define-consult-method ( word class quot -- )
|
||||
pick add <method> spin define-method ;
|
||||
pick add spin define-method ;
|
||||
|
||||
: define-consult ( class group quot -- )
|
||||
>r group-words r>
|
||||
|
|
|
@ -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 )
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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 -- )
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
@ -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 <process-stream> }
|
||||
{ $subsection with-process-stream }
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: monitor queue closed? ;
|
||||
|
||||
: check-monitor ( monitor -- )
|
||||
monitor-closed? [ "Monitor closed" throw ] when ;
|
||||
|
||||
: (monitor) ( delegate -- monitor )
|
||||
H{ } clone {
|
||||
set-delegate
|
||||
set-monitor-queue
|
||||
} monitor construct ;
|
||||
|
||||
HOOK: fill-queue io-backend ( monitor -- )
|
||||
|
||||
: changed-file ( changed path -- )
|
||||
namespace [ append ] change-at ;
|
||||
|
||||
: dequeue-change ( assoc -- path changes )
|
||||
delete-any prune natural-sort >array ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
HOOK: <monitor> 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+
|
||||
|
|
|
@ -14,9 +14,9 @@ TUPLE: io-task port callbacks ;
|
|||
|
||||
: io-task-fd io-task-port port-handle ;
|
||||
|
||||
: <io-task> ( port continuation class -- task )
|
||||
>r 1vector io-task construct-boa r> construct-delegate ;
|
||||
inline
|
||||
: <io-task> ( 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 ;
|
||||
|
||||
: <mx-task> ( port -- task )
|
||||
f io-task construct-boa mx-task construct-delegate ;
|
||||
f mx-task <io-task> ;
|
||||
|
||||
M: mx-task do-io-task
|
||||
io-task-port mx-port-mx 0 swap wait-for-events f ;
|
||||
|
|
|
@ -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 <process>
|
||||
] with-descriptor ;
|
||||
|
||||
M: unix-io kill-process* ( pid -- )
|
||||
SIGTERM kill io-error ;
|
||||
|
||||
: open-pipe ( -- pair )
|
||||
2 "int" <c-array> dup pipe zero?
|
||||
[ 2 c-int-array> ] [ drop f ] if ;
|
||||
|
|
|
@ -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 ;
|
||||
|
||||
: <linux-monitor> ( 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 ;
|
||||
|
||||
: <inotify> ( -- port )
|
||||
H{ } clone
|
||||
inotify_init dup io-error inotify <buffered-port>
|
||||
{ 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
|
||||
[ <linux-monitor> 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 <monitor> ( 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 <displaced-alien> ;
|
||||
|
||||
: 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 ;
|
||||
|
||||
: <inotify-task> ( port -- task )
|
||||
f inotify-task <input-task> ;
|
||||
|
||||
: init-inotify ( mx -- )
|
||||
<inotify>
|
||||
dup inotify set-global
|
||||
<inotify-task> swap register-io-task ;
|
||||
|
||||
M: inotify-task do-io-task ( task -- )
|
||||
io-task-port read-notifications f ;
|
||||
|
||||
M: linux-io init-io ( -- )
|
||||
<select-mx> mx set-global ;
|
||||
<select-mx> dup mx set-global init-inotify ;
|
||||
|
||||
T{ linux-io } set-io-backend
|
||||
|
||||
|
|
|
@ -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."
|
||||
|
|
|
@ -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 <win32-file> ;
|
||||
|
||||
TUPLE: win32-monitor path recursive? ;
|
||||
|
||||
: <win32-monitor> ( path recursive? port -- monitor )
|
||||
(monitor) {
|
||||
set-win32-monitor-path
|
||||
set-win32-monitor-recursive?
|
||||
set-delegate
|
||||
} win32-monitor construct ;
|
||||
|
||||
M: windows-nt-io <monitor> ( path recursive? -- monitor )
|
||||
[
|
||||
>r dup open-directory monitor <buffered-port> r> {
|
||||
set-monitor-path
|
||||
set-delegate
|
||||
set-monitor-recursive?
|
||||
} monitor construct
|
||||
over open-directory win32-monitor <buffered-port>
|
||||
<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 <uint>
|
||||
(make-overlapped)
|
||||
|
@ -49,6 +50,7 @@ M: windows-nt-io <monitor> ( 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 <monitor> ( 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 <displaced-alien> (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 ;
|
||||
|
|
|
@ -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
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 ;
|
||||
|
|
|
@ -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
|
||||
! --------
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: r-trunc? ( n -- ? )
|
||||
10 /i dup 0 > [
|
||||
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
|
|
@ -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.
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (concat-product) ( accum n multiplier -- m )
|
||||
pick length 8 > [
|
||||
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
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: max-p ( -- n )
|
||||
p-count get length ;
|
||||
|
||||
: adjust-p-count ( n -- )
|
||||
max-p 1- over <range> 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 <array> 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
|
|
@ -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
|
||||
! --------
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: (concat-upto) ( n limit str -- str )
|
||||
2dup length > [
|
||||
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
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: max-p ( -- n )
|
||||
p-count get length ;
|
||||
|
||||
: adjust-p-count ( n -- )
|
||||
max-p 1- over <range> 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 <array> 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
|
|
@ -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 ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
@ -140,3 +140,16 @@ PRIVATE>
|
|||
: ?second ( seq -- second/f ) 1 swap ?nth ; inline
|
||||
: ?third ( seq -- third/f ) 2 swap ?nth ; inline
|
||||
: ?fourth ( seq -- fourth/f ) 3 swap ?nth ; inline
|
||||
|
||||
: accumulator ( quot -- quot vec )
|
||||
V{ } clone [ [ push ] curry compose ] keep ;
|
||||
|
||||
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
|
||||
|
||||
! List the positions of obj in seq
|
||||
|
||||
: indices ( seq obj -- seq )
|
||||
>r dup length swap r>
|
||||
[ = [ ] [ drop f ] if ] curry
|
||||
2map
|
||||
[ ] subset ;
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -14,8 +14,7 @@ IN: tools.crossref
|
|||
|
||||
: (method-usage) ( word generic -- methods )
|
||||
tuck methods
|
||||
[ second quot-uses key? ] with subset
|
||||
0 <column>
|
||||
[ second uses member? ] with subset keys
|
||||
swap [ 2array ] curry map ;
|
||||
|
||||
: method-usage ( word seq -- methods )
|
||||
|
|
|
@ -16,8 +16,11 @@ IN: tools.deploy.backend
|
|||
: copy-lines ( stream -- )
|
||||
[ (copy-lines) ] with-disposal ;
|
||||
|
||||
: run-with-output ( descriptor -- )
|
||||
<process-stream>
|
||||
: run-with-output ( arguments -- )
|
||||
[
|
||||
+arguments+ set
|
||||
+stdout+ +stderr+ set
|
||||
] H{ } make-assoc <process-stream>
|
||||
dup duplex-stream-out dispose
|
||||
copy-lines ;
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ;
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax ;
|
||||
USING: alien.syntax math math.bitfields ;
|
||||
IN: unix.linux.inotify
|
||||
|
||||
C-STRUCT: inotify-event
|
||||
|
@ -8,7 +8,7 @@ C-STRUCT: inotify-event
|
|||
{ "uint" "mask" } ! watch mask
|
||||
{ "uint" "cookie" } ! cookie to synchronize two events
|
||||
{ "uint" "len" } ! length (including nulls) of name
|
||||
{ "char[1]" "name" } ! stub for possible name
|
||||
{ "char[0]" "name" } ! stub for possible name
|
||||
;
|
||||
|
||||
: IN_ACCESS HEX: 1 ; inline ! File was accessed
|
||||
|
@ -37,6 +37,13 @@ C-STRUCT: inotify-event
|
|||
: 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
|
||||
|
@ -45,6 +52,6 @@ C-STRUCT: inotify-event
|
|||
IN_MOVE_SELF
|
||||
} flags ; foldable
|
||||
|
||||
FUNCTION: int inotify_init ( void ) ;
|
||||
FUNCTION: int inotify_add_watch ( int fd, char* name, u32 mask ) ;
|
||||
FUNCTION: int inotify_rm_watch ( int fd, u32 wd ) ;
|
||||
FUNCTION: int inotify_init ( ) ;
|
||||
FUNCTION: int inotify_add_watch ( int fd, char* name, uint mask ) ;
|
||||
FUNCTION: int inotify_rm_watch ( int fd, uint wd ) ;
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -3,8 +3,6 @@
|
|||
IN: unix
|
||||
USING: alien.syntax system kernel ;
|
||||
|
||||
TYPEDEF: ulong off_t
|
||||
|
||||
! Solaris.
|
||||
|
||||
: O_RDONLY HEX: 0000 ; inline
|
||||
|
|
|
@ -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,9 +170,10 @@ 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
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2005, 2006 Eduardo Cavazos and Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types hashtables kernel math math.vectors
|
||||
USING: alien alien.c-types hashtables kernel math math.vectors math.bitfields
|
||||
namespaces sequences x11.xlib x11.constants x11.glx ;
|
||||
IN: x11.windows
|
||||
|
||||
|
@ -12,7 +12,6 @@ IN: x11.windows
|
|||
XCreateColormap ;
|
||||
|
||||
: event-mask ( -- n )
|
||||
<<<<<<< HEAD:extra/x11/windows/windows.factor
|
||||
{
|
||||
ExposureMask
|
||||
StructureNotifyMask
|
||||
|
@ -26,19 +25,6 @@ IN: x11.windows
|
|||
LeaveWindowMask
|
||||
PropertyChangeMask
|
||||
} flags ;
|
||||
=======
|
||||
ExposureMask
|
||||
StructureNotifyMask bitor
|
||||
KeyPressMask bitor
|
||||
KeyReleaseMask bitor
|
||||
ButtonPressMask bitor
|
||||
ButtonReleaseMask bitor
|
||||
PointerMotionMask bitor
|
||||
FocusChangeMask bitor
|
||||
EnterWindowMask bitor
|
||||
LeaveWindowMask bitor
|
||||
PropertyChangeMask bitor ;
|
||||
>>>>>>> a05c18152b59073c49aa313ba685516310ec74a8:extra/x11/windows/windows.factor
|
||||
|
||||
: window-attributes ( visinfo -- attributes )
|
||||
"XSetWindowAttributes" <c-object>
|
||||
|
|
|
@ -12,7 +12,7 @@
|
|||
! and note the section.
|
||||
|
||||
USING: kernel arrays alien alien.c-types alien.syntax
|
||||
math words sequences namespaces continuations ;
|
||||
math math.bitfields words sequences namespaces continuations ;
|
||||
IN: x11.xlib
|
||||
|
||||
LIBRARY: xlib
|
||||
|
@ -1078,16 +1078,16 @@ FUNCTION: Status XWithdrawWindow (
|
|||
|
||||
! 17.1.7 - Setting and Reading the WM_NORMAL_HINTS Property
|
||||
|
||||
: USPosition 1 0 shift ; inline
|
||||
: USSize 1 1 shift ; inline
|
||||
: PPosition 1 2 shift ; inline
|
||||
: PSize 1 3 shift ; inline
|
||||
: PMinSize 1 4 shift ; inline
|
||||
: PMaxSize 1 5 shift ; inline
|
||||
: PResizeInc 1 6 shift ; inline
|
||||
: PAspect 1 7 shift ; inline
|
||||
: PBaseSize 1 8 shift ; inline
|
||||
: PWinGravity 1 9 shift ; inline
|
||||
: USPosition 1 0 shift ; inline
|
||||
: USSize 1 1 shift ; inline
|
||||
: PPosition 1 2 shift ; inline
|
||||
: PSize 1 3 shift ; inline
|
||||
: PMinSize 1 4 shift ; inline
|
||||
: PMaxSize 1 5 shift ; inline
|
||||
: PResizeInc 1 6 shift ; inline
|
||||
: PAspect 1 7 shift ; inline
|
||||
: PBaseSize 1 8 shift ; inline
|
||||
: PWinGravity 1 9 shift ; inline
|
||||
: PAllHints
|
||||
{ PPosition PSize PMinSize PMaxSize PResizeInc PAspect } flags ; foldable
|
||||
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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;
|
||||
}
|
||||
|
|
|
@ -1,3 +1,5 @@
|
|||
#include <sys/syscall.h>
|
||||
|
||||
#define UNKNOWN_TYPE_P(file) ((file)->d_type == DT_UNKNOWN)
|
||||
#define DIRECTORY_P(file) ((file)->d_type == DT_DIR)
|
||||
|
||||
|
|
15
vm/types.c
15
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) \
|
||||
{ \
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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);
|
||||
|
|
|
@ -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);
|
||||
|
|
Loading…
Reference in New Issue