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

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

db4
Bruno Deferrari 2008-04-29 09:16:38 -03:00
parent 03b6ae371a 1bc0290c7d
commit cc5d35e189
51 changed files with 44146 additions and 687 deletions

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

@ -270,7 +270,7 @@ M: no-such-symbol compiler-error-type
pop-literal nip >>library
pop-literal nip >>return
! Quotation which coerces parameters to required types
dup param-prep-quot f infer-quot
dup param-prep-quot recursive-state get infer-quot
! Set ABI
dup library>> library [ abi>> ] [ "cdecl" ] if* >>abi
! Add node to IR
@ -278,7 +278,7 @@ M: no-such-symbol compiler-error-type
! Magic #: consume exactly the number of inputs
dup 0 alien-invoke-stack
! Quotation which coerces return value to required type
return-prep-quot f infer-quot
return-prep-quot recursive-state get infer-quot
] "infer" set-word-prop
M: #alien-invoke generate-node
@ -306,13 +306,13 @@ M: alien-indirect-error summary
pop-parameters >>parameters
pop-literal nip >>return
! Quotation which coerces parameters to required types
dup param-prep-quot [ dip ] curry f infer-quot
dup param-prep-quot [ dip ] curry recursive-state get infer-quot
! Add node to IR
dup node,
! Magic #: consume the function pointer, too
dup 1 alien-invoke-stack
! Quotation which coerces return value to required type
return-prep-quot f infer-quot
return-prep-quot recursive-state get infer-quot
] "infer" set-word-prop
M: #alien-indirect generate-node
@ -345,7 +345,7 @@ M: alien-callback-error summary
: callback-bottom ( node -- )
xt>> [ word-xt drop <alien> ] curry
f infer-quot ;
recursive-state get infer-quot ;
\ alien-callback [
4 ensure-values

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

@ -18,6 +18,8 @@ IN: bootstrap.compiler
enable-compiler
: compile-uncompiled [ compiled? not ] filter compile ;
nl
"Compiling..." write flush
@ -42,38 +44,38 @@ nl
find-pair-next namestack*
bitand bitor bitxor bitnot
} compile
} compile-uncompiled
"." write flush
{
+ 1+ 1- 2/ < <= > >= shift min
} compile
+ 1+ 1- 2/ < <= > >= shift
} compile-uncompiled
"." write flush
{
new-sequence nth push pop peek
} compile
} compile-uncompiled
"." write flush
{
hashcode* = get set
} compile
} compile-uncompiled
"." write flush
{
. lines
} compile
} compile-uncompiled
"." write flush
{
malloc calloc free memcpy
} compile
} compile-uncompiled
vocabs [ words [ compiled? not ] filter compile "." write flush ] each
vocabs [ words compile-uncompiled "." write flush ] each
" done" print flush

19
core/bootstrap/image/image-tests.factor
View File

@ -1,5 +1,22 @@
IN: bootstrap.image.tests
USING: bootstrap.image bootstrap.image.private tools.test ;
USING: bootstrap.image bootstrap.image.private tools.test
kernel math ;
\ ' must-infer
\ write-image must-infer
[ f ] [ { 1 2 3 } [ 1 2 3 ] eql? ] unit-test
[ t ] [ [ 1 2 3 ] [ 1 2 3 ] eql? ] unit-test
[ f ] [ [ 2drop 0 ] [ 2drop 0.0 ] eql? ] unit-test
[ t ] [ [ 2drop 0 ] [ 2drop 0 ] eql? ] unit-test
[ f ] [ \ + [ 2drop 0 ] eql? ] unit-test
[ f ] [ 3 [ 0 1 2 ] eql? ] unit-test
[ f ] [ 3 3.0 eql? ] unit-test
[ t ] [ 4.0 4.0 eql? ] unit-test

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

@ -8,7 +8,7 @@ splitting growable classes classes.builtin classes.tuple
classes.tuple.private words.private io.binary io.files vocabs
vocabs.loader source-files definitions debugger float-arrays
quotations.private sequences.private combinators
io.encodings.binary math.order ;
io.encodings.binary math.order accessors ;
IN: bootstrap.image
: my-arch ( -- arch )
@ -31,6 +31,43 @@ IN: bootstrap.image
<PRIVATE
! Object cache; we only consider numbers equal if they have the
! same type
TUPLE: id obj ;
C: <id> id
M: id hashcode* obj>> hashcode* ;
GENERIC: (eql?) ( obj1 obj2 -- ? )
: eql? ( obj1 obj2 -- ? )
[ (eql?) ] [ [ class ] bi@ = ] 2bi and ;
M: integer (eql?) = ;
M: sequence (eql?)
over sequence? [
2dup [ length ] bi@ =
[ [ eql? ] 2all? ] [ 2drop f ] if
] [ 2drop f ] if ;
M: object (eql?) = ;
M: id equal?
over id? [ [ obj>> ] bi@ eql? ] [ 2drop f ] if ;
SYMBOL: objects
: (objects) <id> objects get ; inline
: lookup-object ( obj -- n/f ) (objects) at ;
: put-object ( n obj -- ) (objects) set-at ;
: cache-object ( obj quot -- value )
>r (objects) r> [ obj>> ] prepose cache ; inline
! Constants
: image-magic HEX: 0f0e0d0c ; inline
@ -61,9 +98,6 @@ IN: bootstrap.image
! The image being constructed; a vector of word-size integers
SYMBOL: image
! Object cache
SYMBOL: objects
! Image output format
SYMBOL: big-endian
@ -187,7 +221,9 @@ GENERIC: ' ( obj -- ptr )
2tri ;
M: bignum '
bignum tag-number dup [ emit-bignum ] emit-object ;
[
bignum tag-number dup [ emit-bignum ] emit-object
] cache-object ;
! Fixnums
@ -202,9 +238,11 @@ M: fixnum '
! Floats
M: float '
float tag-number dup [
align-here double>bits emit-64
] emit-object ;
[
float tag-number dup [
align-here double>bits emit-64
] emit-object
] cache-object ;
! Special objects
@ -243,7 +281,7 @@ M: f '
] bi
\ word type-number object tag-number
[ emit-seq ] emit-object
] keep objects get set-at ;
] keep put-object ;
: word-error ( word msg -- * )
[ % dup word-vocabulary % " " % word-name % ] "" make throw ;
@ -252,7 +290,7 @@ M: f '
[ target-word ] keep or ;
: fixup-word ( word -- offset )
transfer-word dup objects get at
transfer-word dup lookup-object
[ ] [ "Not in image: " word-error ] ?if ;
: fixup-words ( -- )
@ -286,7 +324,7 @@ M: wrapper '
M: string '
#! We pool strings so that each string is only written once
#! to the image
objects get [ emit-string ] cache ;
[ emit-string ] cache-object ;
: assert-empty ( seq -- )
length 0 assert= ;
@ -311,12 +349,12 @@ M: float-array ' float-array emit-dummy-array ;
: emit-tuple ( tuple -- pointer )
dup class word-name "tombstone" =
[ objects get [ (emit-tuple) ] cache ] [ (emit-tuple) ] if ;
[ [ (emit-tuple) ] cache-object ] [ (emit-tuple) ] if ;
M: tuple ' emit-tuple ;
M: tuple-layout '
objects get [
[
[
{
[ layout-hashcode , ]
@ -328,12 +366,12 @@ M: tuple-layout '
] { } make [ ' ] map
\ tuple-layout type-number
object tag-number [ emit-seq ] emit-object
] cache ;
] cache-object ;
M: tombstone '
delegate
"((tombstone))" "((empty))" ? "hashtables.private" lookup
word-def first objects get [ emit-tuple ] cache ;
word-def first [ emit-tuple ] cache-object ;
! Arrays
M: array '
@ -343,7 +381,7 @@ M: array '
! Quotations
M: quotation '
objects get [
[
quotation-array '
quotation type-number object tag-number [
emit ! array
@ -351,7 +389,7 @@ M: quotation '
0 emit ! xt
0 emit ! code
] emit-object
] cache ;
] cache-object ;
! End of the image

5
core/math/floats/floats.factor
View File

@ -6,8 +6,6 @@ IN: math.floats.private
M: fixnum >float fixnum>float ;
M: bignum >float bignum>float ;
M: float zero? dup 0.0 float= swap -0.0 float= or ;
M: float >fixnum float>fixnum ;
M: float >bignum float>bignum ;
M: float >float ;
@ -22,4 +20,7 @@ M: float + float+ ;
M: float - float- ;
M: float * float* ;
M: float / float/f ;
M: float /f float/f ;
M: float mod float-mod ;
M: real abs dup 0 < [ neg ] when ;

32
core/math/integers/integers-tests.factor
View File

@ -1,5 +1,5 @@
USING: kernel math namespaces prettyprint
math.private continuations tools.test sequences ;
USING: kernel math math.functions namespaces prettyprint
math.private continuations tools.test sequences random ;
IN: math.integers.tests
[ "-8" ] [ -8 unparse ] unit-test
@ -191,3 +191,31 @@ unit-test
[ f ] [ -128 power-of-2? ] unit-test
[ f ] [ 0 power-of-2? ] unit-test
[ t ] [ 1 power-of-2? ] unit-test
: ratio>float [ >bignum ] bi@ /f ;
[ 5. ] [ 5 1 ratio>float ] unit-test
[ 4. ] [ 4 1 ratio>float ] unit-test
[ 2. ] [ 2 1 ratio>float ] unit-test
[ .5 ] [ 1 2 ratio>float ] unit-test
[ .75 ] [ 3 4 ratio>float ] unit-test
[ 1. ] [ 2000 2^ 2000 2^ 1+ ratio>float ] unit-test
[ -1. ] [ 2000 2^ neg 2000 2^ 1+ ratio>float ] unit-test
[ 0.4 ] [ 6 15 ratio>float ] unit-test
[ HEX: 3fe553522d230931 ]
[ 61967020039 92984792073 ratio>float double>bits ] unit-test
: random-integer
32 random-bits
1 random zero? [ neg ] when
1 random zero? [ >bignum ] when ;
[ t ] [
1000 [
drop
random-integer
random-integer
[ >float / ] [ /f ] 2bi 0.1 ~
] all?
] unit-test

58
core/math/integers/integers.factor
View File

@ -1,4 +1,5 @@
! Copyright (C) 2004, 2007 Slava Pestov.
! Copyright (C) 2008, Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel kernel.private sequences
sequences.private math math.private combinators ;
@ -22,6 +23,8 @@ M: fixnum + fixnum+ ;
M: fixnum - fixnum- ;
M: fixnum * fixnum* ;
M: fixnum /i fixnum/i ;
M: fixnum /f >r >float r> >float float/f ;
M: fixnum mod fixnum-mod ;
M: fixnum /mod fixnum/mod ;
@ -67,4 +70,57 @@ M: bignum bitnot bignum-bitnot ;
M: bignum bit? bignum-bit? ;
M: bignum (log2) bignum-log2 ;
M: integer zero? 0 number= ;
! Converting ratios to floats. Based on FLOAT-RATIO from
! sbcl/src/code/float.lisp, which has the following license:
! "The software is in the public domain and is
! provided with absolutely no warranty."
! First step: pre-scaling
: twos ( x -- y ) dup 1- bitxor log2 ; inline
: scale-denonimator ( den -- scaled-den scale' )
dup twos neg [ shift ] keep ; inline
: pre-scale ( num den -- scale shifted-num scaled-den )
2dup [ log2 ] bi@ -
tuck [ neg 54 + shift ] [ >r scale-denonimator r> + ] 2bi*
-rot ; inline
! Second step: loop
: shift-mantissa ( scale mantissa -- scale' mantissa' )
[ 1+ ] [ 2/ ] bi* ; inline
: /f-loop ( scale mantissa den -- scale' fraction-and-guard rem )
[ 2dup /i log2 53 > ]
[ >r shift-mantissa r> ]
[ ] while /mod ; inline
! Third step: post-scaling
: unscaled-float ( mantissa -- n )
52 2^ 1- bitand 1022 52 shift bitor bits>double ; inline
: scale-float ( scale mantissa -- float' )
>r dup 0 < [ neg 2^ recip ] [ 2^ ] if r> * ; inline
: post-scale ( scale mantissa -- n )
2/ dup log2 52 > [ shift-mantissa ] when
unscaled-float scale-float ; inline
! Main word
: /f-abs ( m n -- f )
over zero? [
2drop 0.0
] [
dup zero? [
2drop 1.0/0.0
] [
pre-scale
/f-loop over odd?
[ zero? [ 1+ ] unless ] [ drop ] if
post-scale
] if
] if ; inline
M: bignum /f ( m n -- f )
[ [ abs ] bi@ /f-abs ] [ [ 0 < ] bi@ xor ] 2bi [ neg ] when ;

10
core/math/math.factor
View File

@ -21,6 +21,7 @@ MATH: + ( x y -- z ) foldable
MATH: - ( x y -- z ) foldable
MATH: * ( x y -- z ) foldable
MATH: / ( x y -- z ) foldable
MATH: /f ( x y -- z ) foldable
MATH: /i ( x y -- z ) foldable
MATH: mod ( x y -- z ) foldable
@ -33,6 +34,8 @@ GENERIC# shift 1 ( x n -- y ) foldable
GENERIC: bitnot ( x -- y ) foldable
GENERIC# bit? 1 ( x n -- ? ) foldable
GENERIC: abs ( x -- y ) foldable
<PRIVATE
GENERIC: (log2) ( x -- n ) foldable
@ -46,10 +49,7 @@ PRIVATE>
(log2)
] if ; foldable
GENERIC: zero? ( x -- ? ) foldable
M: object zero? drop f ;
: zero? ( x -- ? ) 0 number= ; inline
: 1+ ( x -- y ) 1 + ; inline
: 1- ( x -- y ) 1 - ; inline
: 2/ ( x -- y ) -1 shift ; inline
@ -60,8 +60,6 @@ M: object zero? drop f ;
: ?1+ [ 1+ ] [ 0 ] if* ; inline
: /f ( x y -- z ) >r >float r> >float float/f ; inline
: rem ( x y -- z ) tuck mod over + swap mod ; foldable
: 2^ ( n -- 2^n ) 1 swap shift ; inline

2
core/math/order/order.factor
View File

@ -42,4 +42,4 @@ M: real after=? ( obj1 obj2 -- ? ) >= ;
: [-] ( x y -- z ) - 0 max ; inline
: compare ( obj1 obj2 quot -- n ) bi@ <=> ; inline
: compare ( obj1 obj2 quot -- symbol ) bi@ <=> ; inline

14
core/sorting/sorting-tests.factor
View File

@ -19,10 +19,10 @@ unit-test
[ 3 ] [ { 1 2 3 4 } midpoint ] unit-test
[ f ] [ 3 { } [ - ] binsearch ] unit-test
[ 0 ] [ 3 { 3 } [ - ] binsearch ] unit-test
[ 1 ] [ 2 { 1 2 3 } [ - ] binsearch ] unit-test
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ - ] binsearch ] unit-test
[ 1 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ - ] binsearch ] unit-test
[ 3 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ - ] binsearch ] unit-test
[ 10 ] [ 10 20 >vector [ - ] binsearch ] unit-test
[ f ] [ 3 { } [ <=> ] binsearch ] unit-test
[ 0 ] [ 3 { 3 } [ <=> ] binsearch ] unit-test
[ 1 ] [ 2 { 1 2 3 } [ <=> ] binsearch ] unit-test
[ 3 ] [ 4 { 1 2 3 4 5 6 } [ <=> ] binsearch ] unit-test
[ 2 ] [ 3.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
[ 4 ] [ 5.5 { 1 2 3 4 5 6 7 8 } [ <=> ] binsearch ] unit-test
[ 10 ] [ 10 20 >vector [ <=> ] binsearch ] unit-test

6
core/sorting/sorting.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2005, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays kernel math sequences vectors math.order
sequences sequences.private growable ;
sequences sequences.private growable math.order ;
IN: sorting
DEFER: sort
@ -58,13 +58,13 @@ PRIVATE>
[ midpoint@ ] keep nth-unsafe ; inline
: partition ( seq n -- slice )
1 < swap halves ? ; inline
+gt+ eq? not swap halves ? ; inline
: (binsearch) ( elt quot seq -- i )
dup length 1 <= [
slice-from 2nip
] [
[ midpoint swap call ] 3keep roll dup zero?
[ midpoint swap call ] 3keep roll dup +eq+ eq?
[ drop dup slice-from swap midpoint@ + 2nip ]
[ partition (binsearch) ] if
] if ; inline

2
extra/builder/release/branch/branch.factor
View File

@ -21,7 +21,7 @@ IN: builder.release.branch
{
"scp"
my-boot-image-name
"factorcode.org:/var/www/factorcode.org/newsite/images/clean"
{ "factorcode.org:/var/www/factorcode.org/newsite/images/clean/" platform }
}
to-strings
try-process ;

1
extra/db/db.factor
View File

@ -35,7 +35,6 @@ HOOK: db-close db ( handle -- )
handle>> db-close
] with-variable ;
! TUPLE: sql sql in-params out-params ;
TUPLE: statement handle sql in-params out-params bind-params bound? type ;
TUPLE: simple-statement < statement ;
TUPLE: prepared-statement < statement ;

