Merge branch 'master' of git://factorcode.org/git/factor
Daniel Ehrenberg
commit
4e5b7bfa21
|
|
@ -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 ;
|
||||
|
|
|
|||
|
|
@ -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>>
|
||||
|
|
|
|||
|
|
@ -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? ;
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 )
|
||||
|
||||
|
|
|
|||
|
|
@ -1 +0,0 @@
|
|||
Doug Coleman
|
||||
|
|
@ -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,42 @@
|
|||
! 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> [ [ 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 ;
|
||||
|
|
|
|||
|
|
@ -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 ;
|
||||
IN: images.tiff
|
||||
|
||||
TUPLE: tiff-image < image ;
|
||||
|
|
@ -268,15 +268,16 @@ 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 [
|
||||
|
|
@ -289,4 +290,4 @@ M: parsed-tiff >image ( image -- image )
|
|||
|
||||
! 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