Merge branch 'master' of git://factorcode.org/git/factor
Joe Groff
commit
e3f531cba4
|
|
@ -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
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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" } "." } ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ] ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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>>
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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 ) ;
|
||||
|
|
@ -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
|
||||
|
|
@ -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 ;
|
||||
|
|
@ -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 -- ? )
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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* ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
] }
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -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 }
|
||||
|
|
|
|||
|
|
@ -171,3 +171,8 @@ M: comparison render*
|
|||
SINGLETON: html
|
||||
|
||||
M: html render* 2drop <unescaped> ;
|
||||
|
||||
! XML component
|
||||
SINGLETON: xml
|
||||
|
||||
M: xml render* 2drop ;
|
||||
|
|
|
|||
|
|
@ -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 } }
|
||||
|
|
|
|||
|
|
@ -95,6 +95,7 @@ COMPONENT: password
|
|||
COMPONENT: choice
|
||||
COMPONENT: checkbox
|
||||
COMPONENT: code
|
||||
COMPONENT: xml
|
||||
|
||||
SYMBOL: template-cache
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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 ]
|
||||
[
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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 ;
|
||||
|
Before Width: | Height: | Size: 1.6 KiB After Width: | Height: | Size: 1.6 KiB |
|
Before Width: | Height: | Size: 5.2 KiB After Width: | Height: | Size: 5.2 KiB |
|
Before Width: | Height: | Size: 11 KiB After Width: | Height: | Size: 11 KiB |
|
Before Width: | Height: | Size: 59 KiB After Width: | Height: | Size: 59 KiB |
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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) ;
|
||||
|
|
|
|||
|
|
@ -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. ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
Loading…
Reference in New Issue