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

db4
Joe Groff 2009-02-12 22:40:51 -06:00
commit e3f531cba4
52 changed files with 847 additions and 299 deletions

View File

@ -1,6 +1,13 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.complex.functor sequences kernel ;
USING: alien.c-types alien.structs alien.complex.functor accessors
sequences kernel ;
IN: alien.complex
<< { "float" "double" } [ dup "complex-" prepend define-complex-type ] each >>
<<
{ "float" "double" } [ dup "complex-" prepend define-complex-type ] each
! This overrides the fact that small structures are never returned
! in registers on NetBSD, Linux and Solaris running on 32-bit x86.
"complex-float" c-type t >>return-in-registers? drop
>>

View File

@ -3,7 +3,7 @@
USING: accessors arrays assocs generic hashtables kernel kernel.private
math namespaces parser sequences strings words libc fry
alien.c-types alien.structs.fields cpu.architecture math.order
quotations ;
quotations byte-arrays ;
IN: alien.structs
TUPLE: struct-type
@ -13,11 +13,14 @@ fields
{ boxer-quot callable }
{ unboxer-quot callable }
{ getter callable }
{ setter callable } ;
{ setter callable }
return-in-registers? ;
M: struct-type c-type ;
M: struct-type heap-size size>> ;
M: struct-type c-type-class drop object ;
M: struct-type c-type-class drop byte-array ;
M: struct-type c-type-align align>> ;
@ -37,7 +40,7 @@ M: struct-type box-parameter
[ %box-large-struct ] [ box-parameter ] if-value-struct ;
: if-small-struct ( c-type true false -- ? )
[ dup struct-small-enough? ] 2dip '[ f swap @ ] if ; inline
[ dup return-struct-in-registers? ] 2dip '[ f swap @ ] if ; inline
M: struct-type unbox-return
[ %unbox-small-struct ] [ %unbox-large-struct ] if-small-struct ;

View File

@ -0,0 +1,27 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors bitstreams io io.streams.string kernel tools.test
grouping compression.lzw multiline byte-arrays io.encodings.binary
io.streams.byte-array ;
IN: bitstreams.tests
[ 1 t ]
[ B{ 254 } <string-reader> <bitstream-reader> read-bit ] unit-test
[ 254 8 t ]
[ B{ 254 } <string-reader> <bitstream-reader> 8 swap read-bits ] unit-test
[ 4095 12 t ]
[ B{ 255 255 } <string-reader> <bitstream-reader> 12 swap read-bits ] unit-test
[ B{ 254 } ]
[
<string-writer> <bitstream-writer> 254 8 rot
[ write-bits ] keep stream>> >byte-array
] unit-test
[ 255 8 t ]
[ B{ 255 } binary <byte-reader> <bitstream-reader> 8 swap read-bits ] unit-test
[ 255 8 f ]
[ B{ 255 } binary <byte-reader> <bitstream-reader> 9 swap read-bits ] unit-test

View File

@ -0,0 +1,96 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors byte-arrays destructors fry io kernel locals
math sequences ;
IN: bitstreams
TUPLE: bitstream stream end-of-stream? current-bits #bits disposed ;
TUPLE: bitstream-reader < bitstream ;
: reset-bitstream ( stream -- stream )
0 >>#bits 0 >>current-bits ; inline
: new-bitstream ( stream class -- bitstream )
new
swap >>stream
reset-bitstream ; inline
M: bitstream-reader dispose ( stream -- )
stream>> dispose ;
: <bitstream-reader> ( stream -- bitstream )
bitstream-reader new-bitstream ; inline
: read-next-byte ( bitstream -- bitstream )
dup stream>> stream-read1 [
>>current-bits 8 >>#bits
] [
0 >>#bits
t >>end-of-stream?
] if* ;
: maybe-read-next-byte ( bitstream -- bitstream )
dup #bits>> 0 = [ read-next-byte ] when ; inline
: shift-one-bit ( bitstream -- n )
[ current-bits>> ] [ #bits>> ] bi 1- neg shift 1 bitand ; inline
: next-bit ( bitstream -- n/f ? )
maybe-read-next-byte
dup end-of-stream?>> [
drop f
] [
[ shift-one-bit ]
[ [ 1- ] change-#bits maybe-read-next-byte drop ] bi
] if dup >boolean ;
: read-bit ( bitstream -- n ? )
dup #bits>> 1 = [
[ current-bits>> 1 bitand ]
[ read-next-byte drop ] bi t
] [
next-bit
] if ; inline
: bits>integer ( seq -- n )
0 [ [ 1 shift ] dip bitor ] reduce ; inline
: read-bits ( width bitstream -- n width ? )
[
'[ _ read-bit drop ] replicate
[ f = ] trim-tail
[ bits>integer ] [ length ] bi
] 2keep drop over = ;
TUPLE: bitstream-writer < bitstream ;
: <bitstream-writer> ( stream -- bitstream )
bitstream-writer new-bitstream ; inline
: write-bit ( n bitstream -- )
[ 1 shift bitor ] change-current-bits
[ 1+ ] change-#bits
dup #bits>> 8 = [
[ [ current-bits>> ] [ stream>> stream-write1 ] bi ]
[ reset-bitstream drop ] bi
] [
drop
] if ; inline
ERROR: invalid-bit-width n ;
:: write-bits ( n width bitstream -- )
n 0 < [ n invalid-bit-width ] when
n 0 = [
width [ 0 bitstream write-bit ] times
] [
width n log2 1+ dup :> n-length - [ 0 bitstream write-bit ] times
n-length [
n-length swap - 1- neg n swap shift 1 bitand
bitstream write-bit
] each
] if ;
: flush-bits ( bitstream -- ) stream>> stream-flush ;
: bitstream-output ( bitstream -- bytes ) stream>> >byte-array ;