2
extra/db/postgresql/lib/lib.factor
View File

@ -154,7 +154,7 @@ M: postgresql-malloc-destructor dispose ( obj -- )
: postgresql-column-typed ( handle row column type -- obj )
dup array? [ first ] when
{
{ +native-id+ [ pq-get-number ] }
{ +db-assigned-id+ [ pq-get-number ] }
{ +random-id+ [ pq-get-number ] }
{ INTEGER [ pq-get-number ] }
{ BIG-INTEGER [ pq-get-number ] }

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

@ -6,6 +6,7 @@ sequences debugger db db.postgresql.lib db.postgresql.ffi
db.tuples db.types tools.annotations math.ranges
combinators sequences.lib classes locals words tools.walker
namespaces.lib accessors random db.queries ;
USE: tools.walker
IN: db.postgresql
TUPLE: postgresql-db < db
@ -48,7 +49,8 @@ M: literal-bind postgresql-bind-conversion ( tuple literal-bind -- obj )
nip value>> <low-level-binding> ;
M: generator-bind postgresql-bind-conversion ( tuple generate-bind -- obj )
nip singleton>> eval-generator <low-level-binding> ;
dup generator-singleton>> eval-generator
[ swap slot-name>> rot set-slot-named ] [ <low-level-binding> ] bi ;
M: postgresql-statement bind-tuple ( tuple statement -- )
tuck in-params>>
@ -158,7 +160,7 @@ M: postgresql-db bind# ( spec obj -- )
M: postgresql-db create-sql-statement ( class -- seq )
[
[ create-table-sql , ] keep
dup db-columns find-primary-key native-id?
dup db-columns find-primary-key db-assigned-id-spec?
[ create-function-sql , ] [ drop ] if
] { } make ;
@ -179,11 +181,11 @@ M: postgresql-db create-sql-statement ( class -- seq )
M: postgresql-db drop-sql-statement ( class -- seq )
[
[ drop-table-sql , ] keep
dup db-columns find-primary-key native-id?
dup db-columns find-primary-key db-assigned-id-spec?
[ drop-function-sql , ] [ drop ] if
] { } make ;
M: postgresql-db <insert-native-statement> ( class -- statement )
M: postgresql-db <insert-db-assigned-statement> ( class -- statement )
[
"select add_" 0% 0%
"(" 0%
@ -193,7 +195,7 @@ M: postgresql-db <insert-native-statement> ( class -- statement )
");" 0%
] query-make ;
M: postgresql-db <insert-nonnative-statement> ( class -- statement )
M: postgresql-db <insert-user-assigned-statement> ( class -- statement )
[
"insert into " 0% 0%
"(" 0%
@ -204,8 +206,10 @@ M: postgresql-db <insert-nonnative-statement> ( class -- statement )
[ ", " 0% ] [
dup type>> +random-id+ = [
[
drop bind-name%
f random-id-generator
bind-name%
slot-name>>
f
random-id-generator
] [ type>> ] bi <generator-bind> 1,
] [
bind%
@ -219,8 +223,8 @@ M: postgresql-db insert-tuple* ( tuple statement -- )
M: postgresql-db persistent-table ( -- hashtable )
H{
{ +native-id+ { "integer" "serial primary key" f } }
{ +assigned-id+ { f f "primary key" } }
{ +db-assigned-id+ { "integer" "serial primary key" f } }
{ +user-assigned-id+ { f f "primary key" } }
{ +random-id+ { "bigint" "bigint primary key" f } }
{ TEXT { "text" "text" f } }
{ VARCHAR { "varchar" "varchar" f } }

71
extra/db/queries/queries.factor
View File

@ -15,7 +15,7 @@ GENERIC: where ( specs obj -- )
: query-make ( class quot -- )
>r sql-props r>
[ 0 sql-counter rot with-variable ] { "" { } { } } nmake
[ 0 sql-counter rot with-variable ";" 0% ] { "" { } { } } nmake
<simple-statement> maybe-make-retryable ; inline
M: db begin-transaction ( -- ) "BEGIN" sql-command ;
@ -35,14 +35,6 @@ M: db <update-tuple-statement> ( class -- statement )
where-primary-key%
] query-make ;
M: db <delete-tuple-statement> ( specs table -- sql )
[
"delete from " 0% 0%
" where " 0%
find-primary-key
dup column-name>> 0% " = " 0% bind%
] query-make ;
M: random-id-generator eval-generator ( singleton -- obj )
drop
system-random-generator get [
@ -52,18 +44,40 @@ M: random-id-generator eval-generator ( singleton -- obj )
: interval-comparison ( ? str -- str )
"from" = " >" " <" ? swap [ "= " append ] when ;
: fp-infinity? ( float -- ? )
dup float? [
double>bits -52 shift 11 2^ 1- [ bitand ] keep =
] [
drop f
] if ;
: (infinite-interval?) ( interval -- ?1 ?2 )
[ from>> ] [ to>> ] bi
[ first fp-infinity? ] bi@ ;
: double-infinite-interval? ( obj -- ? )
dup interval? [ (infinite-interval?) and ] [ drop f ] if ;
: infinite-interval? ( obj -- ? )
dup interval? [ (infinite-interval?) or ] [ drop f ] if ;
: where-interval ( spec obj from/to -- )
pick column-name>> 0%
>r first2 r> interval-comparison 0%
bind# ;
over first fp-infinity? [
3drop
] [
pick column-name>> 0%
>r first2 r> interval-comparison 0%
bind#
] if ;
: in-parens ( quot -- )
"(" 0% call ")" 0% ; inline
M: interval where ( spec obj -- )
[
[ from>> "from" where-interval " and " 0% ]
[ to>> "to" where-interval ] 2bi
[ from>> "from" where-interval ] [
nip infinite-interval? [ " and " 0% ] unless
] [ to>> "to" where-interval ] 2tri
] in-parens ;
M: sequence where ( spec obj -- )
@ -80,12 +94,29 @@ M: integer where ( spec obj -- ) object-where ;
M: string where ( spec obj -- ) object-where ;
: filter-slots ( tuple specs -- specs' )
[
slot-name>> swap get-slot-named
dup double-infinite-interval? [ drop f ] when
] with filter ;
: where-clause ( tuple specs -- )
" where " 0% [
" and " 0%
dupd filter-slots
dup empty? [
2drop
] [
2dup slot-name>> swap get-slot-named where
] interleave drop ;
" where " 0% [
" and " 0%
] [
2dup slot-name>> swap get-slot-named where
] interleave drop
] if ;
M: db <delete-tuple-statement> ( tuple table -- sql )
[
"delete from " 0% 0%
where-clause
] query-make ;
M: db <select-by-slots-statement> ( tuple class -- statement )
[
@ -94,7 +125,5 @@ M: db <select-by-slots-statement> ( tuple class -- statement )
[ dup column-name>> 0% 2, ] interleave
" from " 0% 0%
dupd
[ slot-name>> swap get-slot-named ] with filter
dup empty? [ 2drop ] [ where-clause ] if ";" 0%
where-clause
] query-make ;

1
extra/db/sql/sql.factor
View File

@ -1,7 +1,6 @@
USING: kernel parser quotations classes.tuple words math.order
namespaces.lib namespaces sequences arrays combinators
prettyprint strings math.parser sequences.lib math symbols ;
USE: tools.walker
IN: db.sql
SYMBOLS: insert update delete select distinct columns from as

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

@ -4,7 +4,7 @@ USING: alien.c-types arrays assocs kernel math math.parser
namespaces sequences db.sqlite.ffi db combinators
continuations db.types calendar.format serialize
io.streams.byte-array byte-arrays io.encodings.binary
tools.walker io.backend ;
io.backend ;
IN: db.sqlite.lib
: sqlite-error ( n -- * )
@ -106,7 +106,7 @@ IN: db.sqlite.lib
object>bytes
sqlite-bind-blob-by-name
] }
{ +native-id+ [ sqlite-bind-int-by-name ] }
{ +db-assigned-id+ [ sqlite-bind-int-by-name ] }
{ +random-id+ [ sqlite-bind-int64-by-name ] }
{ NULL [ sqlite-bind-null-by-name ] }
[ no-sql-type ]
@ -132,7 +132,7 @@ IN: db.sqlite.lib
: sqlite-column-typed ( handle index type -- obj )
dup array? [ first ] when
{
{ +native-id+ [ sqlite3_column_int64 ] }
{ +db-assigned-id+ [ sqlite3_column_int64 ] }
{ +random-id+ [ sqlite3-column-uint64 ] }
{ INTEGER [ sqlite3_column_int ] }
{ BIG-INTEGER [ sqlite3_column_int64 ] }

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

@ -79,8 +79,10 @@ M: literal-bind sqlite-bind-conversion ( tuple literal-bind -- array )
<sqlite-low-level-binding> ;
M: generator-bind sqlite-bind-conversion ( tuple generate-bind -- array )
nip [ key>> ] [ singleton>> eval-generator ] [ type>> ] tri
<sqlite-low-level-binding> ;
tuck
[ generator-singleton>> eval-generator tuck ] [ slot-name>> ] bi
rot set-slot-named
>r [ key>> ] [ type>> ] bi r> swap <sqlite-low-level-binding> ;
M: sqlite-statement bind-tuple ( tuple statement -- )
[
@ -129,19 +131,20 @@ M: sqlite-db create-sql-statement ( class -- statement )
M: sqlite-db drop-sql-statement ( class -- statement )
[ "drop table " 0% 0% ";" 0% drop ] query-make ;
M: sqlite-db <insert-native-statement> ( tuple -- statement )
M: sqlite-db <insert-db-assigned-statement> ( tuple -- statement )
[
"insert into " 0% 0%
"(" 0%
maybe-remove-id
remove-db-assigned-id
dup [ ", " 0% ] [ column-name>> 0% ] interleave
") values(" 0%
[ ", " 0% ] [
dup type>> +random-id+ = [
[ slot-name>> ]
[
column-name>> ":" prepend dup 0%
random-id-generator
] [ type>> ] bi <generator-bind> 1,
] [ type>> ] tri <generator-bind> 1,
] [
bind%
] if
@ -149,8 +152,8 @@ M: sqlite-db <insert-native-statement> ( tuple -- statement )
");" 0%
] query-make ;
M: sqlite-db <insert-nonnative-statement> ( tuple -- statement )
<insert-native-statement> ;
M: sqlite-db <insert-user-assigned-statement> ( tuple -- statement )
<insert-db-assigned-statement> ;
M: sqlite-db bind# ( spec obj -- )
>r
@ -163,8 +166,8 @@ M: sqlite-db bind% ( spec -- )
M: sqlite-db persistent-table ( -- assoc )
H{
{ +native-id+ { "integer primary key" "integer primary key" "primary key" } }
{ +assigned-id+ { f f "primary key" } }
{ +db-assigned-id+ { "integer primary key" "integer primary key" "primary key" } }
{ +user-assigned-id+ { f f "primary key" } }
{ +random-id+ { "integer primary key" "integer primary key" "primary key" } }
{ INTEGER { "integer" "integer" "primary key" } }
{ BIG-INTEGER { "bigint" "bigint" } }

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

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: io.files kernel tools.test db db.tuples classes
db.types continuations namespaces math math.ranges
prettyprint tools.walker calendar sequences db.sqlite
math.intervals db.postgresql accessors random math.bitfields.lib ;
prettyprint calendar sequences db.sqlite math.intervals
db.postgresql accessors random math.bitfields.lib ;
IN: db.tuples.tests
TUPLE: person the-id the-name the-number the-real
@ -21,7 +21,7 @@ ts date time blob factor-blob ;
set-person-factor-blob
} person construct ;
: <assigned-person> ( id name age real ts date time blob factor-blob -- person )
: <user-assigned-person> ( id name age real ts date time blob factor-blob -- person )
<person> [ set-person-the-id ] keep ;
SYMBOL: person1
@ -30,6 +30,7 @@ SYMBOL: person3
SYMBOL: person4
: test-tuples ( -- )
[ ] [ person recreate-table ] unit-test
[ ] [ person ensure-table ] unit-test
[ ] [ person drop-table ] unit-test
[ ] [ person create-table ] unit-test
@ -106,10 +107,10 @@ SYMBOL: person4
[ ] [ person drop-table ] unit-test ;
: native-person-schema ( -- )
: db-assigned-person-schema ( -- )
person "PERSON"
{
{ "the-id" "ID" +native-id+ }
{ "the-id" "ID" +db-assigned-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
@ -132,10 +133,10 @@ SYMBOL: person4
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <person> person4 set ;
: assigned-person-schema ( -- )
: user-assigned-person-schema ( -- )
person "PERSON"
{
{ "the-id" "ID" INTEGER +assigned-id+ }
{ "the-id" "ID" INTEGER +user-assigned-id+ }
{ "the-name" "NAME" { VARCHAR 256 } +not-null+ }
{ "the-number" "AGE" INTEGER { +default+ 0 } }
{ "the-real" "REAL" DOUBLE { +default+ 0.3 } }
@ -145,27 +146,27 @@ SYMBOL: person4
{ "blob" "B" BLOB }
{ "factor-blob" "FB" FACTOR-BLOB }
} define-persistent
1 "billy" 10 3.14 f f f f f <assigned-person> person1 set
2 "johnny" 10 3.14 f f f f f <assigned-person> person2 set
1 "billy" 10 3.14 f f f f f <user-assigned-person> person1 set
2 "johnny" 10 3.14 f f f f f <user-assigned-person> person2 set
3 "teddy" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
B{ 115 116 111 114 101 105 110 97 98 108 111 98 }
f <assigned-person> person3 set
f <user-assigned-person> person3 set
4 "eddie" 10 3.14
T{ timestamp f 2008 3 5 16 24 11 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f 2008 11 22 0 0 0 T{ duration f 0 0 0 0 0 0 } }
T{ timestamp f f f f 12 34 56 T{ duration f 0 0 0 0 0 0 } }
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <assigned-person> person4 set ;
f H{ { 1 2 } { 3 4 } { 5 "lol" } } <user-assigned-person> person4 set ;
TUPLE: paste n summary author channel mode contents timestamp annotations ;
TUPLE: annotation n paste-id summary author mode contents ;
: native-paste-schema ( -- )
: db-assigned-paste-schema ( -- )
paste "PASTE"
{
{ "n" "ID" +native-id+ }
{ "n" "ID" +db-assigned-id+ }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
{ "channel" "CHANNEL" TEXT }
@ -177,7 +178,7 @@ TUPLE: annotation n paste-id summary author mode contents ;
annotation "ANNOTATION"
{
{ "n" "ID" +native-id+ }
{ "n" "ID" +db-assigned-id+ }
{ "paste-id" "PASTE_ID" INTEGER { +foreign-id+ paste "n" } }
{ "summary" "SUMMARY" TEXT }
{ "author" "AUTHOR" TEXT }
@ -210,7 +211,7 @@ TUPLE: serialize-me id data ;
: test-serialize ( -- )
serialize-me "SERIALIZED"
{
{ "id" "ID" +native-id+ }
{ "id" "ID" +db-assigned-id+ }
{ "data" "DATA" FACTOR-BLOB }
} define-persistent
[ serialize-me drop-table ] [ drop ] recover
@ -226,7 +227,7 @@ TUPLE: exam id name score ;
: test-intervals ( -- )
exam "EXAM"
{
{ "id" "ID" +native-id+ }
{ "id" "ID" +db-assigned-id+ }
{ "name" "NAME" TEXT }
{ "score" "SCORE" INTEGER }
} define-persistent
@ -292,6 +293,46 @@ TUPLE: exam id name score ;
}
] [
T{ exam f T{ range f 1 3 1 } } select-tuples
] unit-test
[
{
T{ exam f 2 "Stan" 80 }
T{ exam f 3 "Kenny" 60 }
T{ exam f 4 "Cartman" 41 }
}
] [
T{ exam f T{ interval f { 2 t } { 1.0/0.0 f } } } select-tuples
] unit-test
[
{
T{ exam f 1 "Kyle" 100 }
}
] [
T{ exam f T{ interval f { -1.0/0.0 t } { 2 f } } } select-tuples
] unit-test
[
{
T{ exam f 1 "Kyle" 100 }
T{ exam f 2 "Stan" 80 }
T{ exam f 3 "Kenny" 60 }
T{ exam f 4 "Cartman" 41 }
}
] [
T{ exam f T{ interval f { -1.0/0.0 t } { 1/0. f } } } select-tuples
] unit-test
[
{
T{ exam f 1 "Kyle" 100 }
T{ exam f 2 "Stan" 80 }
T{ exam f 3 "Kenny" 60 }
T{ exam f 4 "Cartman" 41 }
}
] [
T{ exam } select-tuples
] unit-test ;
TUPLE: bignum-test id m n o ;
@ -304,7 +345,7 @@ TUPLE: bignum-test id m n o ;
: test-bignum
bignum-test "BIGNUM_TEST"
{
{ "id" "ID" +native-id+ }
{ "id" "ID" +db-assigned-id+ }
{ "m" "M" BIG-INTEGER }
{ "n" "N" UNSIGNED-BIG-INTEGER }
{ "o" "O" SIGNED-BIG-INTEGER }
@ -328,9 +369,9 @@ C: <secret> secret
{ "message" "MESSAGE" TEXT }
} define-persistent
[ ] [ secret ensure-table ] unit-test
[ ] [ secret recreate-table ] unit-test
[ ] [ f "kilroy was here" <secret> insert-tuple ] unit-test
[ t ] [ f "kilroy was here" <secret> [ insert-tuple ] keep n>> integer? ] unit-test
[ ] [ f "kilroy was here2" <secret> insert-tuple ] unit-test
@ -345,17 +386,17 @@ C: <secret> secret
T{ secret } select-tuples length 3 =
] unit-test ;
[ native-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-tuples ] test-sqlite
[ assigned-person-schema test-repeated-insert ] test-sqlite
[ db-assigned-person-schema test-tuples ] test-sqlite
[ user-assigned-person-schema test-tuples ] test-sqlite
[ user-assigned-person-schema test-repeated-insert ] test-sqlite
[ test-bignum ] test-sqlite
[ test-serialize ] test-sqlite
[ test-intervals ] test-sqlite
[ test-random-id ] test-sqlite
[ native-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-tuples ] test-postgresql
[ assigned-person-schema test-repeated-insert ] test-postgresql
[ db-assigned-person-schema test-tuples ] test-postgresql
[ user-assigned-person-schema test-tuples ] test-postgresql
[ user-assigned-person-schema test-repeated-insert ] test-postgresql
[ test-bignum ] test-postgresql
[ test-serialize ] test-postgresql
[ test-intervals ] test-postgresql

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

@ -3,7 +3,7 @@
USING: arrays assocs classes db kernel namespaces
classes.tuple words sequences slots math accessors
math.parser io prettyprint db.types continuations
mirrors sequences.lib tools.walker combinators.lib ;
mirrors sequences.lib combinators.lib ;
IN: db.tuples
: define-persistent ( class table columns -- )
@ -37,15 +37,10 @@ SYMBOL: sql-counter
HOOK: create-sql-statement db ( class -- obj )
HOOK: drop-sql-statement db ( class -- obj )
HOOK: <insert-native-statement> db ( class -- obj )
HOOK: <insert-nonnative-statement> db ( class -- obj )
HOOK: <insert-db-assigned-statement> db ( class -- obj )
HOOK: <insert-user-assigned-statement> db ( class -- obj )
HOOK: <update-tuple-statement> db ( class -- obj )
HOOK: <update-tuples-statement> db ( class -- obj )
HOOK: <delete-tuple-statement> db ( class -- obj )
HOOK: <delete-tuples-statement> db ( class -- obj )
HOOK: <delete-tuple-statement> db ( tuple class -- obj )
HOOK: <select-by-slots-statement> db ( tuple class -- tuple )
HOOK: insert-tuple* db ( tuple statement -- )
@ -65,7 +60,7 @@ SINGLETON: retryable
[ bind-params>> ] [ in-params>> ] bi
[
dup generator-bind? [
singleton>> eval-generator >>value
generator-singleton>> eval-generator >>value
] [
drop
] if
@ -113,25 +108,28 @@ M: retryable execute-statement* ( statement type -- )
: drop-table ( class -- )
drop-sql-statement [ execute-statement ] with-disposals ;
: ensure-table ( class -- )
: recreate-table ( class -- )
[
drop-sql-statement make-nonthrowable
[ execute-statement ] with-disposals
] [ create-table ] bi ;
: insert-native ( tuple -- )
: ensure-table ( class -- )
[ create-table ] curry ignore-errors ;
: insert-db-assigned-statement ( tuple -- )
dup class
db get db-insert-statements [ <insert-native-statement> ] cache
db get db-insert-statements [ <insert-db-assigned-statement> ] cache
[ bind-tuple ] 2keep insert-tuple* ;
: insert-nonnative ( tuple -- )
: insert-user-assigned-statement ( tuple -- )
dup class
db get db-insert-statements [ <insert-nonnative-statement> ] cache
db get db-insert-statements [ <insert-user-assigned-statement> ] cache
[ bind-tuple ] keep execute-statement ;
: insert-tuple ( tuple -- )
dup class db-columns find-primary-key nonnative-id?
[ insert-nonnative ] [ insert-native ] if ;
dup class db-columns find-primary-key db-assigned-id-spec?
[ insert-db-assigned-statement ] [ insert-user-assigned-statement ] if ;
: update-tuple ( tuple -- )
dup class
@ -139,9 +137,9 @@ M: retryable execute-statement* ( statement type -- )
[ bind-tuple ] keep execute-statement ;
: delete-tuple ( tuple -- )
dup class
db get db-delete-statements [ <delete-tuple-statement> ] cache
[ bind-tuple ] keep execute-statement ;
dup dup class <delete-tuple-statement> [
[ bind-tuple ] keep execute-statement
] with-disposal ;
: select-tuples ( tuple -- tuples )
dup dup class <select-by-slots-statement> [

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

@ -2,8 +2,8 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays assocs db kernel math math.parser
sequences continuations sequences.deep sequences.lib
words namespaces tools.walker slots slots.private classes
mirrors classes.tuple combinators calendar.format symbols
words namespaces slots slots.private classes mirrors
classes.tuple combinators calendar.format symbols
classes.singleton accessors quotations random ;
IN: db.types
@ -15,18 +15,17 @@ TUPLE: sql-spec class slot-name column-name type primary-key modifiers ;
TUPLE: literal-bind key type value ;
C: <literal-bind> literal-bind
TUPLE: generator-bind key singleton type ;
TUPLE: generator-bind slot-name key generator-singleton type ;
C: <generator-bind> generator-bind
SINGLETON: random-id-generator
TUPLE: low-level-binding value ;
C: <low-level-binding> low-level-binding
SINGLETON: +native-id+
SINGLETON: +assigned-id+
SINGLETON: +db-assigned-id+
SINGLETON: +user-assigned-id+
SINGLETON: +random-id+
UNION: +primary-key+ +native-id+ +assigned-id+ +random-id+ ;
UNION: +nonnative-id+ +random-id+ +assigned-id+ ;
UNION: +primary-key+ +db-assigned-id+ +user-assigned-id+ +random-id+ ;
SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
+foreign-id+ +has-many+ ;
@ -43,11 +42,11 @@ SYMBOLS: +autoincrement+ +serial+ +unique+ +default+ +null+ +not-null+
: primary-key? ( spec -- ? )
primary-key>> +primary-key+? ;
: native-id? ( spec -- ? )
primary-key>> +native-id+? ;
: db-assigned-id-spec? ( spec -- ? )
primary-key>> +db-assigned-id+? ;
: nonnative-id? ( spec -- ? )
primary-key>> +nonnative-id+? ;
: assigned-id-spec? ( spec -- ? )
primary-key>> +user-assigned-id+? ;
: normalize-spec ( spec -- )
dup type>> dup +primary-key+? [
@ -82,8 +81,8 @@ FACTOR-BLOB NULL ;
: number>string* ( n/str -- str )
dup number? [ number>string ] when ;
: maybe-remove-id ( specs -- obj )
[ +native-id+? not ] filter ;
: remove-db-assigned-id ( specs -- obj )
[ +db-assigned-id+? not ] filter ;
: remove-relations ( specs -- newcolumns )
[ relation? not ] filter ;

2
extra/help/help-docs.factor
View File

@ -113,7 +113,7 @@ ARTICLE: "help" "Help system"
"The help system maintains documentation written in a simple markup language, along with cross-referencing and search. Documentation can either exist as free-standing " { $emphasis "articles" } " or be associated with words."
{ $subsection "browsing-help" }
{ $subsection "writing-help" }
{ $subsection "help.lint" }
{ $vocab-subsection "Help lint tool" "help.lint" }
{ $subsection "help-impl" } ;
IN: help

4
extra/http/http-tests.factor
View File

@ -194,7 +194,7 @@ test-db [
<dispatcher>
<action> <protected>
<login>
<session-manager>
<sessions>
sessions-in-db >>sessions
"" add-responder
add-quit-action
@ -225,7 +225,7 @@ test-db [
<dispatcher>
<action> [ "text/plain" <content> [ "Hi" write ] >>body ] >>display
<login>
<session-manager>
<sessions>
sessions-in-db >>sessions
"" add-responder
add-quit-action

2
extra/http/server/auth/providers/db/db.factor
View File

@ -7,7 +7,7 @@ IN: http.server.auth.providers.db
user "USERS"
{
{ "username" "USERNAME" { VARCHAR 256 } +assigned-id+ }
{ "username" "USERNAME" { VARCHAR 256 } +user-assigned-id+ }
{ "realname" "REALNAME" { VARCHAR 256 } }
{ "password" "PASSWORD" { VARCHAR 256 } +not-null+ }
{ "email" "EMAIL" { VARCHAR 256 } }

61
extra/http/server/sessions/sessions-tests.factor
View File

@ -1,16 +1,12 @@
IN: http.server.sessions.tests
USING: tools.test http http.server.sessions
http.server.sessions.storage http.server.sessions.storage.db
http.server.actions http.server math namespaces kernel accessors
prettyprint io.streams.string io.files splitting destructors
sequences db db.sqlite continuations ;
: with-session
[
>r
[ session-manager get swap save-session-after ]
[ \ session set ] bi
r> call
>r [ save-session-after ] [ session set ] bi r> call
] with-destructors ; inline
TUPLE: foo ;
@ -31,18 +27,18 @@ M: foo call-responder*
"id" get session-id-key set-query-param
"/" >>path
request set
{ } session-manager get call-responder
{ } sessions get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
: session-manager-mock-test
: sessions-mock-test
[
<request>
"GET" >>method
"cookies" get >>cookies
"/" >>path
request set
{ } session-manager get call-responder
{ } sessions get call-responder
[ write-response-body drop ] with-string-writer
] with-destructors ;
@ -60,14 +56,15 @@ M: foo call-responder*
init-sessions-table
[ ] [
<foo> <session-manager>
sessions-in-db >>sessions
session-manager set
<foo> <sessions>
sessions set
] unit-test
[
empty-session
123 >>id session set
[ ] [
empty-session
123 >>id session set
] unit-test
[ ] [ 3 "x" sset ] unit-test
@ -81,39 +78,38 @@ M: foo call-responder*
] with-scope
[ t ] [
session-manager get begin-session id>>
session-manager get sessions>> get-session session?
begin-session id>>
get-session session?
] unit-test
[ { 5 0 } ] [
[
session-manager get begin-session
begin-session
dup [ 5 "a" sset ] with-session
dup [ "a" sget , ] with-session
dup [ "x" sget , ] with-session
id>> session-manager get sessions>> delete-session
drop
] { } make
] unit-test
[ 0 ] [
session-manager get begin-session id>>
session-manager get sessions>> get-session [ "x" sget ] with-session
begin-session id>>
get-session [ "x" sget ] with-session
] unit-test
[ { 5 0 } ] [
[
session-manager get begin-session id>>
dup session-manager get sessions>> get-session [ 5 "a" sset ] with-session
dup session-manager get sessions>> get-session [ "a" sget , ] with-session
dup session-manager get sessions>> get-session [ "x" sget , ] with-session
session-manager get sessions>> delete-session
begin-session id>>
dup get-session [ 5 "a" sset ] with-session
dup get-session [ "a" sget , ] with-session
dup get-session [ "x" sget , ] with-session
drop
] { } make
] unit-test
[ ] [
<foo> <session-manager>
sessions-in-db >>sessions
session-manager set
<foo> <sessions>
sessions set
] unit-test
[
@ -121,7 +117,7 @@ M: foo call-responder*
"GET" >>method
"/" >>path
request set
{ "etc" } session-manager get call-responder response set
{ "etc" } sessions get call-responder response set
[ "1" ] [ [ response get write-response-body drop ] with-string-writer ] unit-test
response get
] with-destructors
@ -129,9 +125,9 @@ M: foo call-responder*
[ ] [ response get cookies>> "cookies" set ] unit-test
[ "2" ] [ session-manager-mock-test ] unit-test
[ "3" ] [ session-manager-mock-test ] unit-test
[ "4" ] [ session-manager-mock-test ] unit-test
[ "2" ] [ sessions-mock-test ] unit-test
[ "3" ] [ sessions-mock-test ] unit-test
[ "4" ] [ sessions-mock-test ] unit-test
[
[ ] [
@ -142,8 +138,7 @@ M: foo call-responder*
request set
[
{ } <exiting-action> <session-manager>
sessions-in-db >>sessions
{ } <exiting-action> <sessions>
call-responder
] with-destructors response set
] unit-test

101
extra/http/server/sessions/sessions.factor
View File

@ -1,13 +1,10 @@
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel math.parser namespaces random
accessors quotations hashtables sequences continuations
fry calendar combinators destructors
http
http.server
http.server.sessions.storage
http.server.sessions.storage.null
html.elements ;
USING: assocs kernel math.intervals math.parser namespaces
random accessors quotations hashtables sequences continuations
fry calendar combinators destructors alarms
db db.tuples db.types
http http.server html.elements ;
IN: http.server.sessions
TUPLE: session id expires namespace changed? ;
@ -16,6 +13,28 @@ TUPLE: session id expires namespace changed? ;
session new
swap >>id ;
session "SESSIONS"
{
{ "id" "ID" +random-id+ system-random-generator }
{ "expires" "EXPIRES" BIG-INTEGER +not-null+ }
{ "namespace" "NAMESPACE" FACTOR-BLOB }
} define-persistent
: get-session ( id -- session )
dup [ <session> select-tuple ] when ;
: init-sessions-table session ensure-table ;
: expired-sessions ( -- session )
f <session>
-1.0/0.0 now timestamp>millis [a,b] >>expires
select-tuples ;
: start-expiring-sessions ( db seq -- )
'[
, , [ expired-sessions [ delete-tuple ] each ] with-db
] 5 minutes every drop ;
GENERIC: init-session* ( responder -- )
M: object init-session* drop ;
@ -24,12 +43,11 @@ M: dispatcher init-session* default>> init-session* ;
M: filter-responder init-session* responder>> init-session* ;
TUPLE: session-manager < filter-responder sessions timeout domain ;
TUPLE: sessions < filter-responder timeout domain ;
: <session-manager> ( responder -- responder' )
session-manager new
: <sessions> ( responder -- responder' )
sessions new
swap >>responder
null-sessions >>sessions
20 minutes >>timeout ;
: (session-changed) ( session -- )
@ -50,11 +68,11 @@ TUPLE: session-manager < filter-responder sessions timeout domain ;
[ namespace>> swap change-at ] keep
(session-changed) ; inline
: init-session ( session managed -- )
>r session r> '[ , init-session* ] with-variable ;
: init-session ( session -- )
session [ sessions get init-session* ] with-variable ;
: cutoff-time ( -- time )
session-manager get timeout>> from-now timestamp>millis ;
sessions get timeout>> from-now timestamp>millis ;
: touch-session ( session -- )
cutoff-time >>expires drop ;
@ -64,57 +82,50 @@ TUPLE: session-manager < filter-responder sessions timeout domain ;
H{ } clone >>namespace
dup touch-session ;
: begin-session ( responder -- session )
>r empty-session r>
[ init-session ]
[ sessions>> new-session ]
[ drop ]
2tri ;
: begin-session ( -- session )
empty-session [ init-session ] [ insert-tuple ] [ ] tri ;
! Destructor
TUPLE: session-saver manager session ;
TUPLE: session-saver session ;
C: <session-saver> session-saver
M: session-saver dispose
[ session>> ] [ manager>> sessions>> ] bi
over changed?>> [
[ drop touch-session ] [ update-session ] 2bi
] [ 2drop ] if ;
session>> dup changed?>> [
[ touch-session ] [ update-tuple ] bi
] [ drop ] if ;
: save-session-after ( manager session -- )
: save-session-after ( session -- )
<session-saver> add-always-destructor ;
: existing-session ( path manager session -- response )
[ nip session set ]
[ save-session-after ]
[ drop responder>> ] 2tri
call-responder ;
: existing-session ( path session -- response )
[ session set ] [ save-session-after ] bi
sessions get responder>> call-responder ;
: session-id-key "factorsessid" ;
: cookie-session-id ( -- id/f )
request get session-id-key get-cookie
: cookie-session-id ( request -- id/f )
session-id-key get-cookie
dup [ value>> string>number ] when ;
: post-session-id ( -- id/f )
session-id-key request get post-data>> at string>number ;
: post-session-id ( request -- id/f )
session-id-key swap post-data>> at string>number ;
: request-session-id ( -- id/f )
request get method>> {
request get dup method>> {
{ "GET" [ cookie-session-id ] }
{ "HEAD" [ cookie-session-id ] }
{ "POST" [ post-session-id ] }
} case ;
: request-session ( responder -- session/f )
>r request-session-id r> sessions>> get-session ;
: request-session ( -- session/f )
request-session-id get-session ;
: <session-cookie> ( id -- cookie )
session-id-key <cookie>
"$session-manager" resolve-base-path >>path
session-manager get timeout>> from-now >>expires
session-manager get domain>> >>domain ;
"$sessions" resolve-base-path >>path
sessions get timeout>> from-now >>expires
sessions get domain>> >>domain ;
: put-session-cookie ( response -- response' )
session get id>> number>string <session-cookie> put-cookie ;
@ -126,8 +137,8 @@ M: session-saver dispose
session get id>> number>string =value
input/> ;
M: session-manager call-responder* ( path responder -- response )
M: sessions call-responder* ( path responder -- response )
[ session-form-field ] add-form-hook
dup session-manager set
dup request-session [ dup begin-session ] unless*
sessions set
request-session [ begin-session ] unless*
existing-session put-session-cookie ;

40
extra/http/server/sessions/storage/db/db.factor
View File

@ -1,40 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs accessors kernel http.server.sessions.storage
http.server.sessions http.server db db.tuples db.types math.parser
math.intervals fry random calendar sequences alarms ;
IN: http.server.sessions.storage.db
SINGLETON: sessions-in-db
session "SESSIONS"
{
! { "id" "ID" +random-id+ system-random-generator }
{ "id" "ID" INTEGER +native-id+ }
{ "expires" "EXPIRES" BIG-INTEGER +not-null+ }
{ "namespace" "NAMESPACE" FACTOR-BLOB }
} define-persistent
: init-sessions-table session ensure-table ;
M: sessions-in-db get-session ( id storage -- session/f )
drop dup [ <session> select-tuple ] when ;
M: sessions-in-db update-session ( session storage -- )
drop update-tuple ;
M: sessions-in-db delete-session ( id storage -- )
drop <session> delete-tuple ;
M: sessions-in-db new-session ( session storage -- )
drop insert-tuple ;
: expired-sessions ( -- session )
f <session>
USE: math now timestamp>millis [ 60 60 * 1000 * - ] keep [a,b] >>expires
select-tuples ;
: start-expiring-sessions ( db seq -- )
'[
, , [ expired-sessions [ delete-tuple ] each ] with-db
] 5 minutes every drop ;

16
extra/http/server/sessions/storage/null/null.factor
View File

@ -1,16 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel http.server.sessions.storage ;
IN: http.server.sessions.storage.null
SINGLETON: null-sessions
: null-sessions-error "No session storage installed" throw ;
M: null-sessions get-session null-sessions-error ;
M: null-sessions update-session null-sessions-error ;
M: null-sessions delete-session null-sessions-error ;
M: null-sessions new-session null-sessions-error ;

12
extra/http/server/sessions/storage/storage.factor
View File

@ -1,12 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: calendar ;
IN: http.server.sessions.storage
GENERIC: get-session ( id storage -- session )
GENERIC: update-session ( session storage -- )
GENERIC: delete-session ( id storage -- )
GENERIC: new-session ( session storage -- )

8
extra/locals/locals-docs.factor
View File

@ -120,9 +120,11 @@ $nl
"Another limitation is that closure conversion does not descend into arrays, hashtables or other types of literals. For example, the following does not work:"
{ $code
":: bad-cond-usage ( a -- ... )"
" { [ a 0 < ] [ ... ] }"
" { [ a 0 > ] [ ... ] }"
" { [ a 0 = ] [ ... ] } ;"
" {"
" { [ a 0 < ] [ ... ] }"
" { [ a 0 > ] [ ... ] }"
" { [ a 0 = ] [ ... ] }"
" } cond ;"
} ;
ARTICLE: "locals" "Local variables and lexical closures"

4
extra/math/functions/functions.factor
View File

@ -80,10 +80,6 @@ M: integer (^)
-rot (^mod)
] if ; foldable
GENERIC: abs ( x -- y ) foldable
M: real abs dup 0 < [ neg ] when ;
GENERIC: absq ( x -- y ) foldable
M: real absq sq ;

1
extra/math/ratios/ratios.factor
View File

@ -47,5 +47,6 @@ M: ratio - 2dup scale - -rot ratio+d / ;
M: ratio * 2>fraction * >r * r> / ;
M: ratio / scale / ;
M: ratio /i scale /i ;
M: ratio /f scale /f ;
M: ratio mod 2dup >r >r /i r> r> rot * - ;
M: ratio /mod [ /i ] 2keep mod ;

162
extra/peg/ebnf/ebnf-tests.factor
View File

@ -1,15 +1,16 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf words math math.parser sequences ;
USING: kernel tools.test peg peg.ebnf words math math.parser
sequences accessors ;
IN: peg.ebnf.tests
{ T{ ebnf-non-terminal f "abc" } } [
"abc" 'non-terminal' parse parse-result-ast
"abc" 'non-terminal' parse ast>>
] unit-test
{ T{ ebnf-terminal f "55" } } [
"'55'" 'terminal' parse parse-result-ast
"'55'" 'terminal' parse ast>>
] unit-test
{
@ -20,7 +21,7 @@ IN: peg.ebnf.tests
}
}
} [
"digit = '1' | '2'" 'rule' parse parse-result-ast
"digit = '1' | '2'" 'rule' parse ast>>
] unit-test
{
@ -31,7 +32,7 @@ IN: peg.ebnf.tests
}
}
} [
"digit = '1' '2'" 'rule' parse parse-result-ast
"digit = '1' '2'" 'rule' parse ast>>
] unit-test
{
@ -44,20 +45,22 @@ IN: peg.ebnf.tests
}
}
} [
"one two | three" 'choice' parse parse-result-ast
"one two | three" 'choice' parse ast>>
] unit-test
{
T{ ebnf-sequence f
V{
T{ ebnf-non-terminal f "one" }
T{ ebnf-choice f
V{ T{ ebnf-non-terminal f "two" } T{ ebnf-non-terminal f "three" } }
T{ ebnf-whitespace f
T{ ebnf-choice f
V{ T{ ebnf-non-terminal f "two" } T{ ebnf-non-terminal f "three" } }
}
}
}
}
} [
"one (two | three)" 'choice' parse parse-result-ast
"one {two | three}" 'choice' parse ast>>
] unit-test
{
@ -77,7 +80,7 @@ IN: peg.ebnf.tests
}
}
} [
"one ((two | three) four)*" 'choice' parse parse-result-ast
"one ((two | three) four)*" 'choice' parse ast>>
] unit-test
{
@ -89,43 +92,43 @@ IN: peg.ebnf.tests
}
}
} [
"one ( two )? three" 'choice' parse parse-result-ast
"one ( two )? three" 'choice' parse ast>>
] unit-test
{ "foo" } [
"\"foo\"" 'identifier' parse parse-result-ast
"\"foo\"" 'identifier' parse ast>>
] unit-test
{ "foo" } [
"'foo'" 'identifier' parse parse-result-ast
"'foo'" 'identifier' parse ast>>
] unit-test
{ "foo" } [
"foo" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
"foo" 'non-terminal' parse ast>> ebnf-non-terminal-symbol
] unit-test
{ "foo" } [
"foo]" 'non-terminal' parse parse-result-ast ebnf-non-terminal-symbol
"foo]" 'non-terminal' parse ast>> ebnf-non-terminal-symbol
] unit-test
{ V{ "a" "b" } } [
"ab" [EBNF foo='a' 'b' EBNF] call parse-result-ast
"ab" [EBNF foo='a' 'b' EBNF] call ast>>
] unit-test
{ V{ 1 "b" } } [
"ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call parse-result-ast
"ab" [EBNF foo=('a')[[ drop 1 ]] 'b' EBNF] call ast>>
] unit-test
{ V{ 1 2 } } [
"ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call parse-result-ast
"ab" [EBNF foo=('a') [[ drop 1 ]] ('b') [[ drop 2 ]] EBNF] call ast>>
] unit-test
{ CHAR: A } [
"A" [EBNF foo=[A-Z] EBNF] call parse-result-ast
"A" [EBNF foo=[A-Z] EBNF] call ast>>
] unit-test
{ CHAR: Z } [
"Z" [EBNF foo=[A-Z] EBNF] call parse-result-ast
"Z" [EBNF foo=[A-Z] EBNF] call ast>>
] unit-test
{ f } [
@ -133,7 +136,7 @@ IN: peg.ebnf.tests
] unit-test
{ CHAR: 0 } [
"0" [EBNF foo=[^A-Z] EBNF] call parse-result-ast
"0" [EBNF foo=[^A-Z] EBNF] call ast>>
] unit-test
{ f } [
@ -145,31 +148,31 @@ IN: peg.ebnf.tests
] unit-test
{ V{ "1" "+" "foo" } } [
"1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] call parse-result-ast
"1+1" [EBNF foo='1' '+' '1' [[ drop "foo" ]] EBNF] call ast>>
] unit-test
{ "foo" } [
"1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] call parse-result-ast
"1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] EBNF] call ast>>
] unit-test
{ "foo" } [
"1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
"1+1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call ast>>
] unit-test
{ "bar" } [
"1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call parse-result-ast
"1-1" [EBNF foo='1' '+' '1' => [[ drop "foo" ]] | '1' '-' '1' => [[ drop "bar" ]] EBNF] call ast>>
] unit-test
{ 6 } [
"4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call parse-result-ast
"4+2" [EBNF num=[0-9] => [[ digit> ]] foo=num:x '+' num:y => [[ drop x y + ]] EBNF] call ast>>
] unit-test
{ 6 } [
"4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call parse-result-ast
"4+2" [EBNF foo=[0-9]:x '+' [0-9]:y => [[ drop x digit> y digit> + ]] EBNF] call ast>>
] unit-test
{ 10 } [
{ 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
{ 1 2 3 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call ast>>
] unit-test
{ f } [
@ -177,7 +180,7 @@ IN: peg.ebnf.tests
] unit-test
{ 3 } [
{ 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call parse-result-ast
{ 1 2 "a" 4 } [EBNF num=. ?[ number? ]? list=list:x num:y => [[ drop x y + ]] | num EBNF] call ast>>
] unit-test
{ f } [
@ -185,44 +188,44 @@ IN: peg.ebnf.tests
] unit-test
{ V{ "a" " " "b" } } [
"a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
"a b" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
] unit-test
{ V{ "a" "\t" "b" } } [
"a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
"a\tb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
] unit-test
{ V{ "a" "\n" "b" } } [
"a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call parse-result-ast
"a\nb" [EBNF -=" " | "\t" | "\n" foo="a" - "b" EBNF] call ast>>
] unit-test
{ V{ "a" f "b" } } [
"ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
"ab" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
] unit-test
{ V{ "a" " " "b" } } [
"a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
"a b" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
] unit-test
{ V{ "a" "\t" "b" } } [
"a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
"a\tb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
] unit-test
{ V{ "a" "\n" "b" } } [
"a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call parse-result-ast
"a\nb" [EBNF -=" " | "\t" | "\n" foo="a" (-)? "b" EBNF] call ast>>
] unit-test
{ V{ "a" "b" } } [
"ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
"ab" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
] unit-test
{ V{ "a" "b" } } [
"a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
"a\tb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
] unit-test
{ V{ "a" "b" } } [
"a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call parse-result-ast
"a\nb" [EBNF -=(" " | "\t" | "\n")? => [[ drop ignore ]] foo="a" - "b" EBNF] call ast>>
] unit-test
{ f } [
@ -232,19 +235,19 @@ IN: peg.ebnf.tests
{ V{ V{ 49 } "+" V{ 49 } } } [
#! Test direct left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
"1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
"1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ast>>
] unit-test
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
#! Test direct left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
"1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call parse-result-ast
"1+1+1" [EBNF num=([0-9])+ expr=expr "+" num | num EBNF] call ast>>
] unit-test
{ V{ V{ V{ 49 } "+" V{ 49 } } "+" V{ 49 } } } [
#! Test indirect left recursion.
#! Using packrat, so first part of expr fails, causing 2nd choice to be used
"1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call parse-result-ast
"1+1+1" [EBNF num=([0-9])+ x=expr expr=x "+" num | num EBNF] call ast>>
] unit-test
{ t } [
@ -277,23 +280,88 @@ main = Primary
;EBNF
{ "this" } [
"this" primary parse-result-ast
"this" primary ast>>
] unit-test
{ V{ "this" "." "x" } } [
"this.x" primary parse-result-ast
"this.x" primary ast>>
] unit-test
{ V{ V{ "this" "." "x" } "." "y" } } [
"this.x.y" primary parse-result-ast
"this.x.y" primary ast>>
] unit-test
{ V{ V{ "this" "." "x" } "." "m" "(" ")" } } [
"this.x.m()" primary parse-result-ast
"this.x.m()" primary ast>>
] unit-test
{ V{ V{ V{ "x" "[" "i" "]" } "[" "j" "]" } "." "y" } } [
"x[i][j].y" primary parse-result-ast
"x[i][j].y" primary ast>>
] unit-test
'ebnf' compile must-infer
{ V{ V{ "a" "b" } "c" } } [
"abc" [EBNF a="a" "b" foo=(a "c") EBNF] call ast>>
] unit-test
{ V{ V{ "a" "b" } "c" } } [
"abc" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>>
] unit-test
{ V{ V{ "a" "b" } "c" } } [
"abc" [EBNF a="a" "b" foo=a "c" EBNF] call ast>>
] unit-test
{ f } [
"a bc" [EBNF a="a" "b" foo=(a "c") EBNF] call
] unit-test
{ f } [
"a bc" [EBNF a="a" "b" foo=a "c" EBNF] call
] unit-test
{ f } [
"a bc" [EBNF a="a" "b" foo={a "c"} EBNF] call
] unit-test
{ f } [
"ab c" [EBNF a="a" "b" foo=a "c" EBNF] call
] unit-test
{ V{ V{ "a" "b" } "c" } } [
"ab c" [EBNF a="a" "b" foo={a "c"} EBNF] call ast>>
] unit-test
{ f } [
"ab c" [EBNF a="a" "b" foo=(a "c") EBNF] call
] unit-test
{ f } [
"a b c" [EBNF a="a" "b" foo=a "c" EBNF] call
] unit-test
{ f } [
"a b c" [EBNF a="a" "b" foo=(a "c") EBNF] call
] unit-test
{ f } [
"a b c" [EBNF a="a" "b" foo={a "c"} EBNF] call
] unit-test
{ V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [
"ab cab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>>
] unit-test
{ V{ } } [
"ab cab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>>
] unit-test
{ V{ V{ V{ "a" "b" } "c" } V{ V{ "a" "b" } "c" } } } [
"ab c ab c" [EBNF a="a" "b" foo={a "c"}* EBNF] call ast>>
] unit-test
{ V{ } } [
"ab c ab c" [EBNF a="a" "b" foo=(a "c")* EBNF] call ast>>
] unit-test

34
extra/peg/ebnf/ebnf.factor
View File

@ -17,6 +17,7 @@ TUPLE: ebnf-sequence elements ;
TUPLE: ebnf-repeat0 group ;
TUPLE: ebnf-repeat1 group ;
TUPLE: ebnf-optional group ;
TUPLE: ebnf-whitespace group ;
TUPLE: ebnf-rule symbol elements ;
TUPLE: ebnf-action parser code ;
TUPLE: ebnf-var parser name ;
@ -34,6 +35,7 @@ C: <ebnf-sequence> ebnf-sequence
C: <ebnf-repeat0> ebnf-repeat0
C: <ebnf-repeat1> ebnf-repeat1
C: <ebnf-optional> ebnf-optional
C: <ebnf-whitespace> ebnf-whitespace
C: <ebnf-rule> ebnf-rule
C: <ebnf-action> ebnf-action
C: <ebnf-var> ebnf-var
@ -84,6 +86,7 @@ C: <ebnf> ebnf
[ dup CHAR: + = ]
[ dup CHAR: ? = ]
[ dup CHAR: : = ]
[ dup CHAR: ~ = ]
} || not nip
] satisfy repeat1 [ >string <ebnf-non-terminal> ] action ;
@ -134,9 +137,15 @@ DEFER: 'choice'
#! Parse a group of choices, with a suffix indicating
#! the type of group (repeat0, repeat1, etc) and
#! an quot that is the action that produces the AST.
"(" [ 'choice' sp ] delay ")" syntax-pack
swap 2seq
[ first ] rot compose action ;
2dup
[
"(" [ 'choice' sp ] delay ")" syntax-pack
swap 2seq
[ first ] rot compose action ,
"{" [ 'choice' sp ] delay "}" syntax-pack
swap 2seq
[ first <ebnf-whitespace> ] rot compose action ,
] choice* ;
: 'group' ( -- parser )
#! A grouping with no suffix. Used for precedence.
@ -238,9 +247,15 @@ GENERIC: (transform) ( ast -- parser )
SYMBOL: parser
SYMBOL: main
SYMBOL: ignore-ws
: transform ( ast -- object )
H{ } clone dup dup [ parser set swap (transform) main set ] bind ;
H{ } clone dup dup [
f ignore-ws set
parser set
swap (transform)
main set
] bind ;
M: ebnf (transform) ( ast -- parser )
rules>> [ (transform) ] map peek ;
@ -252,7 +267,13 @@ M: ebnf-rule (transform) ( ast -- parser )
] keep ;
M: ebnf-sequence (transform) ( ast -- parser )
elements>> [ (transform) ] map seq [ dup length 1 = [ first ] when ] action ;
#! If ignore-ws is set then each element of the sequence
#! ignores leading whitespace. This is not inherited by
#! subelements of the sequence.
elements>> [
f ignore-ws [ (transform) ] with-variable
ignore-ws get [ sp ] when
] map seq [ dup length 1 = [ first ] when ] action ;
M: ebnf-choice (transform) ( ast -- parser )
options>> [ (transform) ] map choice ;
@ -282,6 +303,9 @@ M: ebnf-repeat1 (transform) ( ast -- parser )
M: ebnf-optional (transform) ( ast -- parser )
transform-group optional ;
M: ebnf-whitespace (transform) ( ast -- parser )
t ignore-ws [ transform-group ] with-variable ;
GENERIC: build-locals ( code ast -- code )
M: ebnf-sequence build-locals ( code ast -- code )

4
extra/peg/expr/expr.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays strings math.parser sequences
peg peg.ebnf peg.parsers memoize math ;
peg peg.ebnf peg.parsers memoize math accessors ;
IN: peg.expr
EBNF: expr
@ -20,5 +20,5 @@ exp = exp "+" fac => [[ first3 nip + ]]
;EBNF
: eval-expr ( string -- number )
expr parse-result-ast ;
expr ast>> ;

49
extra/peg/peg-tests.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test strings namespaces arrays sequences peg peg.private accessors words math ;
USING: kernel tools.test strings namespaces arrays sequences
peg peg.private accessors words math accessors ;
IN: peg.tests
{ f } [
@ -10,7 +11,7 @@ IN: peg.tests
{ "begin" "end" } [
"beginend" "begin" token parse
{ parse-result-ast parse-result-remaining } get-slots
{ ast>> remaining>> } get-slots
>string
] unit-test
@ -23,11 +24,11 @@ IN: peg.tests
] unit-test
{ CHAR: a } [
"abcd" CHAR: a CHAR: z range parse parse-result-ast
"abcd" CHAR: a CHAR: z range parse ast>>
] unit-test
{ CHAR: z } [
"zbcd" CHAR: a CHAR: z range parse parse-result-ast
"zbcd" CHAR: a CHAR: z range parse ast>>
] unit-test
{ f } [
@ -35,15 +36,15 @@ IN: peg.tests
] unit-test
{ V{ "g" "o" } } [
"good" "g" token "o" token 2array seq parse parse-result-ast
"good" "g" token "o" token 2array seq parse ast>>
] unit-test
{ "a" } [
"abcd" "a" token "b" token 2array choice parse parse-result-ast
"abcd" "a" token "b" token 2array choice parse ast>>
] unit-test
{ "b" } [
"bbcd" "a" token "b" token 2array choice parse parse-result-ast
"bbcd" "a" token "b" token 2array choice parse ast>>
] unit-test
{ f } [
@ -55,15 +56,15 @@ IN: peg.tests
] unit-test
{ 0 } [
"" "a" token repeat0 parse parse-result-ast length
"" "a" token repeat0 parse ast>> length
] unit-test
{ 0 } [
"b" "a" token repeat0 parse parse-result-ast length
"b" "a" token repeat0 parse ast>> length
] unit-test
{ V{ "a" "a" "a" } } [
"aaab" "a" token repeat0 parse parse-result-ast
"aaab" "a" token repeat0 parse ast>>
] unit-test
{ f } [
@ -75,15 +76,15 @@ IN: peg.tests
] unit-test
{ V{ "a" "a" "a" } } [
"aaab" "a" token repeat1 parse parse-result-ast
"aaab" "a" token repeat1 parse ast>>
] unit-test
{ V{ "a" "b" } } [
"ab" "a" token optional "b" token 2array seq parse parse-result-ast
"ab" "a" token optional "b" token 2array seq parse ast>>
] unit-test
{ V{ f "b" } } [
"b" "a" token optional "b" token 2array seq parse parse-result-ast
"b" "a" token optional "b" token 2array seq parse ast>>
] unit-test
{ f } [
@ -91,7 +92,7 @@ IN: peg.tests
] unit-test
{ V{ CHAR: a CHAR: b } } [
"ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse parse-result-ast
"ab" "a" token ensure CHAR: a CHAR: z range dup 3array seq parse ast>>
] unit-test
{ f } [
@ -123,11 +124,11 @@ IN: peg.tests
] unit-test
{ 1 } [
"a" "a" token [ drop 1 ] action parse parse-result-ast
"a" "a" token [ drop 1 ] action parse ast>>
] unit-test
{ V{ 1 1 } } [
"aa" "a" token [ drop 1 ] action dup 2array seq parse parse-result-ast
"aa" "a" token [ drop 1 ] action dup 2array seq parse ast>>
] unit-test
{ f } [
@ -139,19 +140,19 @@ IN: peg.tests
] unit-test
{ CHAR: a } [
"a" [ CHAR: a = ] satisfy parse parse-result-ast
"a" [ CHAR: a = ] satisfy parse ast>>
] unit-test
{ "a" } [
" a" "a" token sp parse parse-result-ast
" a" "a" token sp parse ast>>
] unit-test
{ "a" } [
"a" "a" token sp parse parse-result-ast
"a" "a" token sp parse ast>>
] unit-test
{ V{ "a" } } [
"[a]" "[" token hide "a" token "]" token hide 3array seq parse parse-result-ast
"[a]" "[" token hide "a" token "]" token hide 3array seq parse ast>>
] unit-test
{ f } [
@ -164,8 +165,8 @@ IN: peg.tests
[ "1" token , "-" token , "1" token , ] seq* ,
[ "1" token , "+" token , "1" token , ] seq* ,
] choice*
"1-1" over parse parse-result-ast swap
"1+1" swap parse parse-result-ast
"1-1" over parse ast>> swap
"1+1" swap parse ast>>
] unit-test
: expr ( -- parser )
@ -174,7 +175,7 @@ IN: peg.tests
[ expr ] delay "+" token "1" token 3seq "1" token 2choice ;
{ V{ V{ "1" "+" "1" } "+" "1" } } [
"1+1+1" expr parse parse-result-ast
"1+1+1" expr parse ast>>
] unit-test
{ t } [
@ -189,6 +190,6 @@ IN: peg.tests
] unit-test
{ CHAR: B } [
"B" [ drop t ] satisfy [ 66 >= ] semantic parse parse-result-ast
"B" [ drop t ] satisfy [ 66 >= ] semantic parse ast>>
] unit-test

25
extra/peg/pl0/pl0-tests.factor
View File

@ -1,43 +1,44 @@
! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license.
!
USING: kernel tools.test peg peg.ebnf peg.pl0 multiline sequences ;
USING: kernel tools.test peg peg.ebnf peg.pl0
multiline sequences accessors ;
IN: peg.pl0.tests
{ t } [
"CONST foo = 1;" "block" \ pl0 rule parse parse-result-remaining empty?
"CONST foo = 1;" "block" \ pl0 rule parse remaining>> empty?
] unit-test
{ t } [
"VAR foo;" "block" \ pl0 rule parse parse-result-remaining empty?
"VAR foo;" "block" \ pl0 rule parse remaining>> empty?
] unit-test
{ t } [
"VAR foo,bar , baz;" "block" \ pl0 rule parse parse-result-remaining empty?
"VAR foo,bar , baz;" "block" \ pl0 rule parse remaining>> empty?
] unit-test
{ t } [
"foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
"foo := 5" "statement" \ pl0 rule parse remaining>> empty?
] unit-test
{ t } [
"BEGIN foo := 5 END" "statement" \ pl0 rule parse parse-result-remaining empty?
"BEGIN foo := 5 END" "statement" \ pl0 rule parse remaining>> empty?
] unit-test
{ t } [
"IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
"IF 1=1 THEN foo := 5" "statement" \ pl0 rule parse remaining>> empty?
] unit-test
{ t } [
"WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
"WHILE 1=1 DO foo := 5" "statement" \ pl0 rule parse remaining>> empty?
] unit-test
{ t } [
"WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse parse-result-remaining empty?
"WHILE ODD 1 DO foo := 5" "statement" \ pl0 rule parse remaining>> empty?
] unit-test
{ t } [
"PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse parse-result-remaining empty?
"PROCEDURE square; BEGIN squ:=x*x END" "block" \ pl0 rule parse remaining>> empty?
] unit-test
{ t } [
@ -57,7 +58,7 @@ BEGIN
x := x + 1;
END
END.
"> pl0 parse-result-remaining empty?
"> pl0 remaining>> empty?
] unit-test
{ f } [
@ -123,5 +124,5 @@ BEGIN
y := 36;
CALL gcd;
END.
"> pl0 parse-result-remaining empty?
"> pl0 remaining>> empty?
] unit-test

62
extra/peg/pl0/pl0.factor
View File

@ -7,52 +7,22 @@ IN: peg.pl0
#! Grammar for PL/0 based on http://en.wikipedia.org/wiki/PL/0
EBNF: pl0
_ = (" " | "\t" | "\n")* => [[ drop ignore ]]
BEGIN = "BEGIN" _
CALL = "CALL" _
CONST = "CONST" _
DO = "DO" _
END = "END" _
IF = "IF" _
THEN = "THEN" _
ODD = "ODD" _
PROCEDURE = "PROCEDURE" _
VAR = "VAR" _
WHILE = "WHILE" _
EQ = "=" _
LTEQ = "<=" _
LT = "<" _
GT = ">" _
GTEQ = ">=" _
NEQ = "#" _
COMMA = "," _
SEMICOLON = ";" _
ASSIGN = ":=" _
ADD = "+" _
SUBTRACT = "-" _
MULTIPLY = "*" _
DIVIDE = "/" _
LPAREN = "(" _
RPAREN = ")" _
block = ( CONST ident EQ number ( COMMA ident EQ number )* SEMICOLON )?
( VAR ident ( COMMA ident )* SEMICOLON )?
( PROCEDURE ident SEMICOLON ( block SEMICOLON )? )* statement
statement = ( ident ASSIGN expression
| CALL ident
| BEGIN statement ( SEMICOLON statement )* END
| IF condition THEN statement
| WHILE condition DO statement )?
condition = ODD expression
| expression (EQ | NEQ | LTEQ | LT | GTEQ | GT) expression
expression = (ADD | SUBTRACT)? term ( (ADD | SUBTRACT) term )* _
term = factor ( (MULTIPLY | DIVIDE) factor )*
factor = ident | number | LPAREN expression RPAREN
ident = (([a-zA-Z])+) _ => [[ >string ]]
block = { "CONST" ident "=" number { "," ident "=" number }* ";" }?
{ "VAR" ident { "," ident }* ";" }?
{ "PROCEDURE" ident ";" { block ";" }? }* statement
statement = { ident ":=" expression
| "CALL" ident
| "BEGIN" statement { ";" statement }* "END"
| "IF" condition "THEN" statement
| "WHILE" condition "DO" statement }?
condition = { "ODD" expression }
| { expression ("=" | "#" | "<=" | "<" | ">=" | ">") expression }
expression = {"+" | "-"}? term { {"+" | "-"} term }*
term = factor { {"*" | "/"} factor }*
factor = ident | number | "(" expression ")"
ident = (([a-zA-Z])+) => [[ >string ]]
digit = ([0-9]) => [[ digit> ]]
number = ((digit)+) _ => [[ 10 digits>integer ]]
program = _ block "."
number = (digit)+ => [[ 10 digits>integer ]]
program = { block "." }
;EBNF

4
extra/semantic-db/semantic-db.factor
View File

@ -12,7 +12,7 @@ TUPLE: node id content ;
node "node"
{
{ "id" "id" +native-id+ +autoincrement+ }
{ "id" "id" +db-assigned-id+ +autoincrement+ }
{ "content" "content" TEXT }
} define-persistent
@ -53,7 +53,7 @@ TUPLE: arc id relation subject object ;
arc "arc"
{
{ "id" "id" INTEGER +assigned-id+ } ! foreign key to node table?
{ "id" "id" INTEGER +user-assigned-id+ } ! foreign key to node table?
{ "relation" "relation" INTEGER +not-null+ }
{ "subject" "subject" INTEGER +not-null+ }
{ "object" "object" INTEGER +not-null+ }

4
extra/ui/gadgets/gadgets.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: arrays hashtables kernel models math namespaces sequences
quotations math.vectors combinators sorting vectors dlists
models threads concurrency.flags ;
models threads concurrency.flags math.order ;
IN: ui.gadgets
SYMBOL: ui-notify-flag
@ -106,7 +106,7 @@ GENERIC: children-on ( rect/point gadget -- seq )
M: gadget children-on nip gadget-children ;
: (fast-children-on) ( dim axis gadgets -- i )
swapd [ rect-loc v- over v. ] binsearch nip ;
swapd [ rect-loc v- over v. 0 <=> ] binsearch nip ;
: fast-children-on ( rect axis children -- from to )
3dup

3
extra/update/update.factor
View File

@ -22,7 +22,8 @@ IN: update
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: remote-clean-image ( -- url )
"http://factorcode.org/images/clean/" my-boot-image-name append ;
{ "http://factorcode.org/images/clean/" platform "/" my-boot-image-name }
to-string ;
: download-clean-image ( -- ) remote-clean-image download ;

29
extra/webapps/counter/counter.factor Normal file
View File

@ -0,0 +1,29 @@
USING: math kernel accessors http.server http.server.actions
http.server.sessions http.server.templating.fhtml locals ;
IN: webapps.counter
SYMBOL: count
TUPLE: counter-app < dispatcher ;
M: counter-app init-session*
drop 0 count sset ;
:: <counter-action> ( quot -- action )
<action> [
count quot schange
"" f <standard-redirect>
] >>display ;
: <display-action> ( -- action )
<action> [
"text/html" <content>
"resource:extra/webapps/counter/counter.fhtml" <fhtml> >>body
] >>display ;
: <counter-app> ( -- responder )
counter-app new-dispatcher
[ 1+ ] <counter-action> "inc" add-responder
[ 1- ] <counter-action> "dec" add-responder
<display-action> "" add-responder
<sessions> ;

10
extra/webapps/counter/counter.fhtml Normal file
View File

@ -0,0 +1,10 @@
<% USING: io math.parser http.server.sessions webapps.counter ; %>
<html>
<body>
<h1><% count sget number>string write %></h1>
<a href="inc">++</a>
<a href="dec">--</a>
</body>
</html>

2
extra/webapps/factor-website/factor-website.factor
View File

@ -47,7 +47,7 @@ IN: webapps.factor-website
<boilerplate>
"page" factor-template >>template
<flows>
<session-manager>
<sessions>
sessions-in-db >>sessions
test-db <db-persistence> ;

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

@ -24,7 +24,7 @@ TUPLE: paste id summary author mode date contents annotations captcha ;
paste "PASTE"
{
{ "id" "ID" INTEGER +native-id+ }
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }
{ "mode" "MODE" { VARCHAR 256 } +not-null+ }
@ -43,7 +43,7 @@ TUPLE: annotation aid id summary author mode contents date captcha ;
annotation "ANNOTATION"
{
{ "aid" "AID" INTEGER +native-id+ }
{ "aid" "AID" INTEGER +db-assigned-id+ }
{ "id" "ID" INTEGER +not-null+ }
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
{ "author" "AUTHOR" { VARCHAR 256 } +not-null+ }

2
extra/webapps/planet/planet.factor
View File

@ -27,7 +27,7 @@ M: blog link-href www-url>> ;
blog "BLOGS"
{
{ "id" "ID" INTEGER +native-id+ }
{ "id" "ID" INTEGER +db-assigned-id+ }
{ "name" "NAME" { VARCHAR 256 } +not-null+ }
{ "www-url" "WWWURL" { VARCHAR 256 } +not-null+ }
{ "feed-url" "FEEDURL" { VARCHAR 256 } +not-null+ }

2
extra/webapps/todo/todo.factor
View File

@ -15,7 +15,7 @@ TUPLE: todo uid id priority summary description ;
todo "TODO"
{
{ "uid" "UID" { VARCHAR 256 } +not-null+ }
{ "id" "ID" +native-id+ }
{ "id" "ID" +db-assigned-id+ }
{ "priority" "PRIORITY" INTEGER +not-null+ }
{ "summary" "SUMMARY" { VARCHAR 256 } +not-null+ }
{ "description" "DESCRIPTION" { VARCHAR 256 } }

184
extra/windows/com/syntax/syntax.factor
View File

@ -1,92 +1,92 @@
USING: alien alien.c-types kernel windows.ole32 combinators.lib
parser splitting sequences.lib sequences namespaces assocs
quotations shuffle accessors words macros alien.syntax fry ;
IN: windows.com.syntax
<PRIVATE
C-STRUCT: com-interface
{ "void*" "vtbl" } ;
MACRO: com-invoke ( n return parameters -- )
dup length -roll
'[
, npick com-interface-vtbl , swap void*-nth , ,
"stdcall" alien-indirect
] ;
TUPLE: com-interface-definition name parent iid functions ;
C: <com-interface-definition> com-interface-definition
TUPLE: com-function-definition name return parameters ;
C: <com-function-definition> com-function-definition
SYMBOL: +com-interface-definitions+
+com-interface-definitions+ get-global
[ H{ } +com-interface-definitions+ set-global ]
unless
: find-com-interface-definition ( name -- definition )
dup "f" = [ drop f ] [
dup +com-interface-definitions+ get-global at*
[ nip ]
[ swap " COM interface hasn't been defined" append throw ]
if
] if ;
: save-com-interface-definition ( definition -- )
dup name>> +com-interface-definitions+ get-global set-at ;
: (parse-com-function) ( tokens -- definition )
[ second ]
[ first ]
[ 3 tail 2 group [ first ] map "void*" prefix ]
tri
<com-function-definition> ;
: parse-com-functions ( -- functions )
";" parse-tokens { ")" } split
[ empty? not ] filter
[ (parse-com-function) ] map ;
: (iid-word) ( definition -- word )
name>> "-iid" append create-in ;
: (function-word) ( function interface -- word )
name>> "::" rot name>> 3append create-in ;
: family-tree ( definition -- definitions )
dup parent>> [ family-tree ] [ { } ] if*
swap add ;
: family-tree-functions ( definition -- functions )
dup parent>> [ family-tree-functions ] [ { } ] if*
swap functions>> append ;
: (define-word-for-function) ( function interface n -- )
-rot [ (function-word) swap ] 2keep drop
{ return>> parameters>> } get-slots
[ com-invoke ] 3curry
define ;
: define-words-for-com-interface ( definition -- )
[ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
[ name>> "com-interface" swap typedef ]
[
dup family-tree-functions
[ (define-word-for-function) ] with each-index
]
tri ;
PRIVATE>
: COM-INTERFACE:
scan
scan find-com-interface-definition
scan string>guid
parse-com-functions
<com-interface-definition>
dup save-com-interface-definition
define-words-for-com-interface
; parsing
USING: alien alien.c-types kernel windows.ole32 combinators.lib
parser splitting sequences.lib sequences namespaces assocs
quotations shuffle accessors words macros alien.syntax fry ;
IN: windows.com.syntax
<PRIVATE
C-STRUCT: com-interface
{ "void*" "vtbl" } ;
MACRO: com-invoke ( n return parameters -- )
dup length -roll
'[
, npick com-interface-vtbl , swap void*-nth , ,
"stdcall" alien-indirect
] ;
TUPLE: com-interface-definition name parent iid functions ;
C: <com-interface-definition> com-interface-definition
TUPLE: com-function-definition name return parameters ;
C: <com-function-definition> com-function-definition
SYMBOL: +com-interface-definitions+
+com-interface-definitions+ get-global
[ H{ } +com-interface-definitions+ set-global ]
unless
: find-com-interface-definition ( name -- definition )
dup "f" = [ drop f ] [
dup +com-interface-definitions+ get-global at*
[ nip ]
[ swap " COM interface hasn't been defined" append throw ]
if
] if ;
: save-com-interface-definition ( definition -- )
dup name>> +com-interface-definitions+ get-global set-at ;
: (parse-com-function) ( tokens -- definition )
[ second ]
[ first ]
[ 3 tail 2 group [ first ] map "void*" prefix ]
tri
<com-function-definition> ;
: parse-com-functions ( -- functions )
";" parse-tokens { ")" } split
[ empty? not ] filter
[ (parse-com-function) ] map ;
: (iid-word) ( definition -- word )
name>> "-iid" append create-in ;
: (function-word) ( function interface -- word )
name>> "::" rot name>> 3append create-in ;
: family-tree ( definition -- definitions )
dup parent>> [ family-tree ] [ { } ] if*
swap suffix ;
: family-tree-functions ( definition -- functions )
dup parent>> [ family-tree-functions ] [ { } ] if*
swap functions>> append ;
: (define-word-for-function) ( function interface n -- )
-rot [ (function-word) swap ] 2keep drop
{ return>> parameters>> } get-slots
[ com-invoke ] 3curry
define ;
: define-words-for-com-interface ( definition -- )
[ [ (iid-word) ] [ iid>> 1quotation ] bi define ]
[ name>> "com-interface" swap typedef ]
[
dup family-tree-functions
[ (define-word-for-function) ] with each-index
]
tri ;
PRIVATE>
: COM-INTERFACE:
scan
scan find-com-interface-definition
scan string>guid
parse-com-functions
<com-interface-definition>
dup save-com-interface-definition
define-words-for-com-interface
; parsing

271
extra/windows/ole32/ole32.factor
View File

@ -1,135 +1,136 @@
USING: alien alien.syntax alien.c-types alien.strings math
kernel sequences windows windows.types combinators.lib ;
IN: windows.ole32
LIBRARY: ole32
TYPEDEF: GUID* REFGUID
TYPEDEF: void* LPUNKNOWN
TYPEDEF: wchar_t* LPOLESTR
TYPEDEF: wchar_t* LPCOLESTR
TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID
FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;
FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
: S_OK 0 ; inline
: S_FALSE 1 ; inline
: E_NOINTERFACE HEX: 80004002 ; inline
: E_FAIL HEX: 80004005 ; inline
: E_INVALIDARG HEX: 80070057 ; inline
: MK_ALT HEX: 20 ; inline
: DROPEFFECT_NONE 0 ; inline
: DROPEFFECT_COPY 1 ; inline
: DROPEFFECT_MOVE 2 ; inline
: DROPEFFECT_LINK 4 ; inline
: DROPEFFECT_SCROLL HEX: 80000000 ; inline
: DD_DEFSCROLLINSET 11 ; inline
: DD_DEFSCROLLDELAY 50 ; inline
: DD_DEFSCROLLINTERVAL 50 ; inline
: DD_DEFDRAGDELAY 200 ; inline
: DD_DEFDRAGMINDIST 2 ; inline
: CF_TEXT 1 ; inline
: CF_BITMAP 2 ; inline
: CF_METAFILEPICT 3 ; inline
: CF_SYLK 4 ; inline
: CF_DIF 5 ; inline
: CF_TIFF 6 ; inline
: CF_OEMTEXT 7 ; inline
: CF_DIB 8 ; inline
: CF_PALETTE 9 ; inline
: CF_PENDATA 10 ; inline
: CF_RIFF 11 ; inline
: CF_WAVE 12 ; inline
: CF_UNICODETEXT 13 ; inline
: CF_ENHMETAFILE 14 ; inline
: CF_HDROP 15 ; inline
: CF_LOCALE 16 ; inline
: CF_MAX 17 ; inline
: CF_OWNERDISPLAY HEX: 0080 ; inline
: CF_DSPTEXT HEX: 0081 ; inline
: CF_DSPBITMAP HEX: 0082 ; inline
: CF_DSPMETAFILEPICT HEX: 0083 ; inline
: CF_DSPENHMETAFILE HEX: 008E ; inline
: DVASPECT_CONTENT 1 ; inline
: DVASPECT_THUMBNAIL 2 ; inline
: DVASPECT_ICON 4 ; inline
: DVASPECT_DOCPRINT 8 ; inline
: TYMED_HGLOBAL 1 ; inline
: TYMED_FILE 2 ; inline
: TYMED_ISTREAM 4 ; inline
: TYMED_ISTORAGE 8 ; inline
: TYMED_GDI 16 ; inline
: TYMED_MFPICT 32 ; inline
: TYMED_ENHMF 64 ; inline
: TYMED_NULL 0 ; inline
C-STRUCT: DVTARGETDEVICE
{ "DWORD" "tdSize" }
{ "WORD" "tdDriverNameOffset" }
{ "WORD" "tdDeviceNameOffset" }
{ "WORD" "tdPortNameOffset" }
{ "WORD" "tdExtDevmodeOffset" }
{ "BYTE[1]" "tdData" } ;
TYPEDEF: WORD CLIPFORMAT
TYPEDEF: POINT POINTL
C-STRUCT: FORMATETC
{ "CLIPFORMAT" "cfFormat" }
{ "DVTARGETDEVICE*" "ptd" }
{ "DWORD" "dwAspect" }
{ "LONG" "lindex" }
{ "DWORD" "tymed" } ;
TYPEDEF: FORMATETC* LPFORMATETC
C-STRUCT: STGMEDIUM
{ "DWORD" "tymed" }
{ "void*" "data" }
{ "LPUNKNOWN" "punkForRelease" } ;
TYPEDEF: STGMEDIUM* LPSTGMEDIUM
: COINIT_MULTITHREADED 0 ; inline
: COINIT_APARTMENTTHREADED 2 ; inline
: COINIT_DISABLE_OLE1DDE 4 ; inline
: COINIT_SPEED_OVER_MEMORY 8 ; inline
FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ;
: ole32-error ( hresult -- )
dup succeeded? [
drop
] [ (win32-error-string) throw ] if ;
: ole-initialize ( -- )
f OleInitialize ole32-error ;
: guid= ( a b -- ? )
IsEqualGUID c-bool> ;
: GUID-STRING-LENGTH
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
: string>guid ( string -- guid )
utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
: guid>string ( guid -- string )
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
[ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;
USING: alien alien.syntax alien.c-types alien.strings math
kernel sequences windows windows.types combinators.lib
math.order ;
IN: windows.ole32
LIBRARY: ole32
TYPEDEF: GUID* REFGUID
TYPEDEF: void* LPUNKNOWN
TYPEDEF: wchar_t* LPOLESTR
TYPEDEF: wchar_t* LPCOLESTR
TYPEDEF: REFGUID REFIID
TYPEDEF: REFGUID REFCLSID
FUNCTION: HRESULT CoCreateInstance ( REFGUID rclsid, LPUNKNOWN pUnkOuter, DWORD dwClsContext, REFGUID riid, LPUNKNOWN out_ppv ) ;
FUNCTION: BOOL IsEqualGUID ( REFGUID rguid1, REFGUID rguid2 ) ;
FUNCTION: int StringFromGUID2 ( REFGUID rguid, LPOLESTR lpsz, int cchMax ) ;
FUNCTION: HRESULT CLSIDFromString ( LPOLESTR lpsz, REFGUID out_rguid ) ;
: S_OK 0 ; inline
: S_FALSE 1 ; inline
: E_NOINTERFACE HEX: 80004002 ; inline
: E_FAIL HEX: 80004005 ; inline
: E_INVALIDARG HEX: 80070057 ; inline
: MK_ALT HEX: 20 ; inline
: DROPEFFECT_NONE 0 ; inline
: DROPEFFECT_COPY 1 ; inline
: DROPEFFECT_MOVE 2 ; inline
: DROPEFFECT_LINK 4 ; inline
: DROPEFFECT_SCROLL HEX: 80000000 ; inline
: DD_DEFSCROLLINSET 11 ; inline
: DD_DEFSCROLLDELAY 50 ; inline
: DD_DEFSCROLLINTERVAL 50 ; inline
: DD_DEFDRAGDELAY 200 ; inline
: DD_DEFDRAGMINDIST 2 ; inline
: CF_TEXT 1 ; inline
: CF_BITMAP 2 ; inline
: CF_METAFILEPICT 3 ; inline
: CF_SYLK 4 ; inline
: CF_DIF 5 ; inline
: CF_TIFF 6 ; inline
: CF_OEMTEXT 7 ; inline
: CF_DIB 8 ; inline
: CF_PALETTE 9 ; inline
: CF_PENDATA 10 ; inline
: CF_RIFF 11 ; inline
: CF_WAVE 12 ; inline
: CF_UNICODETEXT 13 ; inline
: CF_ENHMETAFILE 14 ; inline
: CF_HDROP 15 ; inline
: CF_LOCALE 16 ; inline
: CF_MAX 17 ; inline
: CF_OWNERDISPLAY HEX: 0080 ; inline
: CF_DSPTEXT HEX: 0081 ; inline
: CF_DSPBITMAP HEX: 0082 ; inline
: CF_DSPMETAFILEPICT HEX: 0083 ; inline
: CF_DSPENHMETAFILE HEX: 008E ; inline
: DVASPECT_CONTENT 1 ; inline
: DVASPECT_THUMBNAIL 2 ; inline
: DVASPECT_ICON 4 ; inline
: DVASPECT_DOCPRINT 8 ; inline
: TYMED_HGLOBAL 1 ; inline
: TYMED_FILE 2 ; inline
: TYMED_ISTREAM 4 ; inline
: TYMED_ISTORAGE 8 ; inline
: TYMED_GDI 16 ; inline
: TYMED_MFPICT 32 ; inline
: TYMED_ENHMF 64 ; inline
: TYMED_NULL 0 ; inline
C-STRUCT: DVTARGETDEVICE
{ "DWORD" "tdSize" }
{ "WORD" "tdDriverNameOffset" }
{ "WORD" "tdDeviceNameOffset" }
{ "WORD" "tdPortNameOffset" }
{ "WORD" "tdExtDevmodeOffset" }
{ "BYTE[1]" "tdData" } ;
TYPEDEF: WORD CLIPFORMAT
TYPEDEF: POINT POINTL
C-STRUCT: FORMATETC
{ "CLIPFORMAT" "cfFormat" }
{ "DVTARGETDEVICE*" "ptd" }
{ "DWORD" "dwAspect" }
{ "LONG" "lindex" }
{ "DWORD" "tymed" } ;
TYPEDEF: FORMATETC* LPFORMATETC
C-STRUCT: STGMEDIUM
{ "DWORD" "tymed" }
{ "void*" "data" }
{ "LPUNKNOWN" "punkForRelease" } ;
TYPEDEF: STGMEDIUM* LPSTGMEDIUM
: COINIT_MULTITHREADED 0 ; inline
: COINIT_APARTMENTTHREADED 2 ; inline
: COINIT_DISABLE_OLE1DDE 4 ; inline
: COINIT_SPEED_OVER_MEMORY 8 ; inline
FUNCTION: HRESULT OleInitialize ( void* reserved ) ;
FUNCTION: HRESULT CoInitializeEx ( void* reserved, DWORD dwCoInit ) ;
FUNCTION: HRESULT RegisterDragDrop ( HWND hWnd, IDropTarget* pDropTarget ) ;
FUNCTION: HRESULT RevokeDragDrop ( HWND hWnd ) ;
FUNCTION: void ReleaseStgMedium ( LPSTGMEDIUM pmedium ) ;
: succeeded? ( hresult -- ? )
0 HEX: 7FFFFFFF between? ;
: ole32-error ( hresult -- )
dup succeeded? [
drop
] [ (win32-error-string) throw ] if ;
: ole-initialize ( -- )
f OleInitialize ole32-error ;
: guid= ( a b -- ? )
IsEqualGUID c-bool> ;
: GUID-STRING-LENGTH
"{01234567-89ab-cdef-0123-456789abcdef}" length ; inline
: string>guid ( string -- guid )
utf16n string>alien "GUID" <c-object> [ CLSIDFromString ole32-error ] keep ;
: guid>string ( guid -- string )
GUID-STRING-LENGTH 1+ [ "ushort" <c-array> ] keep
[ StringFromGUID2 drop ] { 2 } multikeep utf16n alien>string ;

43205
extra/zip-codes/zipcode.csv Normal file
View File

File diff suppressed because it is too large Load Diff