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

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

db4
Daniel Ehrenberg 2009-02-12 17:14:20 -06:00
parent c4f45e3f74 1f6c50fd91
commit 4e5b7bfa21
32 changed files with 297 additions and 257 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
basis/alien/complex/complex.factor
View File

@ -1,6 +1,13 @@
! Copyright (C) 2009 Slava Pestov. ! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! 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 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
>>

11
basis/alien/structs/structs.factor
View File

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

6
basis/bootstrap/image/image-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io io.files io.pathnames ; USING: help.markup help.syntax io io.files io.pathnames strings ;
IN: bootstrap.image IN: bootstrap.image
ARTICLE: "bootstrap.image" "Bootstrapping new images" ARTICLE: "bootstrap.image" "Bootstrapping new images"
@ -14,7 +14,7 @@ $nl
ABOUT: "bootstrap.image" ABOUT: "bootstrap.image"
HELP: make-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:" { $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" } "." } ; "The new image file is written to the " { $link resource-path } " and is named " { $snippet "boot." { $emphasis "architecture" } ".image" } "." } ;

4
basis/combinators/smart/smart-tests.factor
View File

@ -44,4 +44,6 @@ IN: combinators.smart.tests
\ nested-smart-combo-test must-infer \ 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

6
basis/combinators/smart/smart.factor
View File

@ -21,6 +21,12 @@ MACRO: reduce-outputs ( quot operation -- newquot )
: sum-outputs ( quot -- n ) : sum-outputs ( quot -- n )
[ + ] reduce-outputs ; inline [ + ] 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 ) MACRO: append-outputs-as ( quot exemplar -- newquot )
[ dup infer out>> ] dip '[ @ _ _ nappend-as ] ; [ dup infer out>> ] dip '[ @ _ _ nappend-as ] ;

2
basis/compiler/alien/alien.factor
View File

@ -5,7 +5,7 @@ alien.c-types alien.structs cpu.architecture ;
IN: compiler.alien IN: compiler.alien
: large-struct? ( ctype -- ? ) : 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 ) : alien-parameters ( params -- seq )
dup parameters>> dup parameters>>

2
basis/cpu/architecture/architecture.factor
View File

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

2
basis/cpu/ppc/ppc.factor
View File

@ -659,7 +659,7 @@ M: ppc %callback-value ( ctype -- )
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ; 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 M: ppc %box-small-struct
drop "No small structs" throw ; drop "No small structs" throw ;

9
basis/cpu/x86/32/32.factor
View File

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

2
basis/cpu/x86/64/unix/unix.factor
View File

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

3
basis/cpu/x86/64/winnt/winnt.factor
View File

@ -10,7 +10,8 @@ M: float-regs param-regs drop { XMM0 XMM1 XMM2 XMM3 } ;
M: x86.64 reserved-area-size 4 cells ; M: x86.64 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? ; M: x86.64 value-struct? heap-size { 1 2 4 8 } member? ;

98
basis/db/postgresql/ffi/ffi.factor
View File

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

96
basis/db/sqlite/ffi/ffi.factor
View File

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

19
basis/editors/editors.factor
View File

@ -1,9 +1,10 @@
! Copyright (C) 2005, 2008 Slava Pestov. ! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: parser lexer kernel namespaces sequences definitions USING: parser lexer kernel namespaces sequences definitions
io.files io.backend io.pathnames io summary continuations io.files io.backend io.pathnames io summary continuations
tools.crossref tools.vocabs prettyprint source-files assocs tools.crossref tools.vocabs prettyprint source-files assocs
vocabs vocabs.loader splitting accessors ; vocabs vocabs.loader splitting accessors debugger prettyprint
help.topics ;
IN: editors IN: editors
TUPLE: no-edit-hook ; TUPLE: no-edit-hook ;
@ -29,11 +30,21 @@ SYMBOL: edit-hook
[ (normalize-path) ] dip edit-hook get-global [ (normalize-path) ] dip edit-hook get-global
[ call ] [ no-edit-hook edit-location ] if* ; [ 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 -- ) : 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 -- ) : edit-vocab ( name -- )
vocab-source-path 1 edit-location ; >vocab-link edit ;
GENERIC: error-file ( error -- file ) GENERIC: error-file ( error -- file )

1
basis/images/backend/authors.txt
View File

@ -1 +0,0 @@
Doug Coleman

51
basis/images/backend/backend.factor
View File

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

8
basis/images/bitmap/bitmap-tests.factor
View File

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

12
basis/images/bitmap/bitmap.factor
View File

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

49
basis/images/images.factor
View File

@ -1,21 +1,42 @@
! Copyright (C) 2009 Doug Coleman. ! Copyright (C) 2009 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: constructors kernel splitting unicode.case combinators USING: kernel accessors grouping sequences combinators ;
accessors images.bitmap images.tiff images.backend io.backend
io.pathnames ;
IN: images IN: images
ERROR: unknown-image-extension extension ; SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR ;
: image-class ( path -- class ) TUPLE: image dim component-order byte-order bitmap ;
file-extension >lower {
{ "bmp" [ bitmap-image ] }
{ "tiff" [ tiff-image ] }
[ unknown-image-extension ]
} case ;
: load-image ( path -- image ) : <image> ( -- image ) image new ; inline
dup image-class new load-image* ;
: <image> ( path -- image ) GENERIC: load-image* ( path tuple -- image )
load-image normalize-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 ;