View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io io.files io.pathnames ;
USING: help.markup help.syntax io io.files io.pathnames strings ;
IN: bootstrap.image
ARTICLE: "bootstrap.image" "Bootstrapping new images"
@ -14,7 +14,7 @@ $nl
ABOUT: "bootstrap.image"
HELP: make-image
{ $values { "arch" "a string" } }
{ $values { "arch" string } }
{ $description "Creates a bootstrap image from sources, where " { $snippet "architecture" } " is one of the following:"
{ $code "x86.32" "x86.64" "ppc" "arm" }
{ $code "x86.32" "unix-x86.64" "winnt-x86.64" "macosx-ppc" "linux-ppc" }
"The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;

View File

@ -44,4 +44,6 @@ IN: combinators.smart.tests
\ nested-smart-combo-test must-infer
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
[ { { 1 2 } { 3 4 } } ] [ nested-smart-combo-test ] unit-test
[ 14 ] [ [ 1 2 3 ] [ sq ] [ + ] map-reduce-outputs ] unit-test

View File

@ -21,6 +21,12 @@ MACRO: reduce-outputs ( quot operation -- newquot )
: sum-outputs ( quot -- n )
[ + ] reduce-outputs ; inline
MACRO: map-reduce-outputs ( quot mapper reducer -- newquot )
[ dup infer out>> ] 2dip
[ swap '[ _ _ napply ] ]
[ [ 1 [-] ] dip n*quot ] bi-curry* bi
'[ @ @ @ ] ;
MACRO: append-outputs-as ( quot exemplar -- newquot )
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;

View File

@ -5,7 +5,7 @@ alien.c-types alien.structs cpu.architecture ;
IN: compiler.alien
: large-struct? ( ctype -- ? )
dup c-struct? [ struct-small-enough? not ] [ drop f ] if ;
dup c-struct? [ return-struct-in-registers? not ] [ drop f ] if ;
: alien-parameters ( params -- seq )
dup parameters>>

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,4 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors tools.test compression.lzw ;
IN: compression.lzw.tests

View File

@ -0,0 +1,204 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors assocs bitstreams byte-vectors combinators io
io.encodings.binary io.streams.byte-array kernel math sequences
vectors ;
IN: compression.lzw
CONSTANT: clear-code 256
CONSTANT: end-of-information 257
TUPLE: lzw input output end-of-input? table count k omega omega-k #bits
code old-code ;
SYMBOL: table-full
ERROR: index-too-big n ;
: lzw-bit-width ( n -- n' )
{
{ [ dup 510 <= ] [ drop 9 ] }
{ [ dup 1022 <= ] [ drop 10 ] }
{ [ dup 2046 <= ] [ drop 11 ] }
{ [ dup 4094 <= ] [ drop 12 ] }
[ drop table-full ]
} cond ;
: lzw-bit-width-compress ( lzw -- n )
count>> lzw-bit-width ;
: lzw-bit-width-uncompress ( lzw -- n )
table>> length lzw-bit-width ;
: initial-compress-table ( -- assoc )
258 iota [ [ 1vector ] keep ] H{ } map>assoc ;
: initial-uncompress-table ( -- seq )
258 iota [ 1vector ] V{ } map-as ;
: reset-lzw ( lzw -- lzw )
257 >>count
V{ } clone >>omega
V{ } clone >>omega-k
9 >>#bits ;
: reset-lzw-compress ( lzw -- lzw )
f >>k
initial-compress-table >>table reset-lzw ;
: reset-lzw-uncompress ( lzw -- lzw )
initial-uncompress-table >>table reset-lzw ;
: <lzw-compress> ( input -- obj )
lzw new
swap >>input
binary <byte-writer> <bitstream-writer> >>output
reset-lzw-compress ;
: <lzw-uncompress> ( input -- obj )
lzw new
swap >>input
BV{ } clone >>output
reset-lzw-uncompress ;
: push-k ( lzw -- lzw )
[ ]
[ k>> ]
[ omega>> clone [ push ] keep ] tri >>omega-k ;
: omega-k-in-table? ( lzw -- ? )
[ omega-k>> ] [ table>> ] bi key? ;
ERROR: not-in-table ;
: write-output ( lzw -- )
[
[ omega>> ] [ table>> ] bi at* [ not-in-table ] unless
] [
[ lzw-bit-width-compress ]
[ output>> write-bits ] bi
] bi ;
: omega-k>omega ( lzw -- lzw )
dup omega-k>> clone >>omega ;
: k>omega ( lzw -- lzw )
dup k>> 1vector >>omega ;
: add-omega-k ( lzw -- )
[ [ 1+ ] change-count count>> ]
[ omega-k>> clone ]
[ table>> ] tri set-at ;
: lzw-compress-char ( lzw k -- )
>>k push-k dup omega-k-in-table? [
omega-k>omega drop
] [
[ write-output ]
[ add-omega-k ]
[ k>omega drop ] tri
] if ;
: (lzw-compress-chars) ( lzw -- )
dup lzw-bit-width-compress table-full = [
drop
] [
dup input>> stream-read1
[ [ lzw-compress-char ] [ drop (lzw-compress-chars) ] 2bi ]
[ t >>end-of-input? drop ] if*
] if ;
: lzw-compress-chars ( lzw -- )
{
! [ [ clear-code lzw-compress-char ] [ drop ] bi ] ! reset-lzw-compress drop ] bi ]
[
[ clear-code ] dip
[ lzw-bit-width-compress ]
[ output>> write-bits ] bi
]
[ (lzw-compress-chars) ]
[
[ k>> ]
[ lzw-bit-width-compress ]
[ output>> write-bits ] tri
]
[
[ end-of-information ] dip
[ lzw-bit-width-compress ]
[ output>> write-bits ] bi
]
[ ]
} cleave dup end-of-input?>> [ drop ] [ lzw-compress-chars ] if ;
: lzw-compress ( byte-array -- seq )
binary <byte-reader> <lzw-compress>
[ lzw-compress-chars ] [ output>> stream>> ] bi ;
: lookup-old-code ( lzw -- vector )
[ old-code>> ] [ table>> ] bi nth ;
: lookup-code ( lzw -- vector )
[ code>> ] [ table>> ] bi nth ;
: code-in-table? ( lzw -- ? )
[ code>> ] [ table>> length ] bi < ;
: code>old-code ( lzw -- lzw )
dup code>> >>old-code ;
: write-code ( lzw -- )
[ lookup-code ] [ output>> ] bi push-all ;
: add-to-table ( seq lzw -- ) table>> push ;
: lzw-read ( lzw -- lzw n )
[ ] [ lzw-bit-width-uncompress ] [ input>> ] tri read-bits 2drop ;
DEFER: lzw-uncompress-char
: handle-clear-code ( lzw -- )
reset-lzw-uncompress
lzw-read dup end-of-information = [
2drop
] [
>>code
[ write-code ]
[ code>old-code ] bi
lzw-uncompress-char
] if ;
: handle-uncompress-code ( lzw -- lzw )
dup code-in-table? [
[ write-code ]
[
[
[ lookup-old-code ]
[ lookup-code first ] bi suffix
] [ add-to-table ] bi
] [ code>old-code ] tri
] [
[
[ lookup-old-code dup first suffix ] keep
[ output>> push-all ] [ add-to-table ] 2bi
] [ code>old-code ] bi
] if ;
: lzw-uncompress-char ( lzw -- )
lzw-read [
>>code
dup code>> end-of-information = [
drop
] [
dup code>> clear-code = [
handle-clear-code
] [
handle-uncompress-code
lzw-uncompress-char
] if
] if
] [
drop
] if* ;
: lzw-uncompress ( seq -- byte-array )
binary <byte-reader> <bitstream-reader>
<lzw-uncompress> [ lzw-uncompress-char ] [ output>> ] bi ;

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,30 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax combinators system ;
IN: compression.zlib.ffi
<< "zlib" {
{ [ os winnt? ] [ "zlib1.dll" ] }
{ [ os macosx? ] [ "libz.dylib" ] }
{ [ os unix? ] [ "libz.so" ] }
} cond "cdecl" add-library >>
LIBRARY: zlib
CONSTANT: Z_OK 0
CONSTANT: Z_STREAM_END 1
CONSTANT: Z_NEED_DICT 2
CONSTANT: Z_ERRNO -1
CONSTANT: Z_STREAM_ERROR -2
CONSTANT: Z_DATA_ERROR -3
CONSTANT: Z_MEM_ERROR -4
CONSTANT: Z_BUF_ERROR -5
CONSTANT: Z_VERSION_ERROR -6
TYPEDEF: void Bytef
TYPEDEF: ulong uLongf
TYPEDEF: ulong uLong
FUNCTION: int compress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;
FUNCTION: int compress2 ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen, int level ) ;
FUNCTION: int uncompress ( Bytef* dest, uLongf* destLen, Bytef* source, uLong sourceLen ) ;

View File

@ -0,0 +1,9 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel tools.test compression.zlib classes ;
IN: compression.zlib.tests
: compress-me ( -- byte-array ) B{ 1 2 3 4 5 } ;
[ t ] [ compress-me [ compress uncompress ] keep = ] unit-test
[ t ] [ compress-me compress compressed instance? ] unit-test

View File

@ -0,0 +1,48 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax byte-arrays combinators
kernel math math.functions sequences system accessors
libc ;
QUALIFIED: compression.zlib.ffi
IN: compression.zlib
TUPLE: compressed data length ;
: <compressed> ( data length -- compressed )
compressed new
swap >>length
swap >>data ;
ERROR: zlib-failed n string ;
: zlib-error-message ( n -- * )
dup compression.zlib.ffi:Z_ERRNO = [
drop errno "native libc error"
] [
dup {
"no error" "libc_error"
"stream error" "data error"
"memory error" "buffer error" "zlib version error"
} ?nth
] if zlib-failed ;
: zlib-error ( n -- )
dup compression.zlib.ffi:Z_OK = [ drop ] [ dup zlib-error-message zlib-failed ] if ;
: compressed-size ( byte-array -- n )
length 1001/1000 * ceiling 12 + ;
: compress ( byte-array -- compressed )
[
[ compressed-size <byte-array> dup length <ulong> ] keep [
dup length compression.zlib.ffi:compress zlib-error
] 3keep drop *ulong head
] keep length <compressed> ;
: uncompress ( compressed -- byte-array )
[
length>> [ <byte-array> ] keep <ulong> 2dup
] [
data>> dup length
compression.zlib.ffi:uncompress zlib-error
] bi *ulong head ;

View File

@ -152,7 +152,7 @@ HOOK: %loop-entry cpu ( -- )
HOOK: small-enough? cpu ( n -- ? )
! Is this structure small enough to be returned in registers?
HOOK: struct-small-enough? cpu ( c-type -- ? )
HOOK: return-struct-in-registers? cpu ( c-type -- ? )
! Do we pass this struct by value or hidden reference?
HOOK: value-struct? cpu ( c-type -- ? )

View File

@ -659,7 +659,7 @@ M: ppc %callback-value ( ctype -- )
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
M: ppc struct-small-enough? ( size -- ? ) drop f ;
M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
M: ppc %box-small-struct
drop "No small structs" throw ;

View File

@ -48,9 +48,12 @@ M: x86.32 %alien-invoke (CALL) rel-dlsym ;
M: x86.32 %alien-invoke-tail (JMP) rel-dlsym ;
M: x86.32 struct-small-enough? ( size -- ? )
heap-size { 1 2 4 8 } member?
os { linux netbsd solaris } member? not and ;
M: x86.32 return-struct-in-registers? ( c-type -- ? )
c-type
[ return-in-registers?>> ]
[ heap-size { 1 2 4 8 } member? ] bi
os { linux netbsd solaris } member? not
and or ;
: struct-return@ ( n -- operand )
[ next-stack@ ] [ stack-frame get params>> stack@ ] if* ;

View File

@ -44,7 +44,7 @@ M: struct-type flatten-value-type ( type -- seq )
flatten-small-struct
] if ;
M: x86.64 struct-small-enough? ( size -- ? )
M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size 2 cells <= ;
M: x86.64 dummy-stack-params? f ;

View File

@ -10,7 +10,8 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
M: x86.64 reserved-area-size 4 cells ;
M: x86.64 struct-small-enough? heap-size { 1 2 4 8 } member? ;
M: x86.64 return-struct-in-registers? ( c-type -- ? )
heap-size { 1 2 4 8 } member? ;
M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;

View File

@ -7,9 +7,6 @@ IN: csv.tests
: named-unit-test ( name output input -- )
unit-test drop ; inline
! tests nicked from the wikipedia csv article
! http://en.wikipedia.org/wiki/Comma-separated_values
"Fields are separated by commas"
[ { { "1997" "Ford" "E350" } } ]
[ "1997,Ford,E350" <string-reader> csv ] named-unit-test
@ -90,3 +87,5 @@ IN: csv.tests
{ { "writing,some,csv,tests" } } dup "csv-test2-"
unique-file utf8 [ csv>file ] [ file>csv ] 2bi =
] unit-test
[ { { "hello" "" "" "" "goodbye" "" } } ] [ "hello,,\"\",,goodbye," <string-reader> csv ] unit-test

View File

@ -46,13 +46,15 @@ DEFER: quoted-field ( -- endchar )
: (row) ( -- sep )
field ,
dup delimiter get = [ drop (row) ] when ;
dup delimiter> = [ drop (row) ] when ;
: row ( -- eof? array[string] )
[ (row) ] { } make ;
: (csv) ( -- )
row harvest [ , ] unless-empty [ (csv) ] when ;
row
dup [ empty? ] all? [ drop ] [ , ] if
[ (csv) ] when ;
PRIVATE>
@ -60,7 +62,8 @@ PRIVATE>
[ row nip ] with-input-stream ;
: csv ( stream -- rows )
[ [ (csv) ] { } make ] with-input-stream ;
[ [ (csv) ] { } make ] with-input-stream
dup peek { "" } = [ but-last ] when ;
: file>csv ( path encoding -- csv )
<file-reader> csv ;