1
basis/images/loader/authors.txt Normal file
View File

@ -0,0 +1 @@
Doug Coleman

18
basis/images/loader/loader.factor Normal file
View File

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

0
extra/images/test-images/1bit.bmp → basis/images/test-images/1bit.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 1.6 KiB

After

Width:  |  Height:  |  Size: 1.6 KiB

0
extra/images/test-images/octagon.tiff → basis/images/test-images/octagon.tiff
View File

0
extra/images/test-images/rgb.tiff → basis/images/test-images/rgb.tiff
View File

0
extra/images/test-images/rgb4bit.bmp → basis/images/test-images/rgb4bit.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 5.2 KiB

After

Width:  |  Height:  |  Size: 5.2 KiB

0
extra/images/test-images/rgb8bit.bmp → basis/images/test-images/rgb8bit.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 11 KiB

After

Width:  |  Height:  |  Size: 11 KiB

0
extra/images/test-images/thiswayup24.bmp → basis/images/test-images/thiswayup24.bmp
View File

Side by Side Swipe Overlay

Before

Width:  |  Height:  |  Size: 59 KiB

After

Width:  |  Height:  |  Size: 59 KiB

13
basis/images/tiff/tiff.factor
View File

@ -3,7 +3,7 @@
USING: accessors combinators io io.encodings.binary io.files kernel USING: accessors combinators io io.encodings.binary io.files kernel
pack endian constructors sequences arrays math.order math.parser pack endian constructors sequences arrays math.order math.parser
prettyprint classes io.binary assocs math math.bitwise byte-arrays prettyprint classes io.binary assocs math math.bitwise byte-arrays
grouping images.backend ; grouping images ;
IN: images.tiff IN: images.tiff
TUPLE: tiff-image < image ; TUPLE: tiff-image < image ;
@ -268,15 +268,16 @@ ERROR: unknown-component-order ifd ;
[ unknown-component-order ] [ unknown-component-order ]
} case ; } case ;
M: ifd >image ( ifd -- image ) : ifd>image ( ifd -- image )
{ {
[ [ image-width find-tag ] [ image-length find-tag ] bi 2array ] [ [ image-width find-tag ] [ image-length find-tag ] bi 2array ]
[ ifd-component-order ] [ ifd-component-order ]
[ drop big-endian ] ! XXX
[ bitmap>> ] [ bitmap>> ]
} cleave tiff-image new-image ; } cleave tiff-image boa ;
M: parsed-tiff >image ( image -- image ) : tiff>image ( image -- image )
ifds>> [ >image ] map first ; ifds>> [ ifd>image ] map first ;
: load-tiff ( path -- parsed-tiff ) : load-tiff ( path -- parsed-tiff )
binary [ binary [
@ -289,4 +290,4 @@ M: parsed-tiff >image ( image -- image )
! tiff files can store several images -- we just take the first for now ! tiff files can store several images -- we just take the first for now
M: tiff-image load-image* ( path tiff-image -- image ) M: tiff-image load-image* ( path tiff-image -- image )
drop load-tiff >image ; drop load-tiff tiff>image ;

111
core/kernel/kernel.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2004, 2008 Slava Pestov. ! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel.private slots.private math.private USING: kernel.private slots.private math.private
classes.tuple.private ; classes.tuple.private ;
@ -51,7 +51,7 @@ DEFER: if
! Default ! Default
: ?if ( default cond true false -- ) : ?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. ! Slippers and dippers.
! Not declared inline because the compiler special-cases them ! Not declared inline because the compiler special-cases them
@ -138,6 +138,69 @@ DEFER: if
: 2tri@ ( u v w y x z quot -- ) : 2tri@ ( u v w y x z quot -- )
dup dup 2tri* ; inline 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 ! Object protocol
GENERIC: hashcode* ( depth obj -- code ) GENERIC: hashcode* ( depth obj -- code )
@ -171,50 +234,6 @@ GENERIC: new ( class -- tuple )
GENERIC: boa ( ... 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 ! Error handling -- defined early so that other files can
! throw errors before continuations are loaded ! throw errors before continuations are loaded
: throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ; : throw ( error -- * ) 5 getenv [ die ] or 1 (throw) ;

8
extra/images/viewer/viewer.factor
View File

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

7
extra/tar/tar.factor
View File

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

4
extra/ui/render/test/test.factor
View File

@ -4,7 +4,7 @@ USING: accessors colors arrays kernel sequences math byte-arrays
namespaces grouping fry cap images.bitmap namespaces grouping fry cap images.bitmap
ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids ui.gadgets ui.gadgets.packs ui.gadgets.borders ui.gadgets.grids
ui.gadgets.grid-lines ui.gadgets.labels ui.gadgets.buttons 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 IN: ui.render.test
SINGLETON: line-test SINGLETON: line-test
@ -38,7 +38,7 @@ SYMBOL: render-output
screenshot screenshot
[ render-output set-global ] [ 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" ? bitmap= "is perfect" "needs work" ?
"Your UI rendering " prepend "Your UI rendering " prepend
message-window message-window