View File

@ -11,46 +11,46 @@ IN: db.postgresql.ffi
} cond "cdecl" add-library >>
! ConnSatusType
: CONNECTION_OK HEX: 0 ; inline
: CONNECTION_BAD HEX: 1 ; inline
: CONNECTION_STARTED HEX: 2 ; inline
: CONNECTION_MADE HEX: 3 ; inline
: CONNECTION_AWAITING_RESPONSE HEX: 4 ; inline
: CONNECTION_AUTH_OK HEX: 5 ; inline
: CONNECTION_SETENV HEX: 6 ; inline
: CONNECTION_SSL_STARTUP HEX: 7 ; inline
: CONNECTION_NEEDED HEX: 8 ; inline
CONSTANT: CONNECTION_OK HEX: 0
CONSTANT: CONNECTION_BAD HEX: 1
CONSTANT: CONNECTION_STARTED HEX: 2
CONSTANT: CONNECTION_MADE HEX: 3
CONSTANT: CONNECTION_AWAITING_RESPONSE HEX: 4
CONSTANT: CONNECTION_AUTH_OK HEX: 5
CONSTANT: CONNECTION_SETENV HEX: 6
CONSTANT: CONNECTION_SSL_STARTUP HEX: 7
CONSTANT: CONNECTION_NEEDED HEX: 8
! 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
CONSTANT: PGRES_POLLING_FAILED HEX: 0
CONSTANT: PGRES_POLLING_READING HEX: 1
CONSTANT: PGRES_POLLING_WRITING HEX: 2
CONSTANT: PGRES_POLLING_OK HEX: 3
CONSTANT: PGRES_POLLING_ACTIVE HEX: 4
! 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
CONSTANT: PGRES_EMPTY_QUERY HEX: 0
CONSTANT: PGRES_COMMAND_OK HEX: 1
CONSTANT: PGRES_TUPLES_OK HEX: 2
CONSTANT: PGRES_COPY_OUT HEX: 3
CONSTANT: PGRES_COPY_IN HEX: 4
CONSTANT: PGRES_BAD_RESPONSE HEX: 5
CONSTANT: PGRES_NONFATAL_ERROR HEX: 6
CONSTANT: PGRES_FATAL_ERROR HEX: 7
! 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
CONSTANT: PQTRANS_IDLE HEX: 0
CONSTANT: PQTRANS_ACTIVE HEX: 1
CONSTANT: PQTRANS_INTRANS HEX: 2
CONSTANT: PQTRANS_INERROR HEX: 3
CONSTANT: PQTRANS_UNKNOWN HEX: 4
! PGVerbosity;
: PQERRORS_TERSE HEX: 0 ; inline
: PQERRORS_DEFAULT HEX: 1 ; inline
: PQERRORS_VERBOSE HEX: 2 ; inline
CONSTANT: PQERRORS_TERSE HEX: 0
CONSTANT: PQERRORS_DEFAULT HEX: 1
CONSTANT: PQERRORS_VERBOSE HEX: 2
: InvalidOid 0 ; inline
CONSTANT: InvalidOid 0
TYPEDEF: int ConnStatusType
TYPEDEF: int ExecStatusType
@ -348,21 +348,21 @@ FUNCTION: int PQdsplen ( uchar* s, int encoding ) ;
FUNCTION: int PQenv2encoding ( ) ;
! From git, include/catalog/pg_type.h
: BOOL-OID 16 ; inline
: BYTEA-OID 17 ; inline
: CHAR-OID 18 ; inline
: NAME-OID 19 ; inline
: INT8-OID 20 ; inline
: INT2-OID 21 ; inline
: INT4-OID 23 ; inline
: TEXT-OID 23 ; inline
: OID-OID 26 ; inline
: FLOAT4-OID 700 ; inline
: FLOAT8-OID 701 ; inline
: VARCHAR-OID 1043 ; inline
: DATE-OID 1082 ; inline
: TIME-OID 1083 ; inline
: TIMESTAMP-OID 1114 ; inline
: TIMESTAMPTZ-OID 1184 ; inline
: INTERVAL-OID 1186 ; inline
: NUMERIC-OID 1700 ; inline
CONSTANT: BOOL-OID 16
CONSTANT: BYTEA-OID 17
CONSTANT: CHAR-OID 18
CONSTANT: NAME-OID 19
CONSTANT: INT8-OID 20
CONSTANT: INT2-OID 21
CONSTANT: INT4-OID 23
CONSTANT: TEXT-OID 23
CONSTANT: OID-OID 26
CONSTANT: FLOAT4-OID 700
CONSTANT: FLOAT8-OID 701
CONSTANT: VARCHAR-OID 1043
CONSTANT: DATE-OID 1082
CONSTANT: TIME-OID 1083
CONSTANT: TIMESTAMP-OID 1114
CONSTANT: TIMESTAMPTZ-OID 1184
CONSTANT: INTERVAL-OID 1186
CONSTANT: NUMERIC-OID 1700

View File

@ -44,11 +44,11 @@ M: retryable execute-statement* ( statement type -- )
] bi attempt-all drop ;
: sql-props ( class -- columns table )
[ db-columns ] [ db-table ] bi ;
[ db-columns ] [ db-table-name ] bi ;
: query-make ( class quot -- statements )
#! query, input, outputs, secondary queries
over unparse "table" set
over db-table-name "table-name" set
[ sql-props ] dip
[ 0 sql-counter rot with-variable ] curry
{ "" { } { } { } } nmake

View File

@ -13,33 +13,33 @@ IN: db.sqlite.ffi
} 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
CONSTANT: SQLITE_OK 0 ! Successful result
CONSTANT: SQLITE_ERROR 1 ! SQL error or missing database
CONSTANT: SQLITE_INTERNAL 2 ! An internal logic error in SQLite
CONSTANT: SQLITE_PERM 3 ! Access permission denied
CONSTANT: SQLITE_ABORT 4 ! Callback routine requested an abort
CONSTANT: SQLITE_BUSY 5 ! The database file is locked
CONSTANT: SQLITE_LOCKED 6 ! A table in the database is locked
CONSTANT: SQLITE_NOMEM 7 ! A malloc() failed
CONSTANT: SQLITE_READONLY 8 ! Attempt to write a readonly database
CONSTANT: SQLITE_INTERRUPT 9 ! Operation terminated by sqlite_interrupt()
CONSTANT: SQLITE_IOERR 10 ! Some kind of disk I/O error occurred
CONSTANT: SQLITE_CORRUPT 11 ! The database disk image is malformed
CONSTANT: SQLITE_NOTFOUND 12 ! (Internal Only) Table or record not found
CONSTANT: SQLITE_FULL 13 ! Insertion failed because database is full
CONSTANT: SQLITE_CANTOPEN 14 ! Unable to open the database file
CONSTANT: SQLITE_PROTOCOL 15 ! Database lock protocol error
CONSTANT: SQLITE_EMPTY 16 ! (Internal Only) Database table is empty
CONSTANT: SQLITE_SCHEMA 17 ! The database schema changed
CONSTANT: SQLITE_TOOBIG 18 ! Too much data for one row of a table
CONSTANT: SQLITE_CONSTRAINT 19 ! Abort due to contraint violation
CONSTANT: SQLITE_MISMATCH 20 ! Data type mismatch
CONSTANT: SQLITE_MISUSE 21 ! Library used incorrectly
CONSTANT: SQLITE_NOLFS 22 ! Uses OS features not supported on host
CONSTANT: SQLITE_AUTH 23 ! Authorization denied
CONSTANT: SQLITE_FORMAT 24 ! Auxiliary database format error
CONSTANT: SQLITE_RANGE 25 ! 2nd parameter to sqlite3_bind out of range
CONSTANT: SQLITE_NOTADB 26 ! File opened that is not a database file
: sqlite-error-messages ( -- seq ) {
"Successful result"
@ -72,32 +72,32 @@ IN: db.sqlite.ffi
} ;
! Return values from sqlite3_step
: SQLITE_ROW 100 ; inline
: SQLITE_DONE 101 ; inline
CONSTANT: SQLITE_ROW 100
CONSTANT: SQLITE_DONE 101
! 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
CONSTANT: SQLITE_INTEGER 1
CONSTANT: SQLITE_FLOAT 2
CONSTANT: SQLITE_TEXT 3
CONSTANT: SQLITE_BLOB 4
CONSTANT: SQLITE_NULL 5
! Values for the 'destructor' parameter of the 'bind' routines.
: SQLITE_STATIC 0 ; inline
: SQLITE_TRANSIENT -1 ; inline
CONSTANT: SQLITE_STATIC 0
CONSTANT: SQLITE_TRANSIENT -1
: 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
CONSTANT: SQLITE_OPEN_READONLY HEX: 00000001
CONSTANT: SQLITE_OPEN_READWRITE HEX: 00000002
CONSTANT: SQLITE_OPEN_CREATE HEX: 00000004
CONSTANT: SQLITE_OPEN_DELETEONCLOSE HEX: 00000008
CONSTANT: SQLITE_OPEN_EXCLUSIVE HEX: 00000010
CONSTANT: SQLITE_OPEN_MAIN_DB HEX: 00000100
CONSTANT: SQLITE_OPEN_TEMP_DB HEX: 00000200
CONSTANT: SQLITE_OPEN_TRANSIENT_DB HEX: 00000400
CONSTANT: SQLITE_OPEN_MAIN_JOURNAL HEX: 00000800
CONSTANT: SQLITE_OPEN_TEMP_JOURNAL HEX: 00001000
CONSTANT: SQLITE_OPEN_SUBJOURNAL HEX: 00002000
CONSTANT: SQLITE_OPEN_MASTER_JOURNAL HEX: 00004000
TYPEDEF: void sqlite3
TYPEDEF: void sqlite3_stmt

View File

@ -73,3 +73,57 @@ IN: db.sqlite.tests
"select * from person" sql-query length
] with-db
] unit-test
! You don't need a primary key
USING: accessors arrays sorting ;
TUPLE: things one two ;
things "THINGS" {
{ "one" "ONE" INTEGER +not-null+ }
{ "two" "TWO" INTEGER +not-null+ }
} define-persistent
[ { { 0 0 } { 0 1 } { 1 0 } { 1 1 } } ] [
test.db [
things create-table
0 0 things boa insert-tuple
0 1 things boa insert-tuple
1 1 things boa insert-tuple
1 0 things boa insert-tuple
f f things boa select-tuples
[ [ one>> ] [ two>> ] bi 2array ] map natural-sort
things drop-table
] with-db
] unit-test
! Tables can have different names than the name of the tuple
TUPLE: foo slot ;
C: <foo> foo
foo "BAR" { { "slot" "SOMETHING" INTEGER +not-null+ } } define-persistent
TUPLE: hi bye try ;
C: <hi> hi
hi "HELLO" {
{ "bye" "BUHBYE" INTEGER { +foreign-id+ foo "SOMETHING" } }
{ "try" "RETHROW" INTEGER { +foreign-id+ foo "SOMETHING" } }
} define-persistent
[ T{ foo { slot 1 } } T{ hi { bye 1 } { try 1 } } ] [
test.db [
foo create-table
hi create-table
1 <foo> insert-tuple
f <foo> select-tuple
1 1 <hi> insert-tuple
f <hi> select-tuple
hi drop-table
foo drop-table
] with-db
] unit-test
[ ] [
test.db [
hi create-table
hi drop-table
] with-db
] unit-test

View File

@ -138,11 +138,13 @@ M: sqlite-db-connection create-sql-statement ( class -- statement )
modifiers 0%
] interleave
", " 0%
find-primary-key
"primary key(" 0%
[ "," 0% ] [ column-name>> 0% ] interleave
"));" 0%
find-primary-key [
", " 0%
"primary key(" 0%
[ "," 0% ] [ column-name>> 0% ] interleave
")" 0%
] unless-empty
");" 0%
] query-make ;
M: sqlite-db-connection drop-sql-statement ( class -- statement )
@ -223,11 +225,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: insert-trigger ( -- string )
[
<"
CREATE TRIGGER fki_${table}_${foreign-table}_id
BEFORE INSERT ON ${table}
CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
@ -235,12 +237,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: insert-trigger-not-null ( -- string )
[
<"
CREATE TRIGGER fki_${table}_${foreign-table}_id
BEFORE INSERT ON ${table}
CREATE TRIGGER fki_${table-name}_${foreign-table-name}_id
BEFORE INSERT ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'insert on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
SELECT RAISE(ROLLBACK, 'insert on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE NEW.${foreign-table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
@ -248,11 +250,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: update-trigger ( -- string )
[
<"
CREATE TRIGGER fku_${table}_${foreign-table}_id
BEFORE UPDATE ON ${table}
CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
@ -260,12 +262,12 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: update-trigger-not-null ( -- string )
[
<"
CREATE TRIGGER fku_${table}_${foreign-table}_id
BEFORE UPDATE ON ${table}
CREATE TRIGGER fku_${table-name}_${foreign-table-name}_id
BEFORE UPDATE ON ${table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'update on table "${table}" violates foreign key constraint "fk_${foreign-table}_id"')
SELECT RAISE(ROLLBACK, 'update on table "${table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE NEW.${foreign-table-id} IS NOT NULL
AND (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
AND (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = NEW.${table-id}) IS NULL;
END;
"> interpolate
] with-string-writer ;
@ -273,11 +275,11 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: delete-trigger-restrict ( -- string )
[
<"
CREATE TRIGGER fkd_${table}_${foreign-table}_id
BEFORE DELETE ON ${foreign-table}
CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table}" violates foreign key constraint "fk_${foreign-table}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
SELECT RAISE(ROLLBACK, 'delete on table "${foreign-table-name}" violates foreign key constraint "fk_${foreign-table-name}_id"')
WHERE (SELECT ${foreign-table-id} FROM ${foreign-table-name} WHERE ${foreign-table-id} = OLD.${foreign-table-id}) IS NOT NULL;
END;
"> interpolate
] with-string-writer ;
@ -285,10 +287,10 @@ M: sqlite-db-connection persistent-table ( -- assoc )
: delete-trigger-cascade ( -- string )
[
<"
CREATE TRIGGER fkd_${table}_${foreign-table}_id
BEFORE DELETE ON ${foreign-table}
CREATE TRIGGER fkd_${table-name}_${foreign-table-name}_id
BEFORE DELETE ON ${foreign-table-name}
FOR EACH ROW BEGIN
DELETE from ${table} WHERE ${table-id} = OLD.${foreign-table-id};
DELETE from ${table-name} WHERE ${table-id} = OLD.${foreign-table-id};
END;
"> interpolate
] with-string-writer ;
@ -321,7 +323,7 @@ M: sqlite-db-connection compound ( string seq -- new-string )
{ "default" [ first number>string " " glue ] }
{ "references" [
[ >reference-string ] keep
first2 [ "foreign-table" set ]
first2 [ db-table-name "foreign-table-name" set ]
[ "foreign-table-id" set ] bi*
create-sqlite-triggers
] }

View File

@ -49,7 +49,7 @@ ERROR: no-slot ;
ERROR: not-persistent class ;
: db-table ( class -- object )
: db-table-name ( class -- object )
dup "db-table" word-prop [ ] [ not-persistent ] ?if ;
: db-columns ( class -- object )
@ -165,7 +165,7 @@ ERROR: no-column column ;
: >reference-string ( string pair -- string )
first2
[ [ unparse " " glue ] [ db-columns ] bi ] dip
[ [ db-table-name " " glue ] [ db-columns ] bi ] dip
swap [ column-name>> = ] with find nip
[ no-column ] unless*
column-name>> "(" ")" surround append ;

View File

@ -1,9 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov.
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser lexer kernel namespaces sequences definitions
io.files io.backend io.pathnames io summary continuations
tools.crossref tools.vocabs prettyprint source-files assocs
vocabs vocabs.loader splitting accessors ;
vocabs vocabs.loader splitting accessors debugger prettyprint
help.topics ;
IN: editors
TUPLE: no-edit-hook ;
@ -29,11 +30,21 @@ SYMBOL: edit-hook
[ (normalize-path) ] dip edit-hook get-global
[ call ] [ no-edit-hook edit-location ] if* ;
ERROR: cannot-find-source definition ;
M: cannot-find-source error.
"Cannot find source for ``" write
definition>> pprint-short
"''" print ;
: edit ( defspec -- )
where [ first2 edit-location ] when* ;
dup where
[ first2 edit-location ]
[ dup word-link? [ name>> edit ] [ cannot-find-source ] if ]
?if ;
: edit-vocab ( name -- )
vocab-source-path 1 edit-location ;
>vocab-link edit ;
GENERIC: error-file ( error -- file )

View File

@ -57,7 +57,10 @@ HELP: hidden
{ $description "Hidden components render as a hidden form field. For example, a page for editing a weblog post might contain a hidden field with the post ID." } ;
HELP: html
{ $description "HTML components render HTML verbatim, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
{ $description "HTML components render HTML verbatim from a string, without any escaping. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
HELP: xml
{ $description "XML components render XML verbatim, from an XML chunk. Care must be taken to only render trusted input, to avoid cross-site scripting attacks." } ;
HELP: inspector
{ $description "Inspector components render an arbitrary object by passing it to the " { $link describe } " word." } ;
@ -90,6 +93,7 @@ $nl
{ $subsection inspector }
{ $subsection comparison }
{ $subsection html }
{ $subsection xml }
"Tuple components:"
{ $subsection field }
{ $subsection password }

View File

@ -171,3 +171,8 @@ M: comparison render*
SINGLETON: html
M: html render* 2drop <unescaped> ;
! XML component
SINGLETON: xml
M: xml render* 2drop ;

View File

@ -1,8 +1,8 @@
IN: html.templates.chloe
USING: help.markup help.syntax html.components html.forms
USING: xml.data help.markup help.syntax html.components html.forms
html.templates html.templates.chloe.syntax
html.templates.chloe.compiler html.templates.chloe.components
math xml.data strings quotations namespaces ;
math strings quotations namespaces ;
HELP: <chloe>
{ $values { "path" "a pathname string without the trailing " { $snippet ".xml" } " extension" } { "chloe" chloe } }
@ -70,6 +70,7 @@ ARTICLE: "html.templates.chloe.tags.component" "Component Chloe tags"
{ { $snippet "t:field" } { $link field } }
{ { $snippet "t:hidden" } { $link hidden } }
{ { $snippet "t:html" } { $link html } }
{ { $snippet "t:xml" } { $link xml } }
{ { $snippet "t:inspector" } { $link inspector } }
{ { $snippet "t:label" } { $link label } }
{ { $snippet "t:link" } { $link link } }

View File

@ -95,6 +95,7 @@ COMPONENT: password
COMPONENT: choice
COMPONENT: checkbox
COMPONENT: code
COMPONENT: xml
SYMBOL: template-cache

View File

@ -1,51 +0,0 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel grouping fry sequences combinators
math ;
IN: images.backend
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
TUPLE: image dim component-order bitmap ;
TUPLE: normalized-image < image ;
GENERIC: load-image* ( path tuple -- image )
GENERIC: >image ( object -- image )
: no-op ( -- ) ;
: normalize-component-order ( image -- image )
dup component-order>>
{
{ RGBA [ no-op ] }
{ BGRA [
[
[ 4 <sliced-groups> [ [ 0 3 ] dip <slice> reverse-here ] each ]
[ RGBA >>component-order ] bi
] change-bitmap
] }
{ RGB [
[ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
] }
{ BGR [
[
3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
[ 255 suffix ] map concat
] change-bitmap
] }
} case RGBA >>component-order ;
GENERIC: normalize-scan-line-order ( image -- image )
M: image normalize-scan-line-order ;
: normalize-image ( image -- image )
normalize-component-order
normalize-scan-line-order ;
: new-image ( dim component-order bitmap class -- image )
new
swap >>bitmap
swap >>component-order
swap >>dim ; inline

View File

@ -3,16 +3,16 @@ io.files io.files.unique kernel tools.test ;
IN: images.bitmap.tests
: test-bitmap24 ( -- path )
"resource:extra/images/test-images/thiswayup24.bmp" ;
"resource:basis/images/test-images/thiswayup24.bmp" ;
: test-bitmap8 ( -- path )
"resource:extra/images/test-images/rgb8bit.bmp" ;
"resource:basis/images/test-images/rgb8bit.bmp" ;
: test-bitmap4 ( -- path )
"resource:extra/images/test-images/rgb4bit.bmp" ;
"resource:basis/images/test-images/rgb4bit.bmp" ;
: test-bitmap1 ( -- path )
"resource:extra/images/test-images/1bit.bmp" ;
"resource:basis/images/test-images/1bit.bmp" ;
[ t ]
[

View File

@ -1,10 +1,9 @@
! Copyright (C) 2007, 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien alien.c-types arrays byte-arrays columns
combinators fry grouping io io.binary io.encodings.binary
io.files kernel libc macros math math.bitwise math.functions
namespaces opengl opengl.gl prettyprint sequences strings
summary ui ui.gadgets.panes images.backend ;
combinators fry grouping io io.binary io.encodings.binary io.files
kernel macros math math.bitwise math.functions namespaces sequences
strings images endian summary ;
IN: images.bitmap
TUPLE: bitmap-image < image ;
@ -102,12 +101,13 @@ ERROR: unknown-component-order bitmap ;
[ unknown-component-order ]
} case ;
M: bitmap >image ( bitmap -- bitmap-image )
: >image ( bitmap -- bitmap-image )
{
[ [ width>> ] [ height>> ] bi 2array ]
[ bitmap>component-order ]
[ drop little-endian ] ! XXX
[ buffer>> ]
} cleave bitmap-image new-image ;
} cleave bitmap-image boa ;
M: bitmap-image load-image* ( path bitmap -- bitmap-image )
drop load-bitmap >image ;

View File

@ -1,21 +1,41 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators
accessors images.bitmap images.tiff images.backend io.backend
io.pathnames ;
USING: kernel accessors grouping sequences combinators ;
IN: images
ERROR: unknown-image-extension extension ;
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
: image-class ( path -- class )
file-extension >lower {
{ "bmp" [ bitmap-image ] }
{ "tiff" [ tiff-image ] }
[ unknown-image-extension ]
} case ;
TUPLE: image dim component-order byte-order bitmap ;
: load-image ( path -- image )
dup image-class new load-image* ;
: <image> ( -- image ) image new ; inline
: <image> ( path -- image )
load-image normalize-image ;
GENERIC: load-image* ( path tuple -- image )
: normalize-component-order ( image -- image )
dup component-order>>
{
{ RGBA [ ] }
{ BGRA [
[
4 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
] change-bitmap
] }
{ RGB [
[ 3 <sliced-groups> [ 255 suffix ] map concat ] change-bitmap
] }
{ BGR [
[
3 <sliced-groups> dup [ [ 0 3 ] dip <slice> reverse-here ] each
[ 255 suffix ] map concat
] change-bitmap
] }
} case
RGBA >>component-order ;
GENERIC: normalize-scan-line-order ( image -- image )
M: image normalize-scan-line-order ;
: normalize-image ( image -- image )
normalize-component-order
normalize-scan-line-order ;

View File

@ -0,0 +1 @@
Doug Coleman

View File

@ -0,0 +1,18 @@
! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators
accessors images.bitmap images.tiff images io.backend
io.pathnames ;
IN: images.loader
ERROR: unknown-image-extension extension ;
: image-class ( path -- class )
file-extension >lower {
{ "bmp" [ bitmap-image ] }
{ "tiff" [ tiff-image ] }
[ unknown-image-extension ]
} case ;
: load-image ( path -- image )
dup image-class new load-image* normalize-image ;

View File

Before

Width:  |  Height:  |  Size: 1.6 KiB

After

Width:  |  Height:  |  Size: 1.6 KiB

View File

Before

Width:  |  Height:  |  Size: 5.2 KiB

After

Width:  |  Height:  |  Size: 5.2 KiB

View File

Before

Width:  |  Height:  |  Size: 11 KiB

After

Width:  |  Height:  |  Size: 11 KiB

View File

Before

Width:  |  Height:  |  Size: 59 KiB

After

Width:  |  Height:  |  Size: 59 KiB

View File

@ -3,7 +3,7 @@
USING: accessors combinators io io.encodings.binary io.files kernel
pack endian constructors sequences arrays math.order math.parser
prettyprint classes io.binary assocs math math.bitwise byte-arrays
grouping images.backend ;
grouping images compression.lzw fry ;
IN: images.tiff
TUPLE: tiff-image < image ;
@ -256,6 +256,20 @@ ERROR: bad-small-ifd-type n ;
dup ifd-entries>>
[ process-ifd-entry swap ] H{ } map>assoc >>processed-tags ;
ERROR: unhandled-compression compression ;
: (uncompress-strips) ( strips compression -- uncompressed-strips )
{
{ compression-none [ ] }
{ compression-lzw [ [ lzw-uncompress ] map ] }
[ unhandled-compression ]
} case ;
: uncompress-strips ( ifd -- ifd )
dup '[
_ compression find-tag (uncompress-strips)
] change-strips ;
: strips>bitmap ( ifd -- ifd )
dup strips>> concat >>bitmap ;
@ -268,25 +282,30 @@ ERROR: unknown-component-order ifd ;
[ unknown-component-order ]
} case ;
M: ifd >image ( ifd -- image )
: ifd>image ( ifd -- image )
{
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order ]
[ drop big-endian ] ! XXX
[ bitmap>> ]
} cleave tiff-image new-image ;
} cleave tiff-image boa ;
M: parsed-tiff >image ( image -- image )
ifds>> [ >image ] map first ;
: tiff>image ( image -- image )
ifds>> [ ifd>image ] map first ;
: load-tiff ( path -- parsed-tiff )
binary [
<parsed-tiff>
read-header dup endianness>> [
read-ifds
dup ifds>> [ process-ifd read-strips strips>bitmap drop ] each
dup ifds>> [
process-ifd read-strips
uncompress-strips
strips>bitmap drop
] each
] with-endianness
] with-file-reader ;
! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image )
drop load-tiff >image ;
drop load-tiff tiff>image ;

View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel.private slots.private math.private
classes.tuple.private ;
@ -51,7 +51,7 @@ DEFER: if
! Default
: ?if ( default cond true false -- )
pick [ roll 2drop call ] [ 2nip call ] if ; inline
pick [ drop [ drop ] 2dip call ] [ 2nip call ] if ; inline
! Slippers and dippers.
! Not declared inline because the compiler special-cases them
@ -138,6 +138,69 @@ DEFER: if
: 2tri@ ( u v w y x z quot -- )
dup dup 2tri* ; inline
! Quotation building
: 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline
: 3curry ( obj1 obj2 obj3 quot -- curry )
curry curry curry ; inline
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: prepose ( quot1 quot2 -- compose )
swap compose ; inline
! Curried cleavers
<PRIVATE
: [curry] ( quot -- quot' ) [ curry ] curry ; inline
PRIVATE>
: bi-curry ( x p q -- p' q' ) [ [curry] ] bi@ bi ; inline
: tri-curry ( x p q r -- p' q' r' ) [ [curry] ] tri@ tri ; inline
: bi-curry* ( x y p q -- p' q' ) [ [curry] ] bi@ bi* ; inline
: tri-curry* ( x y z p q r -- p' q' r' ) [ [curry] ] tri@ tri* ; inline
: bi-curry@ ( x y q -- p' q' ) [curry] bi@ ; inline
: tri-curry@ ( x y z q -- p' q' r' ) [curry] tri@ ; inline
! Booleans
: not ( obj -- ? ) [ f ] [ t ] if ; inline
: and ( obj1 obj2 -- ? ) over ? ; inline
: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
: or ( obj1 obj2 -- ? ) dupd ? ; inline
: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
: both? ( x y quot -- ? ) bi@ and ; inline
: either? ( x y quot -- ? ) bi@ or ; inline
: most ( x y quot -- z )
[ 2dup ] dip call [ drop ] [ nip ] if ; inline
! Loops
: loop ( pred: ( -- ? ) -- )
[ call ] keep [ loop ] curry when ; inline recursive
: do ( pred body tail -- pred body tail )
over 3dip ; inline
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
[ pick 3dip [ do while ] 3curry ] keep if ; inline recursive
: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
[ [ not ] compose ] 2dip while ; inline
! Object protocol
GENERIC: hashcode* ( depth obj -- code )
@ -171,50 +234,6 @@ GENERIC: new ( class -- tuple )
GENERIC: boa ( ... class -- tuple )
! Quotation building
: 2curry ( obj1 obj2 quot -- curry )
curry curry ; inline
: 3curry ( obj1 obj2 obj3 quot -- curry )
curry curry curry ; inline
: with ( param obj quot -- obj curry )
swapd [ swapd call ] 2curry ; inline
: prepose ( quot1 quot2 -- compose )
swap compose ; inline
! Booleans
: not ( obj -- ? ) [ f ] [ t ] if ; inline
: and ( obj1 obj2 -- ? ) over ? ; inline
: >boolean ( obj -- ? ) [ t ] [ f ] if ; inline
: or ( obj1 obj2 -- ? ) dupd ? ; inline
: xor ( obj1 obj2 -- ? ) [ f swap ? ] when* ; inline
: both? ( x y quot -- ? ) bi@ and ; inline
: either? ( x y quot -- ? ) bi@ or ; inline
: most ( x y quot -- z )
[ 2dup ] dip call [ drop ] [ nip ] if ; inline
! Loops
: loop ( pred: ( -- ? ) -- )
dup slip swap [ loop ] [ drop ] if ; inline recursive
: do ( pred body tail -- pred body tail )
over 3dip ; inline
: while ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
[ pick 3dip [ do while ] 3curry ] keep if ; inline recursive
: until ( pred: ( -- ? ) body: ( -- ) tail: ( -- ) -- )
[ [ not ] compose ] 2dip while ; inline
! Error handling -- defined early so that other files can
! throw errors before continuations are loaded
: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;

View File

@ -1,6 +1,6 @@
! Copyright (C) 2007 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.backend io.pathnames kernel
USING: accessors images images.loader io.pathnames kernel
namespaces opengl opengl.gl sequences strings ui ui.gadgets
ui.gadgets.panes ui.render ;
IN: images.viewer
@ -23,15 +23,15 @@ M: image-gadget draw-gadget* ( gadget -- )
swap >>image ;
: image-window ( path -- gadget )
[ <image> <image-gadget> dup ] [ open-window ] bi ;
[ load-image <image-gadget> dup ] [ open-window ] bi ;
GENERIC: image. ( object -- )
: default-image. ( path -- )
<image-gadget> gadget. ;
M: string image. ( image -- ) <image> default-image. ;
M: string image. ( image -- ) load-image default-image. ;
M: pathname image. ( image -- ) <image> default-image. ;
M: pathname image. ( image -- ) load-image default-image. ;
M: image image. ( image -- ) default-image. ;

View File

@ -5,8 +5,8 @@ system tools.hexdump io.encodings.binary summary accessors
io.backend byte-arrays ;
IN: tar
: zero-checksum 256 ; inline
: block-size 512 ; inline
CONSTANT: zero-checksum 256
CONSTANT: block-size 512
TUPLE: tar-header name mode uid gid size mtime checksum typeflag
linkname magic version uname gname devmajor devminor prefix ;
@ -89,8 +89,7 @@ M: unknown-typeflag summary ( obj -- str )
! Symlink
: typeflag-2 ( header -- )
[ name>> ] [ linkname>> ] bi
[ make-link ] 2curry ignore-errors ;
[ name>> ] [ linkname>> ] bi make-link ;
! character special
: typeflag-3 ( header -- ) unknown-typeflag ;

View File

@ -4,7 +4,7 @@ USING: accessors colors arrays kernel sequences math byte-arrays
namespaces grouping fry cap images.bitmap
ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids
ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons
ui.render ui opengl opengl.gl images ;
ui.render ui opengl opengl.gl images images.loader ;
IN: ui.render.test
SINGLETON: line-test
@ -38,7 +38,7 @@ SYMBOL: render-output
screenshot
[ render-output set-global ]
[
"resource:extra/ui/render/test/reference.bmp" <image>
"resource:extra/ui/render/test/reference.bmp" load-image
bitmap= "is perfect" "needs work" ?
"Your UI rendering " prepend
message-window