diff --git a/Factor.app/Contents/Resources/English.lproj/Factor.nib/classes.nib b/Factor.app/Contents/Resources/English.lproj/Factor.nib/classes.nib
index bf3d2a6560..6a6eedfcc0 100644
--- a/Factor.app/Contents/Resources/English.lproj/Factor.nib/classes.nib
+++ b/Factor.app/Contents/Resources/English.lproj/Factor.nib/classes.nib
@@ -1,17 +1,38 @@
-{
- IBClasses = (
- {
- ACTIONS = {
- newFactorWorkspace = id;
- runFactorFile = id;
- saveFactorImage = id;
- saveFactorImageAs = id;
- showFactorHelp = id;
- };
- CLASS = FirstResponder;
- LANGUAGE = ObjC;
- SUPERCLASS = NSObject;
- }
- );
- IBVersion = 1;
-}
\ No newline at end of file
+
+
+
+
+ IBClasses
+
+
+ ACTIONS
+
+ factorBrowser
+ id
+ factorListener
+ id
+ newFactorBrowser
+ id
+ newFactorListener
+ id
+ refreshAll
+ id
+ runFactorFile
+ id
+ saveFactorImage
+ id
+ saveFactorImageAs
+ id
+
+ CLASS
+ FirstResponder
+ LANGUAGE
+ ObjC
+ SUPERCLASS
+ NSObject
+
+
+ IBVersion
+ 1
+
+
diff --git a/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib b/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib
index 8e4b9eeba8..1096a1224a 100644
--- a/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib
+++ b/Factor.app/Contents/Resources/English.lproj/Factor.nib/info.nib
@@ -1,21 +1,18 @@
-
+
- IBDocumentLocation
- 557 119 525 491 0 0 2560 1578
- IBEditorPositions
-
- 29
- 326 905 270 44 0 0 2560 1578
-
IBFramework Version
- 439.0
+ 629
+ IBOldestOS
+ 5
IBOpenObjects
- 29
+ 305
IBSystem Version
- 8R218
+ 9G55
+ targetFramework
+ IBCocoaFramework
diff --git a/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib b/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib
index 8dfebba566..c30c9e4bfd 100644
Binary files a/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib and b/Factor.app/Contents/Resources/English.lproj/Factor.nib/keyedobjects.nib differ
diff --git a/README.txt b/README.txt
index d60bf03130..bd9da0ab2b 100755
--- a/README.txt
+++ b/README.txt
@@ -24,7 +24,7 @@ The Factor runtime is written in GNU C99, and is built with GNU make and
gcc.
Factor supports various platforms. For an up-to-date list, see
-.
+.
Factor requires gcc 3.4 or later.
@@ -36,17 +36,6 @@ arguments for make.
Run 'make' ('gmake' on *BSD) with no parameters to build the Factor VM.
-Compilation will yield an executable named 'factor' on Unix,
-'factor.exe' on Windows XP/Vista, and 'factor-ce.exe' on Windows CE.
-
-* Libraries needed for compilation
-
-For X11 support, you need recent development libraries for libc,
-Freetype, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
-(like Ubuntu), you can use the following line to grab everything:
-
- sudo apt-get install libc6-dev libfreetype6-dev libx11-dev glutg3-dev
-
* Bootstrapping the Factor image
Once you have compiled the Factor runtime, you must bootstrap the Factor
@@ -69,6 +58,12 @@ machines.
On Unix, Factor can either run a graphical user interface using X11, or
a terminal listener.
+For X11 support, you need recent development libraries for libc,
+Pango, X11, OpenGL and GLUT. On a Debian-derived Linux distribution
+(like Ubuntu), you can use the following line to grab everything:
+
+ sudo apt-get install libc6-dev libpango-1.0-dev libx11-dev glutg3-dev
+
If your DISPLAY environment variable is set, the UI will start
automatically:
@@ -78,14 +73,6 @@ To run an interactive terminal listener:
./factor -run=listener
-If you're inside a terminal session, you can start the UI with one of
-the following two commands:
-
- ui
- [ ui ] in-thread
-
-The latter keeps the terminal listener running.
-
* Running Factor on Mac OS X - Cocoa UI
On Mac OS X, a Cocoa UI is available in addition to the terminal
@@ -110,7 +97,7 @@ When compiling Factor, pass the X11=1 parameter:
Then bootstrap with the following switches:
- ./factor -i=boot..image -ui-backend=x11
+ ./factor -i=boot..image -ui-backend=x11 -ui-text-backend=pango
Now if $DISPLAY is set, running ./factor will start the UI.
@@ -126,6 +113,12 @@ the command prompt using the console application:
factor.com -i=boot..image
+Before bootstrapping, you will need to download the DLLs for the Pango
+text rendering library. The required DLLs are listed in
+build-support/dlls.txt and are available from the following location:
+
+
+
Once bootstrapped, double-clicking factor.exe or factor.com starts
the Factor UI.
@@ -135,7 +128,9 @@ To run the listener in the command prompt:
* The Factor FAQ
-The Factor FAQ is available at .
+The Factor FAQ is available at the following location:
+
+
* Command line usage
@@ -153,7 +148,6 @@ The Factor source tree is organized as follows:
core/ - Factor core library
basis/ - Factor basis library, compiler, tools
extra/ - more libraries and applications
- fonts/ - TrueType fonts used by UI
misc/ - editor modes, icons, etc
unmaintained/ - unmaintained contributions, please help!
diff --git a/basis/alien/destructors/authors.txt b/basis/alien/destructors/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/alien/destructors/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/alien/destructors/destructors-tests.factor b/basis/alien/destructors/destructors-tests.factor
new file mode 100644
index 0000000000..4f434452d4
--- /dev/null
+++ b/basis/alien/destructors/destructors-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test alien.destructors ;
+IN: alien.destructors.tests
diff --git a/basis/alien/destructors/destructors.factor b/basis/alien/destructors/destructors.factor
new file mode 100644
index 0000000000..6c55528b70
--- /dev/null
+++ b/basis/alien/destructors/destructors.factor
@@ -0,0 +1,29 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: functors destructors accessors kernel parser words ;
+IN: alien.destructors
+
+SLOT: alien
+
+FUNCTOR: define-destructor ( F -- )
+
+F-destructor DEFINES-CLASS ${F}-destructor
+ DEFINES <${F}-destructor>
+&F DEFINES &${F}
+|F DEFINES |${F}
+
+WHERE
+
+TUPLE: F-destructor alien disposed ;
+
+: ( alien -- destructor ) f F-destructor boa ; inline
+
+M: F-destructor dispose* alien>> F ;
+
+: &F ( alien -- alien ) dup &dispose drop ; inline
+
+: |F ( alien -- alien ) dup |dispose drop ; inline
+
+;FUNCTOR
+
+: DESTRUCTOR: scan-word define-destructor ; parsing
\ No newline at end of file
diff --git a/basis/alien/destructors/summary.txt b/basis/alien/destructors/summary.txt
new file mode 100644
index 0000000000..301655b50d
--- /dev/null
+++ b/basis/alien/destructors/summary.txt
@@ -0,0 +1 @@
+Functor for defining destructors which call a C function to dispose of resources
diff --git a/basis/alien/syntax/syntax.factor b/basis/alien/syntax/syntax.factor
index bed454e81d..987c73127e 100644
--- a/basis/alien/syntax/syntax.factor
+++ b/basis/alien/syntax/syntax.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2005, 2008 Slava Pestov, Alex Chapman.
+! Copyright (C) 2005, 2009 Slava Pestov, Alex Chapman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays alien alien.c-types alien.structs
alien.arrays alien.strings kernel math namespaces parser
diff --git a/basis/ascii/ascii.factor b/basis/ascii/ascii.factor
index 193e847d27..bd1b86b279 100644
--- a/basis/ascii/ascii.factor
+++ b/basis/ascii/ascii.factor
@@ -10,7 +10,7 @@ IN: ascii
: LETTER? ( ch -- ? ) CHAR: A CHAR: Z between? ; inline
: digit? ( ch -- ? ) CHAR: 0 CHAR: 9 between? ; inline
: printable? ( ch -- ? ) CHAR: \s CHAR: ~ between? ; inline
-: control? ( ch -- ? ) "\0\e\r\n\t\u000008\u00007f" member? ; inline
+: control? ( ch -- ? ) { [ 0 HEX: 1F between? ] [ HEX: 7F = ] } 1|| ; inline
: quotable? ( ch -- ? ) { [ printable? ] [ "\"\\" member? not ] } 1&& ; inline
: Letter? ( ch -- ? ) { [ letter? ] [ LETTER? ] } 1|| ; inline
: alpha? ( ch -- ? ) { [ Letter? ] [ digit? ] } 1|| ; inline
@@ -20,4 +20,4 @@ IN: ascii
: >upper ( str -- upper ) [ ch>upper ] map ;
HINTS: >lower string ;
-HINTS: >upper string ;
\ No newline at end of file
+HINTS: >upper string ;
diff --git a/basis/base64/base64-tests.factor b/basis/base64/base64-tests.factor
index dcc4aa5240..ddefff35bb 100644
--- a/basis/base64/base64-tests.factor
+++ b/basis/base64/base64-tests.factor
@@ -1,25 +1,26 @@
-USING: kernel tools.test base64 strings sequences ;
+USING: kernel tools.test base64 strings sequences
+io.encodings.string io.encodings.ascii ;
IN: base64.tests
-[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" >base64 base64> >string
+[ "abcdefghijklmnopqrstuvwxyz" ] [ "abcdefghijklmnopqrstuvwxyz" ascii encode >base64 base64> ascii decode
] unit-test
-[ "" ] [ "" >base64 base64> >string ] unit-test
-[ "a" ] [ "a" >base64 base64> >string ] unit-test
-[ "ab" ] [ "ab" >base64 base64> >string ] unit-test
-[ "abc" ] [ "abc" >base64 base64> >string ] unit-test
-[ "abcde" ] [ "abcde" >base64 3 cut "\r\n" swap 3append base64> >string ] unit-test
+[ f ] [ "" ascii encode >base64 base64> ascii decode ] unit-test
+[ "a" ] [ "a" ascii encode >base64 base64> ascii decode ] unit-test
+[ "ab" ] [ "ab" ascii encode >base64 base64> ascii decode ] unit-test
+[ "abc" ] [ "abc" ascii encode >base64 base64> ascii decode ] unit-test
+[ "abcde" ] [ "abcde" ascii encode >base64 3 cut "\r\n" swap 3append base64> ascii decode ] unit-test
! From http://en.wikipedia.org/wiki/Base64
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlzIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2YgdGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGludWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRoZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
[
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
- >base64 >string
+ ascii encode >base64 >string
] unit-test
[ "TWFuIGlzIGRpc3Rpbmd1aXNoZWQsIG5vdCBvbmx5IGJ5IGhpcyByZWFzb24sIGJ1dCBieSB0aGlz\r\nIHNpbmd1bGFyIHBhc3Npb24gZnJvbSBvdGhlciBhbmltYWxzLCB3aGljaCBpcyBhIGx1c3Qgb2Yg\r\ndGhlIG1pbmQsIHRoYXQgYnkgYSBwZXJzZXZlcmFuY2Ugb2YgZGVsaWdodCBpbiB0aGUgY29udGlu\r\ndWVkIGFuZCBpbmRlZmF0aWdhYmxlIGdlbmVyYXRpb24gb2Yga25vd2xlZGdlLCBleGNlZWRzIHRo\r\nZSBzaG9ydCB2ZWhlbWVuY2Ugb2YgYW55IGNhcm5hbCBwbGVhc3VyZS4=" ]
[
"Man is distinguished, not only by his reason, but by this singular passion from other animals, which is a lust of the mind, that by a perseverance of delight in the continued and indefatigable generation of knowledge, exceeds the short vehemence of any carnal pleasure."
- >base64-lines >string
+ ascii encode >base64-lines >string
] unit-test
\ >base64 must-infer
diff --git a/basis/base64/base64.factor b/basis/base64/base64.factor
index 7f96e19430..c51d871bb5 100644
--- a/basis/base64/base64.factor
+++ b/basis/base64/base64.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Doug Coleman, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: combinators io io.binary io.encodings.binary
-io.streams.byte-array io.streams.string kernel math namespaces
+io.streams.byte-array kernel math namespaces
sequences strings io.crlf ;
IN: base64
@@ -75,10 +75,10 @@ PRIVATE>
} case ;
: >base64 ( seq -- base64 )
- binary [ [ encode-base64 ] with-string-reader ] with-byte-writer ;
+ binary [ binary [ encode-base64 ] with-byte-reader ] with-byte-writer ;
: base64> ( base64 -- seq )
- [ binary [ decode-base64 ] with-byte-reader ] with-string-writer ;
+ binary [ binary [ decode-base64 ] with-byte-reader ] with-byte-writer ;
: >base64-lines ( seq -- base64 )
- binary [ [ encode-base64-lines ] with-string-reader ] with-byte-writer ;
+ binary [ binary [ encode-base64-lines ] with-byte-reader ] with-byte-writer ;
diff --git a/basis/bitstreams/bitstreams-tests.factor b/basis/bitstreams/bitstreams-tests.factor
index d55910b131..769efcbb04 100644
--- a/basis/bitstreams/bitstreams-tests.factor
+++ b/basis/bitstreams/bitstreams-tests.factor
@@ -6,17 +6,17 @@ io.streams.byte-array ;
IN: bitstreams.tests
[ 1 t ]
-[ B{ 254 } read-bit ] unit-test
+[ B{ 254 } binary read-bit ] unit-test
[ 254 8 t ]
-[ B{ 254 } 8 swap read-bits ] unit-test
+[ B{ 254 } binary 8 swap read-bits ] unit-test
[ 4095 12 t ]
-[ B{ 255 255 } 12 swap read-bits ] unit-test
+[ B{ 255 255 } binary 12 swap read-bits ] unit-test
[ B{ 254 } ]
[
- 254 8 rot
+ binary 254 8 rot
[ write-bits ] keep stream>> >byte-array
] unit-test
diff --git a/basis/bootstrap/ui/tools/tools.factor b/basis/bootstrap/ui/tools/tools.factor
index a3d02a0016..5cf05aef91 100644
--- a/basis/bootstrap/ui/tools/tools.factor
+++ b/basis/bootstrap/ui/tools/tools.factor
@@ -4,8 +4,8 @@ USING: kernel vocabs vocabs.loader sequences system ;
[ "bootstrap." prepend vocab ] all? [
"ui.tools" require
- "ui.cocoa" vocab [
- "ui.cocoa.tools" require
+ "ui.backend.cocoa" vocab [
+ "ui.backend.cocoa.tools" require
] when
"ui.tools.walker" require
diff --git a/basis/bootstrap/ui/ui.factor b/basis/bootstrap/ui/ui.factor
old mode 100644
new mode 100755
index 0cdf3137f6..4f7f82a067
--- a/basis/bootstrap/ui/ui.factor
+++ b/basis/bootstrap/ui/ui.factor
@@ -9,7 +9,13 @@ IN: bootstrap.ui
{ [ os windows? ] [ "windows" ] }
{ [ os unix? ] [ "x11" ] }
} cond
- ] unless* "ui." prepend require
+ ] unless* "ui.backend." prepend require
- "ui.freetype" require
+ "ui-text-backend" get [
+ {
+ { [ os macosx? ] [ "core-text" ] }
+ { [ os windows? ] [ "pango" ] }
+ { [ os unix? ] [ "pango" ] }
+ } cond
+ ] unless* "ui.text." prepend require
] when
diff --git a/basis/cache/authors.txt b/basis/cache/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/cache/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/cache/cache-tests.factor b/basis/cache/cache-tests.factor
new file mode 100644
index 0000000000..cbf4f64e22
--- /dev/null
+++ b/basis/cache/cache-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test cache ;
+IN: cache.tests
diff --git a/basis/cache/cache.factor b/basis/cache/cache.factor
new file mode 100644
index 0000000000..f16461bf45
--- /dev/null
+++ b/basis/cache/cache.factor
@@ -0,0 +1,43 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel assocs math accessors destructors fry sequences ;
+IN: cache
+
+TUPLE: cache-assoc assoc max-age disposed ;
+
+: ( -- cache )
+ H{ } clone 10 f cache-assoc boa ;
+
+ ( value -- entry ) 0 cache-entry boa ; inline
+
+M: cache-entry dispose value>> dispose ;
+
+M: cache-assoc assoc-size assoc>> assoc-size ;
+
+M: cache-assoc at* assoc>> at* [ dup [ 0 >>age value>> ] when ] dip ;
+
+M: cache-assoc set-at
+ [ check-disposed ] keep
+ [ ] 2dip
+ assoc>> set-at ;
+
+M: cache-assoc clear-assoc assoc>> clear-assoc ;
+
+M: cache-assoc >alist assoc>> [ value>> ] { } assoc-map-as ;
+
+INSTANCE: cache-assoc assoc
+
+M: cache-assoc dispose*
+ [ values dispose-each ] [ clear-assoc ] bi ;
+
+PRIVATE>
+
+: purge-cache ( cache -- )
+ dup max-age>> '[
+ [ nip [ 1+ ] change-age age>> _ >= ] assoc-partition
+ [ values dispose-each ] dip
+ ] change-assoc drop ;
\ No newline at end of file
diff --git a/basis/cache/summary.txt b/basis/cache/summary.txt
new file mode 100644
index 0000000000..2382bfd984
--- /dev/null
+++ b/basis/cache/summary.txt
@@ -0,0 +1 @@
+An associative mapping whose entries expire after a while
diff --git a/unmaintained/assocs-lib/tags.txt b/basis/cache/tags.txt
similarity index 100%
rename from unmaintained/assocs-lib/tags.txt
rename to basis/cache/tags.txt
diff --git a/basis/cairo/authors.txt b/basis/cairo/authors.txt
index 68d35d192b..4023d08987 100644
--- a/basis/cairo/authors.txt
+++ b/basis/cairo/authors.txt
@@ -1,2 +1,3 @@
Sampo Vuori
Doug Coleman
+Slava Pestov
diff --git a/basis/cairo/cairo-tests.factor b/basis/cairo/cairo-tests.factor
new file mode 100644
index 0000000000..bf7c468774
--- /dev/null
+++ b/basis/cairo/cairo-tests.factor
@@ -0,0 +1,8 @@
+IN: cairo.tests
+USING: cairo tools.test math.rectangles accessors ;
+
+[ { 10 20 } ] [
+ { 10 20 } [
+ { 0 1 } { 3 4 } fill-rect
+ ] make-bitmap-image dim>>
+] unit-test
\ No newline at end of file
diff --git a/basis/cairo/cairo.factor b/basis/cairo/cairo.factor
index da7f5a2f32..3a41f0bcf9 100755
--- a/basis/cairo/cairo.factor
+++ b/basis/cairo/cairo.factor
@@ -1,37 +1,52 @@
! Copyright (C) 2008 Doug Coleman.
+! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: cairo.ffi kernel accessors sequences
-namespaces fry continuations destructors ;
+USING: colors fonts cairo.ffi alien alien.c-types kernel accessors
+sequences namespaces fry continuations destructors math images
+images.memory math.rectangles ;
IN: cairo
-TUPLE: cairo-t alien ;
-C: cairo-t
-M: cairo-t dispose ( alien -- ) alien>> cairo_destroy ;
+ERROR: cairo-error message ;
-TUPLE: cairo-surface-t alien ;
-C: cairo-surface-t
-M: cairo-surface-t dispose ( alien -- ) alien>> cairo_surface_destroy ;
+: (check-cairo) ( cairo_status_t -- )
+ dup CAIRO_STATUS_SUCCESS =
+ [ drop ] [ cairo_status_to_string cairo-error ] if ;
-: check-cairo ( cairo_status_t -- )
- dup CAIRO_STATUS_SUCCESS = [ drop ]
- [ cairo_status_to_string "Cairo error: " prepend throw ] if ;
+: check-cairo ( cairo -- ) cairo_status (check-cairo) ;
-SYMBOL: cairo
-: cr ( -- cairo ) cairo get ; inline
+: check-surface ( surface -- ) cairo_surface_status (check-cairo) ;
-: (with-cairo) ( cairo-t quot -- )
- [ alien>> cairo ] dip
- '[ @ cr cairo_status check-cairo ]
- with-variable ; inline
-
-: with-cairo ( cairo quot -- )
- [ ] dip '[ _ (with-cairo) ] with-disposal ; inline
+: width>stride ( width -- stride ) "uint" heap-size * ; inline
-: (with-surface) ( cairo-surface-t quot -- )
- [ alien>> ] dip [ cairo_surface_status check-cairo ] bi ; inline
+: ( data dim -- surface )
+ [ CAIRO_FORMAT_ARGB32 ] dip first2 over width>stride
+ cairo_image_surface_create_for_data
+ dup check-surface ;
-: with-surface ( cairo_surface quot -- )
- [ ] dip '[ _ (with-surface) ] with-disposal ; inline
+: ( surface -- cairo ) cairo_create dup check-cairo ; inline
-: with-cairo-from-surface ( cairo_surface quot -- )
- '[ cairo_create _ with-cairo ] with-surface ; inline
+: make-bitmap-image ( dim quot -- image )
+ '[
+ &cairo_surface_destroy
+ &cairo_destroy
+ @
+ ] make-memory-bitmap
+ BGRA >>component-order ; inline
+
+: dummy-cairo ( -- cr )
+ #! Sometimes we want a dummy context; eg with Pango, we want
+ #! to measure text dimensions to create a new image context with,
+ #! but we need an existing context to measure text dimensions
+ #! with so we use the dummy.
+ \ dummy-cairo [
+ CAIRO_FORMAT_ARGB32 0 0 cairo_image_surface_create
+ cairo_create
+ ] initialize-alien ;
+
+: set-source-color ( cr color -- )
+ >rgba-components cairo_set_source_rgba ;
+
+: fill-rect ( cr rect -- )
+ [ rect-bounds [ first2 ] bi@ cairo_rectangle ]
+ [ drop cairo_fill ]
+ 2bi ;
diff --git a/basis/cairo/ffi/ffi.factor b/basis/cairo/ffi/ffi.factor
index c2daa05374..e7c0a17660 100644
--- a/basis/cairo/ffi/ffi.factor
+++ b/basis/cairo/ffi/ffi.factor
@@ -4,15 +4,15 @@
! Adapted from cairo.h, version 1.5.14
! License: http://factorcode.org/license.txt
-USING: system combinators alien alien.syntax kernel
-alien.c-types accessors sequences arrays ui.gadgets ;
+USING: system combinators alien alien.syntax alien.c-types
+alien.destructors kernel accessors sequences arrays ui.gadgets ;
IN: cairo.ffi
-<< "cairo" {
- { [ os winnt? ] [ "libcairo-2.dll" ] }
- { [ os macosx? ] [ "/opt/local/lib/libcairo.dylib" ] }
- { [ os unix? ] [ "libcairo.so.2" ] }
-} cond "cdecl" add-library >>
+<< {
+ { [ os winnt? ] [ "cairo" "libcairo-2.dll" "cdecl" add-library ] }
+ { [ os macosx? ] [ "cairo" "/opt/local/lib/libcairo.dylib" "cdecl" add-library ] }
+ { [ os unix? ] [ ] }
+} cond >>
LIBRARY: cairo
@@ -94,6 +94,8 @@ cairo_reference ( cairo_t* cr ) ;
FUNCTION: void
cairo_destroy ( cairo_t* cr ) ;
+DESTRUCTOR: cairo_destroy
+
FUNCTION: uint
cairo_get_reference_count ( cairo_t* cr ) ;
@@ -694,6 +696,8 @@ cairo_surface_finish ( cairo_surface_t* surface ) ;
FUNCTION: void
cairo_surface_destroy ( cairo_surface_t* surface ) ;
+DESTRUCTOR: cairo_surface_destroy
+
FUNCTION: uint
cairo_surface_get_reference_count ( cairo_surface_t* surface ) ;
diff --git a/basis/call/call-docs.factor b/basis/call/call-docs.factor
index 463bfdac09..5f76f53fac 100644
--- a/basis/call/call-docs.factor
+++ b/basis/call/call-docs.factor
@@ -1,19 +1,25 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: help.markup help.syntax quotations effects words ;
+USING: help.markup help.syntax quotations effects words call.private ;
IN: call
ABOUT: "call"
ARTICLE: "call" "Calling code with known stack effects"
"The " { $vocab-link "call" } " vocabulary allows for arbitrary quotations to be called from code accepted by the optimizing compiler. This is done by specifying the stack effect of the quotation literally. It is checked at runtime that the stack effect is accurate."
+$nl
+"Quotations:"
{ $subsection POSTPONE: call( }
-{ $subsection POSTPONE: execute( }
{ $subsection call-effect }
-{ $subsection execute-effect } ;
+"Words:"
+{ $subsection POSTPONE: execute( }
+{ $subsection execute-effect }
+"Unsafe calls:"
+{ $subsection POSTPONE: execute-unsafe( }
+{ $subsection execute-effect-unsafe } ;
HELP: call(
-{ $syntax "[ ] call( foo -- bar )" }
+{ $syntax "call( stack -- effect )" }
{ $description "Calls the quotation on the top of the stack, asserting that it has the given stack effect. The quotation does not need to be known at compile time." } ;
HELP: call-effect
@@ -21,12 +27,21 @@ HELP: call-effect
{ $description "Given a quotation and a stack effect, calls the quotation, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary quotation which is not required at compile time." } ;
HELP: execute(
-{ $syntax "word execute( foo -- bar )" }
-{ $description "Calls the word on the top of the stack, aserting that it has the given stack effect. The word does not need to be known at compile time." } ;
+{ $syntax "execute( stack -- effect )" }
+{ $description "Calls the word on the top of the stack, asserting that it has the given stack effect. The word does not need to be known at compile time." } ;
HELP: execute-effect
{ $values { "word" word } { "effect" effect } }
{ $description "Given a word and a stack effect, executes the word, asserting at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." } ;
-{ execute-effect call-effect } related-words
-{ POSTPONE: call( POSTPONE: execute( } related-words
+HELP: execute-unsafe(
+{ $syntax "execute-unsafe( stack -- effect )" }
+{ $description "Calls the word on the top of the stack, blindly declaring that it has the given stack effect. The word does not need to be known at compile time." }
+{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link POSTPONE: execute( } " instead." } ;
+HELP: execute-effect-unsafe
+{ $values { "word" word } { "effect" effect } }
+{ $description "Given a word and a stack effect, executes the word, blindly declaring at runtime that it has the given stack effect. This is a macro which expands given a literal effect parameter, and an arbitrary word which is not required at compile time." }
+{ $warning "If the word being executed has an incorrect stack effect, undefined behavior will result. User code should use " { $link execute-effect-unsafe } " instead." } ;
+
+{ call-effect execute-effect execute-effect-unsafe } related-words
+{ POSTPONE: call( POSTPONE: execute( POSTPONE: execute-unsafe( } related-words
\ No newline at end of file
diff --git a/basis/call/call-tests.factor b/basis/call/call-tests.factor
index a2bd11b06a..002478fb82 100644
--- a/basis/call/call-tests.factor
+++ b/basis/call/call-tests.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: math tools.test call kernel ;
+USING: math tools.test call call.private kernel accessors ;
IN: call.tests
[ 3 ] [ 1 2 [ + ] call( x y -- z ) ] unit-test
@@ -13,3 +13,13 @@ IN: call.tests
[ 1 2 \ + execute( -- z ) ] must-fail
[ 1 2 \ + execute( x y -- z a ) ] must-fail
[ \ + execute( x y -- z ) ] must-infer
+
+[ t ] [ \ + (( a b -- c )) execute-effect-unsafe? ] unit-test
+[ t ] [ \ + (( a b c -- d e )) execute-effect-unsafe? ] unit-test
+[ f ] [ \ + (( a b c -- d )) execute-effect-unsafe? ] unit-test
+[ f ] [ \ call (( x -- )) execute-effect-unsafe? ] unit-test
+
+: compile-execute(-test ( a b -- c ) \ + execute( a b -- c ) ;
+
+[ t ] [ \ compile-execute(-test optimized>> ] unit-test
+[ 4 ] [ 1 3 compile-execute(-test ] unit-test
\ No newline at end of file
diff --git a/basis/call/call.factor b/basis/call/call.factor
index 9b49acf64a..0ccc774ce0 100644
--- a/basis/call/call.factor
+++ b/basis/call/call.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel macros fry summary sequences generalizations accessors
-continuations effects.parser parser words ;
+continuations effects effects.parser parser words ;
IN: call
ERROR: wrong-values values quot length-required ;
@@ -14,17 +14,29 @@ M: wrong-values summary
: firstn-safe ( array quot n -- ... )
3dup nip swap length = [ nip firstn ] [ wrong-values ] if ; inline
+: execute-effect-unsafe ( word effect -- )
+ drop execute ;
+
+: execute-effect-unsafe? ( word effect -- ? )
+ swap dup optimized>> [ stack-effect swap effect<= ] [ 2drop f ] if ; inline
+
+: parse-call( ( accum word -- accum )
+ [ ")" parse-effect parsed ] dip parsed ;
+
+: execute-unsafe( \ execute-effect-unsafe parse-call( ; parsing
+
PRIVATE>
MACRO: call-effect ( effect -- quot )
[ in>> length ] [ out>> length ] bi
'[ [ _ narray ] dip [ with-datastack ] keep _ firstn-safe ] ;
-: call(
- ")" parse-effect parsed \ call-effect parsed ; parsing
+: call( \ call-effect parse-call( ; parsing
: execute-effect ( word effect -- )
- [ [ execute ] curry ] dip call-effect ; inline
+ 2dup execute-effect-unsafe?
+ [ execute-effect-unsafe ]
+ [ [ [ execute ] curry ] dip call-effect ]
+ if ; inline
-: execute(
- ")" parse-effect parsed \ execute-effect parsed ; parsing
+: execute( \ execute-effect parse-call( ; parsing
diff --git a/basis/cocoa/application/application-docs.factor b/basis/cocoa/application/application-docs.factor
index 60a0232a2c..a2c711c3ea 100644
--- a/basis/cocoa/application/application-docs.factor
+++ b/basis/cocoa/application/application-docs.factor
@@ -8,12 +8,6 @@ HELP:
{ CF>string } related-words
-HELP:
-{ $values { "seq" "a sequence of " { $link alien } " instances" } { "alien" alien } }
-{ $description "Allocates an autoreleased " { $snippet "CFArray" } "." } ;
-
-{ } related-words
-
HELP: with-autorelease-pool
{ $values { "quot" quotation } }
{ $description "Sets up a new " { $snippet "NSAutoreleasePool" } ", calls the quotation and frees the pool." } ;
diff --git a/basis/cocoa/application/application.factor b/basis/cocoa/application/application.factor
index 19d83b86d7..9437051dad 100644
--- a/basis/cocoa/application/application.factor
+++ b/basis/cocoa/application/application.factor
@@ -1,27 +1,17 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.syntax io kernel namespaces core-foundation
-core-foundation.arrays core-foundation.data
core-foundation.strings cocoa.messages cocoa cocoa.classes
cocoa.runtime sequences threads init summary kernel.private
assocs ;
IN: cocoa.application
: ( str -- alien ) -> autorelease ;
-: ( seq -- alien ) -> autorelease ;
-: ( number -- alien ) -> autorelease ;
-: ( byte-array -- alien ) -> autorelease ;
-: ( assoc -- alien )
- NSMutableDictionary over assoc-size -> dictionaryWithCapacity:
- [
- [
- spin -> setObject:forKey:
- ] curry assoc-each
- ] keep ;
-CONSTANT: NSApplicationDelegateReplySuccess 0
-CONSTANT: NSApplicationDelegateReplyCancel 1
-CONSTANT: NSApplicationDelegateReplyFailure 2
+C-ENUM:
+NSApplicationDelegateReplySuccess
+NSApplicationDelegateReplyCancel
+NSApplicationDelegateReplyFailure ;
: with-autorelease-pool ( quot -- )
NSAutoreleasePool -> new slip -> release ; inline
@@ -45,7 +35,8 @@ FUNCTION: void NSBeep ( ) ;
[ NSNotificationCenter -> defaultCenter ] dip
-> removeObserver: ;
-: cocoa-app ( quot -- ) [ call NSApp -> run ] with-cocoa ; inline
+: cocoa-app ( quot -- )
+ [ call NSApp -> run ] with-cocoa ; inline
: install-delegate ( receiver delegate -- )
-> alloc -> init -> setDelegate: ;
diff --git a/basis/cocoa/cocoa-docs.factor b/basis/cocoa/cocoa-docs.factor
index dd8d331b35..17621dc634 100644
--- a/basis/cocoa/cocoa-docs.factor
+++ b/basis/cocoa/cocoa-docs.factor
@@ -44,7 +44,6 @@ $nl
{ $subsection "objc-calling" }
{ $subsection "objc-subclassing" }
"A utility library is built to faciliate the development of Cocoa applications in Factor:"
-{ $subsection "cocoa-types" }
{ $subsection "cocoa-application-utils" }
{ $subsection "cocoa-dialogs" }
{ $subsection "cocoa-pasteboard-utils" }
diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor
index 59ea91c3cf..d77435a8ad 100644
--- a/basis/cocoa/cocoa-tests.factor
+++ b/basis/cocoa/cocoa-tests.factor
@@ -1,7 +1,7 @@
IN: cocoa.tests
USING: cocoa cocoa.messages cocoa.subclassing cocoa.types
compiler kernel namespaces cocoa.classes tools.test memory
-compiler.units math ;
+compiler.units math core-graphics.types ;
CLASS: {
{ +superclass+ "NSObject" }
@@ -15,15 +15,15 @@ CLASS: {
: test-foo
Foo -> alloc -> init
- dup 1.0 2.0 101.0 102.0 -> foo:
+ dup 1.0 2.0 101.0 102.0 -> foo:
-> release ;
test-foo
-[ 1.0 ] [ "x" get NSRect-x ] unit-test
-[ 2.0 ] [ "x" get NSRect-y ] unit-test
-[ 101.0 ] [ "x" get NSRect-w ] unit-test
-[ 102.0 ] [ "x" get NSRect-h ] unit-test
+[ 1.0 ] [ "x" get CGRect-x ] unit-test
+[ 2.0 ] [ "x" get CGRect-y ] unit-test
+[ 101.0 ] [ "x" get CGRect-w ] unit-test
+[ 102.0 ] [ "x" get CGRect-h ] unit-test
CLASS: {
{ +superclass+ "NSObject" }
@@ -41,10 +41,10 @@ Bar [
-> release
] compile-call
-[ 1.0 ] [ "x" get NSRect-x ] unit-test
-[ 2.0 ] [ "x" get NSRect-y ] unit-test
-[ 101.0 ] [ "x" get NSRect-w ] unit-test
-[ 102.0 ] [ "x" get NSRect-h ] unit-test
+[ 1.0 ] [ "x" get CGRect-x ] unit-test
+[ 2.0 ] [ "x" get CGRect-y ] unit-test
+[ 101.0 ] [ "x" get CGRect-w ] unit-test
+[ 102.0 ] [ "x" get CGRect-h ] unit-test
! Make sure that we can add methods
CLASS: {
diff --git a/basis/cocoa/enumeration/enumeration.factor b/basis/cocoa/enumeration/enumeration.factor
index 919e8f86c5..1f9430e443 100644
--- a/basis/cocoa/enumeration/enumeration.factor
+++ b/basis/cocoa/enumeration/enumeration.factor
@@ -8,12 +8,11 @@ IN: cocoa.enumeration
CONSTANT: NS-EACH-BUFFER-SIZE 16
: with-enumeration-buffers ( quot -- )
- [
- [
- "NSFastEnumerationState" malloc-object &free
- NS-EACH-BUFFER-SIZE "id" heap-size * malloc-object &free
- NS-EACH-BUFFER-SIZE
- ] dip call
+ '[
+ "NSFastEnumerationState" malloc-object &free
+ NS-EACH-BUFFER-SIZE "id" malloc-array &free
+ NS-EACH-BUFFER-SIZE
+ @
] with-destructors ; inline
:: (NSFastEnumeration-each) ( object quot: ( elt -- ) state stackbuf count -- )
diff --git a/basis/cocoa/messages/messages.factor b/basis/cocoa/messages/messages.factor
index 9a1bebd38f..8818c9a217 100644
--- a/basis/cocoa/messages/messages.factor
+++ b/basis/cocoa/messages/messages.factor
@@ -167,13 +167,19 @@ assoc-union alien>objc-types set-global
drop "void*"
] unless ;
+ERROR: no-objc-type name ;
+
+: decode-type ( ch -- ctype )
+ 1string dup objc>alien-types get at
+ [ ] [ no-objc-type ] ?if ;
+
: (parse-objc-type) ( i string -- ctype )
[ [ 1+ ] dip ] [ nth ] 2bi {
{ [ dup "rnNoORV" member? ] [ drop (parse-objc-type) ] }
{ [ dup CHAR: ^ = ] [ 3drop "void*" ] }
{ [ dup CHAR: { = ] [ drop objc-struct-type ] }
{ [ dup CHAR: [ = ] [ 3drop "void*" ] }
- [ 2nip 1string objc>alien-types get at ]
+ [ 2nip decode-type ]
} cond ;
: parse-objc-type ( string -- ctype ) 0 swap (parse-objc-type) ;
diff --git a/basis/cocoa/pasteboard/pasteboard.factor b/basis/cocoa/pasteboard/pasteboard.factor
index 1a21b338be..ef1c86836b 100644
--- a/basis/cocoa/pasteboard/pasteboard.factor
+++ b/basis/cocoa/pasteboard/pasteboard.factor
@@ -1,4 +1,4 @@
-! Copyright (C) 2006, 2008 Slava Pestov.
+! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.accessors arrays kernel cocoa.messages
cocoa.classes cocoa.application sequences cocoa core-foundation
@@ -15,7 +15,7 @@ CONSTANT: NSStringPboardType "NSStringPboardType"
dup [ CF>string ] when ;
: set-pasteboard-types ( seq pasteboard -- )
- swap f -> declareTypes:owner: drop ;
+ swap -> autorelease f -> declareTypes:owner: drop ;
: set-pasteboard-string ( str pasteboard -- )
NSStringPboardType
diff --git a/basis/cocoa/plists/plists-tests.factor b/basis/cocoa/plists/plists-tests.factor
new file mode 100644
index 0000000000..4f74cd850a
--- /dev/null
+++ b/basis/cocoa/plists/plists-tests.factor
@@ -0,0 +1,40 @@
+IN: cocoa.plists.tests
+USING: tools.test cocoa.plists colors kernel hashtables
+core-foundation.utilities core-foundation destructors
+assocs cocoa.enumeration ;
+
+[
+ [ V{ } ] [ H{ } >cf &CFRelease [ ] NSFastEnumeration-map ] unit-test
+ [ V{ "A" } ] [ { "A" } >cf &CFRelease plist> ] unit-test
+ [ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
+ [ H{ { "A" "B" } } ] [ "B" "A" associate >cf &CFRelease plist> ] unit-test
+
+ [ t ] [
+ {
+ H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 4 } }
+ H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 5 } }
+ H{ { "DeviceUsagePage" 1 } { "DeviceUsage" 6 } }
+ } [ >cf &CFRelease ] [ >cf &CFRelease ] bi
+ [ plist> ] bi@ =
+ ] unit-test
+
+ [ t ] [
+ { "DeviceUsagePage" 1 }
+ [ >cf &CFRelease ] [ >cf &CFRelease ] bi
+ [ plist> ] bi@ =
+ ] unit-test
+
+ [ V{ "DeviceUsagePage" "Yes" } ] [
+ { "DeviceUsagePage" "Yes" }
+ >cf &CFRelease plist>
+ ] unit-test
+
+ [ V{ 2.0 1.0 } ] [
+ { 2.0 1.0 }
+ >cf &CFRelease plist>
+ ] unit-test
+
+ [ 3.5 ] [
+ 3.5 >cf &CFRelease plist>
+ ] unit-test
+] with-destructors
\ No newline at end of file
diff --git a/basis/cocoa/plists/plists.factor b/basis/cocoa/plists/plists.factor
index cf68f9864a..31b59a6eac 100644
--- a/basis/cocoa/plists/plists.factor
+++ b/basis/cocoa/plists/plists.factor
@@ -1,68 +1,60 @@
-! Copyright (C) 2007, 2008 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov.
+! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: strings arrays hashtables assocs sequences
+USING: strings arrays hashtables assocs sequences fry macros
cocoa.messages cocoa.classes cocoa.application cocoa kernel
namespaces io.backend math cocoa.enumeration byte-arrays
-combinators alien.c-types core-foundation core-foundation.data ;
+combinators alien.c-types words core-foundation
+core-foundation.data core-foundation.utilities ;
IN: cocoa.plists
-GENERIC: >plist ( value -- plist )
-
-M: number >plist
- ;
-M: t >plist
- ;
-M: f >plist
- ;
-M: string >plist
- ;
-M: byte-array >plist
- ;
-M: hashtable >plist
- [ [ >plist ] bi@ ] assoc-map ;
-M: sequence >plist
- [ >plist ] map ;
+: >plist ( value -- plist ) >cf -> autorelease ;
: write-plist ( assoc path -- )
- [ >plist ] [ normalize-path ] bi* 0
- -> writeToFile:atomically:
+ [ >plist ] [ normalize-path ] bi* 0 -> writeToFile:atomically:
[ "write-plist failed" throw ] unless ;
DEFER: plist>
+) ( NSString -- string )
-> UTF8String ;
: (plist-NSNumber>) ( NSNumber -- number )
dup -> doubleValue dup >integer =
- [ -> longLongValue ]
- [ -> doubleValue ] if ;
+ [ -> longLongValue ] [ -> doubleValue ] if ;
: (plist-NSData>) ( NSData -- byte-array )
dup -> length [ -> getBytes: ] keep ;
: (plist-NSArray>) ( NSArray -- vector )
- [ plist> ] NSFastEnumeration-map ;
+ [ plist> ] NSFastEnumeration-map ;
: (plist-NSDictionary>) ( NSDictionary -- hashtable )
- dup [ [ -> valueForKey: ] keep swap [ plist> ] bi@ 2array ] with
+ dup [ [ nip ] [ -> valueForKey: ] 2bi [ plist> ] bi@ 2array ] with
NSFastEnumeration-map >hashtable ;
-: plist> ( plist -- value )
- {
- { [ dup NSString -> isKindOfClass: c-bool> ] [ (plist-NSString>) ] }
- { [ dup NSNumber -> isKindOfClass: c-bool> ] [ (plist-NSNumber>) ] }
- { [ dup NSData -> isKindOfClass: c-bool> ] [ (plist-NSData>) ] }
- { [ dup NSArray -> isKindOfClass: c-bool> ] [ (plist-NSArray>) ] }
- { [ dup NSDictionary -> isKindOfClass: c-bool> ] [ (plist-NSDictionary>) ] }
- [ ]
- } cond ;
-
: (read-plist) ( NSData -- id )
NSPropertyListSerialization swap kCFPropertyListImmutable f f
[ -> propertyListFromData:mutabilityOption:format:errorDescription: ] keep
*void* [ -> release "read-plist failed" throw ] when* ;
+MACRO: objc-class-case ( alist -- quot )
+ [ [ '[ dup _ execute -> isKindOfClass: c-bool> ] ] dip ] assoc-map '[ _ cond ] ;
+
+PRIVATE>
+
+: plist> ( plist -- value )
+ {
+ { NSString [ (plist-NSString>) ] }
+ { NSNumber [ (plist-NSNumber>) ] }
+ { NSData [ (plist-NSData>) ] }
+ { NSArray [ (plist-NSArray>) ] }
+ { NSDictionary [ (plist-NSDictionary>) ] }
+ { NSObject [ ] }
+ } objc-class-case ;
+
: read-plist ( path -- assoc )
normalize-path
NSData swap -> dataWithContentsOfFile:
diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor
index 0896312670..394f45bef3 100644
--- a/basis/cocoa/subclassing/subclassing.factor
+++ b/basis/cocoa/subclassing/subclassing.factor
@@ -32,10 +32,11 @@ IN: cocoa.subclassing
[ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
tri ;
+: encode-type ( type -- encoded )
+ dup alien>objc-types get at [ ] [ no-objc-type ] ?if ;
+
: encode-types ( return types -- encoding )
- swap prefix [
- alien>objc-types get at "0" append
- ] map concat ;
+ swap prefix [ encode-type "0" append ] map concat ;
: prepare-method ( ret types quot -- type imp )
[ [ encode-types ] 2keep ] dip
diff --git a/basis/cocoa/types/types-docs.factor b/basis/cocoa/types/types-docs.factor
deleted file mode 100644
index 0c4b01a476..0000000000
--- a/basis/cocoa/types/types-docs.factor
+++ /dev/null
@@ -1,29 +0,0 @@
-USING: math help.markup help.syntax ;
-IN: cocoa.types
-
-HELP:
-{ $values { "x" real } { "y" real } { "w" real } { "h" real } { "rect" "an " { $snippet "NSRect" } } }
-{ $description "Allocates a new " { $snippet "NSRect" } " in the Factor heap." } ;
-
-HELP:
-{ $values { "x" real } { "y" real } { "point" "an " { $snippet "NSPoint" } } }
-{ $description "Allocates a new " { $snippet "NSPoint" } " in the Factor heap." } ;
-
-HELP:
-{ $values { "w" real } { "h" real } { "size" "an " { $snippet "NSSize" } } }
-{ $description "Allocates a new " { $snippet "NSSize" } " in the Factor heap." } ;
-
-ARTICLE: "cocoa-types" "Cocoa types"
-"The Cocoa binding defines some common C structs:"
-{ $code
- "NSRect"
- "NSPoint"
- "NSSize"
-}
-"Some words for working with the above:"
-{ $subsection }
-{ $subsection }
-{ $subsection } ;
-
-IN: cocoa.types
-ABOUT: "cocoa-types"
diff --git a/basis/cocoa/types/types.factor b/basis/cocoa/types/types.factor
index a76e74d9aa..6e03a21bbc 100644
--- a/basis/cocoa/types/types.factor
+++ b/basis/cocoa/types/types.factor
@@ -1,73 +1,20 @@
-! Copyright (C) 2006, 2007 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.c-types alien.syntax combinators kernel ;
+USING: alien.c-types alien.syntax combinators kernel layouts
+core-graphics.types ;
IN: cocoa.types
TYPEDEF: long NSInteger
TYPEDEF: ulong NSUInteger
-<< "ptrdiff_t" heap-size {
- { 4 [ "float" ] }
- { 8 [ "double" ] }
-} case "CGFloat" typedef >>
-
-C-STRUCT: NSPoint
- { "CGFloat" "x" }
- { "CGFloat" "y" } ;
+TYPEDEF: CGPoint NSPoint
TYPEDEF: NSPoint _NSPoint
-TYPEDEF: NSPoint CGPoint
-
-: ( x y -- point )
- "NSPoint"
- [ set-NSPoint-y ] keep
- [ set-NSPoint-x ] keep ;
-
-C-STRUCT: NSSize
- { "CGFloat" "w" }
- { "CGFloat" "h" } ;
+TYPEDEF: CGSize NSSize
TYPEDEF: NSSize _NSSize
-TYPEDEF: NSSize CGSize
-
-: ( w h -- size )
- "NSSize"
- [ set-NSSize-h ] keep
- [ set-NSSize-w ] keep ;
-
-C-STRUCT: NSRect
- { "NSPoint" "origin" }
- { "NSSize" "size" } ;
+TYPEDEF: CGRect NSRect
TYPEDEF: NSRect _NSRect
-TYPEDEF: NSRect CGRect
-
-: NSRect-x ( NSRect -- x )
- NSRect-origin NSPoint-x ; inline
-: NSRect-y ( NSRect -- y )
- NSRect-origin NSPoint-y ; inline
-: NSRect-w ( NSRect -- w )
- NSRect-size NSSize-w ; inline
-: NSRect-h ( NSRect -- h )
- NSRect-size NSSize-h ; inline
-
-: set-NSRect-x ( x NSRect -- )
- NSRect-origin set-NSPoint-x ; inline
-: set-NSRect-y ( y NSRect -- )
- NSRect-origin set-NSPoint-y ; inline
-: set-NSRect-w ( w NSRect -- )
- NSRect-size set-NSSize-w ; inline
-: set-NSRect-h ( h NSRect -- )
- NSRect-size set-NSSize-h ; inline
-
-: ( x y w h -- rect )
- "NSRect"
- [ set-NSRect-h ] keep
- [ set-NSRect-w ] keep
- [ set-NSRect-y ] keep
- [ set-NSRect-x ] keep ;
-
-: NSRect-x-y ( alien -- origin-x origin-y )
- [ NSRect-x ] keep NSRect-y ;
C-STRUCT: NSRange
{ "NSUInteger" "location" }
@@ -85,14 +32,6 @@ TYPEDEF: void* unknown_type
[ set-NSRange-length ] keep
[ set-NSRange-location ] keep ;
-C-STRUCT: CGAffineTransform
- { "CGFloat" "a" }
- { "CGFloat" "b" }
- { "CGFloat" "c" }
- { "CGFloat" "d" }
- { "CGFloat" "tx" }
- { "CGFloat" "ty" } ;
-
C-STRUCT: NSFastEnumerationState
{ "ulong" "state" }
{ "id*" "itemsPtr" }
diff --git a/basis/cocoa/views/views.factor b/basis/cocoa/views/views.factor
index 4bb6468fa6..0b8346db4b 100644
--- a/basis/cocoa/views/views.factor
+++ b/basis/cocoa/views/views.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: specialized-arrays.int arrays kernel math namespaces make
-cocoa cocoa.messages cocoa.classes cocoa.types sequences
-continuations accessors ;
+cocoa cocoa.messages cocoa.classes core-graphics
+core-graphics.types sequences continuations accessors ;
IN: cocoa.views
CONSTANT: NSOpenGLPFAAllRenderers 1
@@ -40,29 +40,29 @@ CONSTANT: NSOpenGLPFAScreenMask 84
CONSTANT: NSOpenGLPFAPixelBuffer 90
CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
-
-CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
+CONSTANT: NSOpenGLCPSwapInterval 222
: with-software-renderer ( quot -- )
- t +software-renderer+ pick with-variable ; inline
+ [ t software-renderer? ] dip with-variable ; inline
+
: with-multisample ( quot -- )
- t +multisample+ pick with-variable ; inline
+ [ t multisample? ] dip with-variable ; inline
: ( attributes -- pixelfmt )
NSOpenGLPixelFormat -> alloc swap [
%
NSOpenGLPFADepthSize , 16 ,
- +software-renderer+ get [
+ software-renderer? get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
] when
- +multisample+ get [
+ multisample? get [
NSOpenGLPFASupersample ,
NSOpenGLPFASampleBuffers , 1 ,
NSOpenGLPFASamples , 8 ,
@@ -73,7 +73,7 @@ PRIVATE>
-> autorelease ;
: ( class dim -- view )
- [ -> alloc 0 0 ] dip first2
+ [ -> alloc 0 0 ] dip first2
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
@@ -81,26 +81,12 @@ PRIVATE>
: view-dim ( view -- dim )
-> bounds
- dup NSRect-w >fixnum
- swap NSRect-h >fixnum 2array ;
+ [ CGRect-w >fixnum ] [ CGRect-h >fixnum ] bi
+ 2array ;
: mouse-location ( view event -- loc )
[
-> locationInWindow f -> convertPoint:fromView:
- [ NSPoint-x ] [ NSPoint-y ] bi
- ] [ drop -> frame NSRect-h ] 2bi
+ [ CGPoint-x ] [ CGPoint-y ] bi
+ ] [ drop -> frame CGRect-h ] 2bi
swap - 2array ;
-
-USE: opengl.gl
-USE: alien.syntax
-
-CONSTANT: NSOpenGLCPSwapInterval 222
-
-LIBRARY: OpenGL
-
-TYPEDEF: int CGLError
-TYPEDEF: void* CGLContextObj
-TYPEDEF: int CGLContextParameter
-
-FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
-
diff --git a/basis/colors/colors-docs.factor b/basis/colors/colors-docs.factor
new file mode 100644
index 0000000000..8881d89711
--- /dev/null
+++ b/basis/colors/colors-docs.factor
@@ -0,0 +1,39 @@
+IN: colors
+USING: accessors help.markup help.syntax ;
+
+HELP: color
+{ $class-description "The class of colors. Implementations include " { $link rgba } ", " { $vocab-link "colors.gray" } " and " { $vocab-link "colors.hsv" } "." } ;
+
+HELP: rgba
+{ $class-description "The class of colors with red, green, blue and alpha channel components. The slots store color components, which are real numbers in the range 0 to 1, inclusive." } ;
+
+HELP: >rgba
+{ $values { "color" color } { "rgba" rgba } }
+{ $contract "Converts a color to an RGBA color." } ;
+
+ARTICLE: "colors.protocol" "Color protocol"
+"Abstract superclass for colors:"
+{ $subsection color }
+"All color objects must are required to implement a method on the " { $link >rgba } " generic word."
+$nl
+"Optionally, they can provide methods on the accessors " { $link red>> } ", " { $link green>> } ", " { $link blue>> } " and " { $link alpha>> } ", either by defining slots with the appropriate names, or with methods which calculate the color component values. The accessors should return color components which are real numbers in the range between 0 and 1."
+$nl
+"Overriding the accessors is purely an optimization, since the default implementations call " { $link >rgba } " and then extract the appropriate component of the result." ;
+
+ARTICLE: "colors" "Colors"
+"The " { $vocab-link "colors" } " vocabulary defines a protocol for colors, with a concrete implementation for RGBA colors. This vocabulary is used by " { $vocab-link "io.styles" } ", " { $vocab-link "ui" } " and other vocabularies, but it is independent of them."
+$nl
+"RGBA colors:"
+{ $subsection rgba }
+{ $subsection }
+"Converting a color to RGBA:"
+{ $subsection >rgba }
+"Extracting RGBA components of colors:"
+{ $subsection >rgba-components }
+"Further topics:"
+{ $subsection "colors.protocol" }
+{ $subsection "colors.constants" }
+{ $vocab-subsection "Grayscale colors" "colors.gray" }
+{ $vocab-subsection "HSV colors" "colors.hsv" } ;
+
+ABOUT: "colors"
\ No newline at end of file
diff --git a/basis/colors/colors.factor b/basis/colors/colors.factor
index 9c55b1f29a..0cd743fa5f 100644
--- a/basis/colors/colors.factor
+++ b/basis/colors/colors.factor
@@ -1,33 +1,30 @@
-! Copyright (C) 2003, 2008 Slava Pestov.
+! Copyright (C) 2003, 2009 Slava Pestov.
! Copyright (C) 2008 Eduardo Cavazos.
! See http://factorcode.org/license.txt for BSD license.
-USING: kernel accessors ;
+USING: kernel accessors combinators math ;
IN: colors
TUPLE: color ;
-TUPLE: rgba < color red green blue alpha ;
+TUPLE: rgba < color
+{ red read-only }
+{ green read-only }
+{ blue read-only }
+{ alpha read-only } ;
C: rgba
-GENERIC: >rgba ( object -- rgba )
+GENERIC: >rgba ( color -- rgba )
M: rgba >rgba ( rgba -- rgba ) ;
-M: color red>> ( color -- red ) >rgba red>> ;
+M: color red>> ( color -- red ) >rgba red>> ;
M: color green>> ( color -- green ) >rgba green>> ;
-M: color blue>> ( color -- blue ) >rgba blue>> ;
+M: color blue>> ( color -- blue ) >rgba blue>> ;
-CONSTANT: black T{ rgba f 0.0 0.0 0.0 1.0 }
-CONSTANT: blue T{ rgba f 0.0 0.0 1.0 1.0 }
-CONSTANT: cyan T{ rgba f 0 0.941 0.941 1 }
-CONSTANT: gray T{ rgba f 0.6 0.6 0.6 1.0 }
-CONSTANT: green T{ rgba f 0.0 1.0 0.0 1.0 }
-CONSTANT: light-gray T{ rgba f 0.95 0.95 0.95 0.95 }
-CONSTANT: light-purple T{ rgba f 0.8 0.8 1.0 1.0 }
-CONSTANT: magenta T{ rgba f 0.941 0 0.941 1 }
-CONSTANT: orange T{ rgba f 0.941 0.627 0 1 }
-CONSTANT: purple T{ rgba f 0.627 0 0.941 1 }
-CONSTANT: red T{ rgba f 1.0 0.0 0.0 1.0 }
-CONSTANT: white T{ rgba f 1.0 1.0 1.0 1.0 }
-CONSTANT: yellow T{ rgba f 1.0 1.0 0.0 1.0 }
+: >rgba-components ( object -- r g b a )
+ >rgba { [ red>> ] [ green>> ] [ blue>> ] [ alpha>> ] } cleave ; inline
+
+: opaque? ( color -- ? ) alpha>> 1 number= ;
+
+CONSTANT: transparent T{ rgba f 0.0 0.0 0.0 0.0 }
\ No newline at end of file
diff --git a/basis/colors/constants/constants-docs.factor b/basis/colors/constants/constants-docs.factor
new file mode 100644
index 0000000000..49d6fce3a1
--- /dev/null
+++ b/basis/colors/constants/constants-docs.factor
@@ -0,0 +1,31 @@
+IN: colors.constants
+USING: help.markup help.syntax strings colors ;
+
+HELP: named-color
+{ $values { "name" string } { "color" color } }
+{ $description "Outputs a named color from the " { $snippet "rgb.txt" } " database." }
+{ $notes "In most cases, " { $link POSTPONE: COLOR: } " should be used instead." }
+{ $errors "Throws an error if the color is not listed in " { $snippet "rgb.txt" } "." } ;
+
+HELP: named-colors
+{ $values { "keys" "a sequence of strings" } }
+{ $description "Outputs a sequence of all colors in the " { $snippet "rgb.txt" } " database." } ;
+
+HELP: COLOR:
+{ $syntax "COLOR: name" }
+{ $description "Parses as a " { $link color } " object with the given name." }
+{ $errors "Throws an error if the color is not listed in " { $snippet "rgb.txt" } "." }
+{ $examples
+ { $code
+ "USING: colors.constants io.styles ;"
+ "\"Hello!\" { { foreground COLOR: cyan } } format nl"
+ }
+} ;
+
+ARTICLE: "colors.constants" "Standard color database"
+"The " { $vocab-link "colors.constants" } " vocabulary bundles the X11 " { $snippet "rgb.txt" } " database and provides words for looking up color values."
+{ $subsection named-color }
+{ $subsection named-colors }
+{ $subsection POSTPONE: COLOR: } ;
+
+ABOUT: "colors.constants"
\ No newline at end of file
diff --git a/basis/colors/constants/constants.factor b/basis/colors/constants/constants.factor
index e298b3b61e..91621c110b 100644
--- a/basis/colors/constants/constants.factor
+++ b/basis/colors/constants/constants.factor
@@ -23,9 +23,11 @@ MEMO: rgb.txt ( -- assoc )
PRIVATE>
+: named-colors ( -- keys ) rgb.txt keys ;
+
ERROR: no-such-color name ;
-: named-color ( name -- rgb )
+: named-color ( name -- color )
dup rgb.txt at [ ] [ no-such-color ] ?if ;
: COLOR: scan named-color parsed ; parsing
\ No newline at end of file
diff --git a/basis/colors/gray/gray-docs.factor b/basis/colors/gray/gray-docs.factor
new file mode 100644
index 0000000000..ac0f45e698
--- /dev/null
+++ b/basis/colors/gray/gray-docs.factor
@@ -0,0 +1,9 @@
+USING: help.markup help.syntax accessors ;
+IN: colors.gray
+
+ARTICLE: "colors.gray" "Grayscale colors"
+"The " { $vocab-link "colors.gray" } " vocabulary implements grayscale colors. These colors hold a single value, and respond to " { $link red>> } ", " { $link green>> } ", " { $link blue>> } " with that value. They also have an independent alpha channel, " { $link alpha>> } "."
+{ $subsection gray }
+{ $subsection } ;
+
+ABOUT: "colors.gray"
\ No newline at end of file
diff --git a/basis/colors/gray/gray.factor b/basis/colors/gray/gray.factor
index 26ec1177b6..5d628dc409 100644
--- a/basis/colors/gray/gray.factor
+++ b/basis/colors/gray/gray.factor
@@ -3,9 +3,15 @@
USING: colors kernel accessors ;
IN: colors.gray
-TUPLE: gray < color gray alpha ;
+TUPLE: gray < color { gray read-only } { alpha read-only } ;
C: gray
M: gray >rgba ( gray -- rgba )
[ gray>> dup dup ] [ alpha>> ] bi ;
+
+M: gray red>> gray>> ;
+
+M: gray green>> gray>> ;
+
+M: gray blue>> gray>> ;
\ No newline at end of file
diff --git a/basis/colors/hsv/hsv-docs.factor b/basis/colors/hsv/hsv-docs.factor
new file mode 100644
index 0000000000..4a9d8a9b9b
--- /dev/null
+++ b/basis/colors/hsv/hsv-docs.factor
@@ -0,0 +1,13 @@
+IN: colors.hsv
+USING: help.markup help.syntax ;
+
+HELP: hsva
+{ $class-description "The class of HSV (Hue, Saturation, Value) colors with an alpha channel. The " { $slot "hue" } " slot stores a value in the interval " { $snippet "[0,360]" } " and the remaining slots store values in the interval " { $snippet "[0,1]" } "." } ;
+
+ARTICLE: "colors.hsv" "HSV colors"
+"The " { $vocab-link "colors.hsv" } " vocabulary implements colors specified by their hue, saturation, and value, together with an alpha channel."
+{ $subsection hsva }
+{ $subsection }
+{ $see-also "colors" } ;
+
+ABOUT: "colors.hsv"
\ No newline at end of file
diff --git a/basis/colors/hsv/hsv-tests.factor b/basis/colors/hsv/hsv-tests.factor
index 8a736553bb..a825cacda8 100644
--- a/basis/colors/hsv/hsv-tests.factor
+++ b/basis/colors/hsv/hsv-tests.factor
@@ -24,3 +24,5 @@ USING: accessors kernel colors colors.hsv tools.test math ;
[ 5/6 5/36 5/6 ] [ 5/6 5/6 5/6 hsv>rgb ] unit-test
[ 1/6 0 1/6 ] [ 5/6 1 1/6 hsv>rgb ] unit-test
+
+[ 0.5 ] [ 180 0.1 0.2 0.5 alpha>> ] unit-test
\ No newline at end of file
diff --git a/basis/colors/hsv/hsv.factor b/basis/colors/hsv/hsv.factor
index 6f658818a1..e4451fcb1c 100644
--- a/basis/colors/hsv/hsv.factor
+++ b/basis/colors/hsv/hsv.factor
@@ -6,7 +6,7 @@ IN: colors.hsv
! h [0,360)
! s [0,1]
! v [0,1]
-TUPLE: hsva < color hue saturation value alpha ;
+TUPLE: hsva < color { hue read-only } { saturation read-only } { value read-only } { alpha read-only } ;
C: hsva
diff --git a/basis/compiler/cfg/instructions/syntax/syntax.factor b/basis/compiler/cfg/instructions/syntax/syntax.factor
index 30d062d4cc..0389841e8f 100644
--- a/basis/compiler/cfg/instructions/syntax/syntax.factor
+++ b/basis/compiler/cfg/instructions/syntax/syntax.factor
@@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: classes.tuple classes.tuple.parser kernel words
-make fry sequences parser accessors ;
+make fry sequences parser accessors effects ;
IN: compiler.cfg.instructions.syntax
: insn-word ( -- word )
@@ -11,7 +11,7 @@ IN: compiler.cfg.instructions.syntax
"insn" "compiler.cfg.instructions" lookup ;
: insn-effect ( word -- effect )
- boa-effect [ but-last ] change-in { } >>out ;
+ boa-effect in>> but-last f ;
: INSN:
parse-tuple-definition "regs" suffix
diff --git a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
index 3ad716d847..cb5f2e926d 100644
--- a/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
+++ b/basis/compiler/cfg/intrinsics/fixnum/fixnum.factor
@@ -70,7 +70,7 @@ IN: compiler.cfg.intrinsics.fixnum
ds-push ;
: emit-fixnum-comparison ( node cc -- )
- [ '[ _ ^^compare ] ] [ '[ _ ^^compare-imm ] ] bi
+ [ ^^compare ] [ ^^compare-imm ] bi-curry
emit-fixnum-op ;
: emit-bignum>fixnum ( -- )
diff --git a/basis/compiler/cfg/intrinsics/slots/slots.factor b/basis/compiler/cfg/intrinsics/slots/slots.factor
index bc46e6149c..0cc6e6f5d0 100644
--- a/basis/compiler/cfg/intrinsics/slots/slots.factor
+++ b/basis/compiler/cfg/intrinsics/slots/slots.factor
@@ -28,15 +28,14 @@ IN: compiler.cfg.intrinsics.slots
] [ drop emit-primitive ] if ;
: (emit-set-slot) ( infos -- obj-reg )
- [ 3inputs [ tuck ] dip ^^offset>slot ]
- [ second value-tag ]
- bi* ^^set-slot ;
+ [ 3inputs ^^offset>slot ] [ second value-tag ] bi*
+ pick [ ^^set-slot ] dip ;
: (emit-set-slot-imm) ( infos -- obj-reg )
ds-drop
- [ 2inputs tuck ]
+ [ 2inputs ]
[ [ third literal>> ] [ second value-tag ] bi ] bi*
- ##set-slot-imm ;
+ pick [ ##set-slot-imm ] dip ;
: emit-set-slot ( node -- )
dup node-input-infos
diff --git a/basis/compiler/cfg/linear-scan/allocation/allocation.factor b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
index d75d5649cb..8d00a14ea2 100644
--- a/basis/compiler/cfg/linear-scan/allocation/allocation.factor
+++ b/basis/compiler/cfg/linear-scan/allocation/allocation.factor
@@ -105,7 +105,7 @@ SYMBOL: spill-counts
#! If it has been spilled already, reuse spill location.
over reload-from>>
[ over vreg>> reg-class>> next-spill-location ] unless*
- tuck [ >>spill-to ] [ >>reload-from ] 2bi* ;
+ [ >>spill-to ] [ >>reload-from ] bi-curry bi* ;
: split-and-spill ( new existing -- before after )
dup rot start>> split-interval
diff --git a/basis/compiler/tests/redefine1.factor b/basis/compiler/tests/redefine1.factor
index b5835de5fd..0875967bd2 100644
--- a/basis/compiler/tests/redefine1.factor
+++ b/basis/compiler/tests/redefine1.factor
@@ -1,24 +1,42 @@
USING: accessors compiler compiler.units tools.test math parser
kernel sequences sequences.private classes.mixin generic
-definitions arrays words assocs eval ;
+definitions arrays words assocs eval strings ;
IN: compiler.tests
-GENERIC: method-redefine-test ( a -- b )
+GENERIC: method-redefine-generic-1 ( a -- b )
-M: integer method-redefine-test 3 + ;
+M: integer method-redefine-generic-1 3 + ;
-: method-redefine-test-1 ( -- b ) 3 method-redefine-test ;
+: method-redefine-test-1 ( -- b ) 3 method-redefine-generic-1 ;
[ 6 ] [ method-redefine-test-1 ] unit-test
-[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-test 4 + ;" eval ] unit-test
+[ ] [ "IN: compiler.tests USE: math M: fixnum method-redefine-generic-1 4 + ;" eval ] unit-test
[ 7 ] [ method-redefine-test-1 ] unit-test
-[ ] [ [ fixnum \ method-redefine-test method forget ] with-compilation-unit ] unit-test
+[ ] [ [ fixnum \ method-redefine-generic-1 method forget ] with-compilation-unit ] unit-test
[ 6 ] [ method-redefine-test-1 ] unit-test
+GENERIC: method-redefine-generic-2 ( a -- b )
+
+M: integer method-redefine-generic-2 3 + ;
+
+: method-redefine-test-2 ( -- b ) 3 method-redefine-generic-2 ;
+
+[ 6 ] [ method-redefine-test-2 ] unit-test
+
+[ ] [ "IN: compiler.tests USE: kernel USE: math M: fixnum method-redefine-generic-2 4 + ; USE: strings M: string method-redefine-generic-2 drop f ;" eval ] unit-test
+
+[ 7 ] [ method-redefine-test-2 ] unit-test
+
+[ ] [
+ [
+ fixnum string [ \ method-redefine-generic-2 method forget ] bi@
+ ] with-compilation-unit
+] unit-test
+
! Test ripple-up behavior
: hey ( -- ) ;
: there ( -- ) hey ;
diff --git a/basis/compiler/tree/dead-code/simple/simple.factor b/basis/compiler/tree/dead-code/simple/simple.factor
index 886233a08b..c9b73808a1 100755
--- a/basis/compiler/tree/dead-code/simple/simple.factor
+++ b/basis/compiler/tree/dead-code/simple/simple.factor
@@ -76,7 +76,7 @@ M: #alien-indirect compute-live-values* nip look-at-inputs ;
] ;
: drop-dead-outputs ( node -- #shuffle )
- dup out-d>> drop-dead-values tuck in-d>> >>out-d drop ;
+ dup out-d>> drop-dead-values [ in-d>> >>out-d drop ] keep ;
: some-outputs-dead? ( #call -- ? )
out-d>> [ live-value? not ] any? ;
diff --git a/basis/compiler/tree/propagation/inlining/inlining.factor b/basis/compiler/tree/propagation/inlining/inlining.factor
index 06d8d4f733..953956c3bd 100755
--- a/basis/compiler/tree/propagation/inlining/inlining.factor
+++ b/basis/compiler/tree/propagation/inlining/inlining.factor
@@ -17,8 +17,10 @@ IN: compiler.tree.propagation.inlining
! we are more eager to inline
SYMBOL: node-count
-: count-nodes ( nodes -- )
- 0 swap [ drop 1+ ] each-node node-count set ;
+: count-nodes ( nodes -- n )
+ 0 swap [ drop 1+ ] each-node ;
+
+: compute-node-count ( nodes -- ) count-nodes node-count set ;
! We try not to inline the same word too many times, to avoid
! combinatorial explosion
@@ -33,9 +35,6 @@ M: word splicing-nodes
M: callable splicing-nodes
build-sub-tree analyze-recursive normalize ;
-: propagate-body ( #call -- )
- body>> (propagate) ;
-
! Dispatch elimination
: eliminate-dispatch ( #call class/f word/quot/f -- ? )
dup [
@@ -44,7 +43,7 @@ M: callable splicing-nodes
2dup splicing-nodes
[ >>method ] [ >>body ] bi*
] if
- propagate-body t
+ body>> (propagate) t
] [ 2drop f >>method f >>body f >>class drop f ] if ;
: inlining-standard-method ( #call word -- class/f method/f )
@@ -161,10 +160,10 @@ SYMBOL: history
: inline-word-def ( #call word quot -- ? )
over history get memq? [ 3drop f ] [
[
- swap remember-inlining
- dupd splicing-nodes >>body
- propagate-body
- ] with-scope
+ [ remember-inlining ] dip
+ [ drop ] [ splicing-nodes ] 2bi
+ [ >>body drop ] [ count-nodes ] [ (propagate) ] tri
+ ] with-scope node-count +@
t
] if ;
@@ -177,6 +176,9 @@ SYMBOL: history
: always-inline-word? ( word -- ? )
{ curry compose } memq? ;
+: never-inline-word? ( word -- ? )
+ [ deferred? ] [ { call execute } memq? ] bi or ;
+
: custom-inlining? ( word -- ? )
"custom-inlining" word-prop ;
@@ -199,7 +201,7 @@ SYMBOL: history
#! calls the compiler at parse time (doing so is
#! discouraged, but it should still work.)
{
- { [ dup deferred? ] [ 2drop f ] }
+ { [ dup never-inline-word? ] [ 2drop f ] }
{ [ dup \ instance? eq? ] [ inline-instance-check ] }
{ [ dup always-inline-word? ] [ inline-word ] }
{ [ dup standard-generic? ] [ inline-standard-method ] }
diff --git a/basis/compiler/tree/propagation/propagation.factor b/basis/compiler/tree/propagation/propagation.factor
index 2a9825e3f1..3dd2c4998a 100644
--- a/basis/compiler/tree/propagation/propagation.factor
+++ b/basis/compiler/tree/propagation/propagation.factor
@@ -20,5 +20,5 @@ IN: compiler.tree.propagation
H{ } clone 1array value-infos set
H{ } clone 1array constraints set
H{ } clone inlining-count set
- dup count-nodes
+ dup compute-node-count
dup (propagate) ;
diff --git a/extra/rewrite-closures/tags.txt b/basis/constructors/tags.txt
similarity index 100%
rename from extra/rewrite-closures/tags.txt
rename to basis/constructors/tags.txt
diff --git a/basis/core-foundation/arrays/arrays.factor b/basis/core-foundation/arrays/arrays.factor
index 3708059f2b..1205352fcb 100644
--- a/basis/core-foundation/arrays/arrays.factor
+++ b/basis/core-foundation/arrays/arrays.factor
@@ -1,6 +1,6 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax kernel sequences ;
+USING: alien.syntax kernel sequences fry ;
IN: core-foundation.arrays
TYPEDEF: void* CFArrayRef
@@ -17,6 +17,5 @@ FUNCTION: CFIndex CFArrayGetCount ( CFArrayRef array ) ;
dup CFArrayGetCount [ CFArrayGetValueAtIndex ] with map ;
: ( seq -- alien )
- [ f swap length f CFArrayCreateMutable ] keep
- [ length ] keep
- [ [ dupd ] dip CFArraySetValueAtIndex ] 2each ;
+ f over length &: kCFTypeArrayCallBacks CFArrayCreateMutable
+ [ '[ [ _ ] 2dip swap CFArraySetValueAtIndex ] each-index ] keep ;
diff --git a/basis/core-foundation/attributed-strings/attributed-strings-tests.factor b/basis/core-foundation/attributed-strings/attributed-strings-tests.factor
new file mode 100644
index 0000000000..c96439a848
--- /dev/null
+++ b/basis/core-foundation/attributed-strings/attributed-strings-tests.factor
@@ -0,0 +1,7 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-foundation.attributed-strings
+core-foundation ;
+IN: core-foundation.attributed-strings.tests
+
+[ ] [ "Hello world" H{ } CFRelease ] unit-test
\ No newline at end of file
diff --git a/basis/core-foundation/attributed-strings/attributed-strings.factor b/basis/core-foundation/attributed-strings/attributed-strings.factor
new file mode 100644
index 0000000000..48c262f3a3
--- /dev/null
+++ b/basis/core-foundation/attributed-strings/attributed-strings.factor
@@ -0,0 +1,19 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax kernel destructors core-foundation
+core-foundation.utilities ;
+IN: core-foundation.attributed-strings
+
+TYPEDEF: void* CFAttributedStringRef
+
+FUNCTION: CFAttributedStringRef CFAttributedStringCreate (
+ CFAllocatorRef alloc,
+ CFStringRef str,
+ CFDictionaryRef attributes
+) ;
+
+: ( string assoc -- alien )
+ [
+ [ >cf &CFRelease ] bi@
+ [ kCFAllocatorDefault ] 2dip CFAttributedStringCreate
+ ] with-destructors ;
\ No newline at end of file
diff --git a/basis/core-foundation/attributed-strings/authors.txt b/basis/core-foundation/attributed-strings/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/core-foundation/attributed-strings/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/unmaintained/raptor/tags.txt b/basis/core-foundation/attributed-strings/tags.txt
similarity index 55%
rename from unmaintained/raptor/tags.txt
rename to basis/core-foundation/attributed-strings/tags.txt
index 6bf68304bb..2320bdd648 100644
--- a/unmaintained/raptor/tags.txt
+++ b/basis/core-foundation/attributed-strings/tags.txt
@@ -1 +1,2 @@
unportable
+bindings
diff --git a/basis/core-foundation/core-foundation.factor b/basis/core-foundation/core-foundation.factor
index 40269ae3be..82f836f28e 100644
--- a/basis/core-foundation/core-foundation.factor
+++ b/basis/core-foundation/core-foundation.factor
@@ -1,6 +1,6 @@
! Copyright (C) 2006, 2008 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax destructors accessors kernel ;
+USING: alien.syntax alien.c-types alien.destructors accessors kernel ;
IN: core-foundation
TYPEDEF: void* CFTypeRef
@@ -10,22 +10,27 @@ CONSTANT: kCFAllocatorDefault f
TYPEDEF: bool Boolean
TYPEDEF: long CFIndex
+TYPEDEF: char UInt8
TYPEDEF: int SInt32
TYPEDEF: uint UInt32
TYPEDEF: ulong CFTypeID
TYPEDEF: UInt32 CFOptionFlags
TYPEDEF: void* CFUUIDRef
+ALIAS:
+ALIAS: *CFIndex *long
+
+C-STRUCT: CFRange
+{ "CFIndex" "location" }
+{ "CFIndex" "length" } ;
+
+: ( location length -- range )
+ "CFRange"
+ [ set-CFRange-length ] keep
+ [ set-CFRange-location ] keep ;
+
FUNCTION: CFTypeRef CFRetain ( CFTypeRef cf ) ;
FUNCTION: void CFRelease ( CFTypeRef cf ) ;
-TUPLE: CFRelease-destructor alien disposed ;
-
-M: CFRelease-destructor dispose* alien>> CFRelease ;
-
-: &CFRelease ( alien -- alien )
- dup f CFRelease-destructor boa &dispose drop ; inline
-
-: |CFRelease ( alien -- alien )
- dup f CFRelease-destructor boa |dispose drop ; inline
+DESTRUCTOR: CFRelease
\ No newline at end of file
diff --git a/basis/core-foundation/data/data.factor b/basis/core-foundation/data/data.factor
index fb5ecaa043..c708eacecc 100644
--- a/basis/core-foundation/data/data.factor
+++ b/basis/core-foundation/data/data.factor
@@ -1,57 +1,20 @@
! Copyright (C) 2008 Joe Groff.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.c-types sequences kernel math ;
+USING: alien.c-types alien.syntax core-foundation.numbers kernel math
+sequences core-foundation.numbers ;
IN: core-foundation.data
TYPEDEF: void* CFDataRef
-TYPEDEF: void* CFDictionaryRef
-TYPEDEF: void* CFMutableDictionaryRef
-TYPEDEF: void* CFNumberRef
TYPEDEF: void* CFSetRef
-TYPEDEF: int CFNumberType
-CONSTANT: kCFNumberSInt8Type 1
-CONSTANT: kCFNumberSInt16Type 2
-CONSTANT: kCFNumberSInt32Type 3
-CONSTANT: kCFNumberSInt64Type 4
-CONSTANT: kCFNumberFloat32Type 5
-CONSTANT: kCFNumberFloat64Type 6
-CONSTANT: kCFNumberCharType 7
-CONSTANT: kCFNumberShortType 8
-CONSTANT: kCFNumberIntType 9
-CONSTANT: kCFNumberLongType 10
-CONSTANT: kCFNumberLongLongType 11
-CONSTANT: kCFNumberFloatType 12
-CONSTANT: kCFNumberDoubleType 13
-CONSTANT: kCFNumberCFIndexType 14
-CONSTANT: kCFNumberNSIntegerType 15
-CONSTANT: kCFNumberCGFloatType 16
-CONSTANT: kCFNumberMaxType 16
-
TYPEDEF: int CFPropertyListMutabilityOptions
-CONSTANT: kCFPropertyListImmutable 0
-CONSTANT: kCFPropertyListMutableContainers 1
+CONSTANT: kCFPropertyListImmutable 0
+CONSTANT: kCFPropertyListMutableContainers 1
CONSTANT: kCFPropertyListMutableContainersAndLeaves 2
-FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
-
FUNCTION: CFDataRef CFDataCreate ( CFAllocatorRef allocator, uchar* bytes, CFIndex length ) ;
FUNCTION: CFTypeID CFGetTypeID ( CFTypeRef cf ) ;
-GENERIC: ( number -- alien )
-
-M: integer
- [ f kCFNumberLongLongType ] dip CFNumberCreate ;
-
-M: float
- [ f kCFNumberDoubleType ] dip CFNumberCreate ;
-
-M: t
- drop f kCFNumberIntType 1 CFNumberCreate ;
-
-M: f
- drop f kCFNumberIntType 0 CFNumberCreate ;
-
: ( byte-array -- alien )
- [ f ] dip dup length CFDataCreate ;
+ [ f ] dip dup length CFDataCreate ;
\ No newline at end of file
diff --git a/basis/core-foundation/dictionaries/authors.txt b/basis/core-foundation/dictionaries/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/core-foundation/dictionaries/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/core-foundation/dictionaries/dictionaries-tests.factor b/basis/core-foundation/dictionaries/dictionaries-tests.factor
new file mode 100644
index 0000000000..61ca131788
--- /dev/null
+++ b/basis/core-foundation/dictionaries/dictionaries-tests.factor
@@ -0,0 +1,18 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-foundation core-foundation.dictionaries
+arrays destructors core-foundation.strings kernel namespaces ;
+IN: core-foundation.dictionaries.tests
+
+[ ] [ { } CFRelease ] unit-test
+
+[ "raps in the back of cars and doesn't afraid of anything" ] [
+ [
+ "cpst" &CFRelease dup "key" set
+ "raps in the back of cars and doesn't afraid of anything" &CFRelease
+ 2array 1array &CFRelease
+ "key" get
+ CFDictionaryGetValue
+ dup [ CF>string ] when
+ ] with-destructors
+] unit-test
\ No newline at end of file
diff --git a/basis/core-foundation/dictionaries/dictionaries.factor b/basis/core-foundation/dictionaries/dictionaries.factor
new file mode 100644
index 0000000000..f758e0e63a
--- /dev/null
+++ b/basis/core-foundation/dictionaries/dictionaries.factor
@@ -0,0 +1,32 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.syntax core-foundation kernel assocs
+specialized-arrays.alien math sequences accessors ;
+IN: core-foundation.dictionaries
+
+TYPEDEF: void* CFDictionaryRef
+TYPEDEF: void* CFMutableDictionaryRef
+TYPEDEF: void* CFDictionaryKeyCallBacks*
+TYPEDEF: void* CFDictionaryValueCallBacks*
+
+FUNCTION: CFDictionaryRef CFDictionaryCreate (
+ CFAllocatorRef allocator,
+ void** keys,
+ void** values,
+ CFIndex numValues,
+ CFDictionaryKeyCallBacks* keyCallBacks,
+ CFDictionaryValueCallBacks* valueCallBacks
+) ;
+
+FUNCTION: void* CFDictionaryGetValue (
+ CFDictionaryRef theDict,
+ void* key
+) ;
+
+: ( alist -- dictionary )
+ [ kCFAllocatorDefault ] dip
+ unzip [ >void*-array ] bi@
+ [ [ underlying>> ] bi@ ] [ nip length ] 2bi
+ &: kCFTypeDictionaryKeyCallBacks
+ &: kCFTypeDictionaryValueCallBacks
+ CFDictionaryCreate ;
\ No newline at end of file
diff --git a/unmaintained/route/tags.txt b/basis/core-foundation/dictionaries/tags.txt
similarity index 55%
rename from unmaintained/route/tags.txt
rename to basis/core-foundation/dictionaries/tags.txt
index 6bf68304bb..2320bdd648 100644
--- a/unmaintained/route/tags.txt
+++ b/basis/core-foundation/dictionaries/tags.txt
@@ -1 +1,2 @@
unportable
+bindings
diff --git a/basis/core-foundation/numbers/authors.txt b/basis/core-foundation/numbers/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/core-foundation/numbers/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/core-foundation/numbers/numbers-tests.factor b/basis/core-foundation/numbers/numbers-tests.factor
new file mode 100644
index 0000000000..1c50f2dcb2
--- /dev/null
+++ b/basis/core-foundation/numbers/numbers-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-foundation.numbers ;
+IN: core-foundation.numbers.tests
diff --git a/basis/core-foundation/numbers/numbers.factor b/basis/core-foundation/numbers/numbers.factor
new file mode 100644
index 0000000000..f01f522d61
--- /dev/null
+++ b/basis/core-foundation/numbers/numbers.factor
@@ -0,0 +1,42 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax kernel math core-foundation ;
+IN: core-foundation.numbers
+
+TYPEDEF: void* CFNumberRef
+
+TYPEDEF: int CFNumberType
+CONSTANT: kCFNumberSInt8Type 1
+CONSTANT: kCFNumberSInt16Type 2
+CONSTANT: kCFNumberSInt32Type 3
+CONSTANT: kCFNumberSInt64Type 4
+CONSTANT: kCFNumberFloat32Type 5
+CONSTANT: kCFNumberFloat64Type 6
+CONSTANT: kCFNumberCharType 7
+CONSTANT: kCFNumberShortType 8
+CONSTANT: kCFNumberIntType 9
+CONSTANT: kCFNumberLongType 10
+CONSTANT: kCFNumberLongLongType 11
+CONSTANT: kCFNumberFloatType 12
+CONSTANT: kCFNumberDoubleType 13
+CONSTANT: kCFNumberCFIndexType 14
+CONSTANT: kCFNumberNSIntegerType 15
+CONSTANT: kCFNumberCGFloatType 16
+CONSTANT: kCFNumberMaxType 16
+
+FUNCTION: CFNumberRef CFNumberCreate ( CFAllocatorRef allocator, CFNumberType theType, void* valuePtr ) ;
+
+GENERIC: ( number -- alien )
+
+M: integer
+ [ f kCFNumberLongLongType ] dip CFNumberCreate ;
+
+M: float
+ [ f kCFNumberDoubleType ] dip CFNumberCreate ;
+
+M: t
+ drop f kCFNumberIntType 1 CFNumberCreate ;
+
+M: f
+ drop f kCFNumberIntType 0 CFNumberCreate ;
+
diff --git a/basis/ui/cocoa/tags.txt b/basis/core-foundation/numbers/tags.txt
similarity index 100%
rename from basis/ui/cocoa/tags.txt
rename to basis/core-foundation/numbers/tags.txt
diff --git a/basis/core-foundation/run-loop/run-loop.factor b/basis/core-foundation/run-loop/run-loop.factor
index 8bdce2ec37..a63a3ea674 100644
--- a/basis/core-foundation/run-loop/run-loop.factor
+++ b/basis/core-foundation/run-loop/run-loop.factor
@@ -56,25 +56,17 @@ FUNCTION: void CFRunLoopRemoveTimer (
: CFRunLoopDefaultMode ( -- alien )
#! Ugly, but we don't have static NSStrings
- \ CFRunLoopDefaultMode get-global dup expired? [
- drop
+ \ CFRunLoopDefaultMode [
"kCFRunLoopDefaultMode"
- dup \ CFRunLoopDefaultMode set-global
- ] when ;
+ ] initialize-alien ;
TUPLE: run-loop fds sources timers ;
: ( -- run-loop )
V{ } clone V{ } clone V{ } clone \ run-loop boa ;
-SYMBOL: expiry-check
-
: run-loop ( -- run-loop )
- \ run-loop get-global not expiry-check get expired? or
- [
- 31337 expiry-check set-global
- dup \ run-loop set-global
- ] [ \ run-loop get-global ] if ;
+ \ run-loop [ ] initialize-alien ;
: add-source-to-run-loop ( source -- )
[ run-loop sources>> push ]
diff --git a/basis/core-foundation/strings/strings-tests.factor b/basis/core-foundation/strings/strings-tests.factor
index 39d5ee6ac0..1c52752b21 100644
--- a/basis/core-foundation/strings/strings-tests.factor
+++ b/basis/core-foundation/strings/strings-tests.factor
@@ -1,9 +1,15 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: core-foundation.strings core-foundation tools.test kernel ;
+USING: core-foundation.strings core-foundation tools.test kernel
+strings ;
IN: core-foundation
[ ] [ "Hello" CFRelease ] unit-test
[ "Hello" ] [ "Hello" [ CF>string ] [ CFRelease ] bi ] unit-test
[ "Hello\u003456" ] [ "Hello\u003456" [ CF>string ] [ CFRelease ] bi ] unit-test
[ "Hello\u013456" ] [ "Hello\u013456" [ CF>string ] [ CFRelease ] bi ] unit-test
+[ ] [ "\0" CFRelease ] unit-test
+[ "\0" ] [ "\0" [ CF>string ] [ CFRelease ] bi ] unit-test
+
+! This shouldn't fail
+[ ] [ { HEX: 123456 } >string CFRelease ] unit-test
\ No newline at end of file
diff --git a/basis/core-foundation/strings/strings.factor b/basis/core-foundation/strings/strings.factor
index 50c17dc6fd..21f3d7efd4 100644
--- a/basis/core-foundation/strings/strings.factor
+++ b/basis/core-foundation/strings/strings.factor
@@ -1,7 +1,8 @@
-! Copyright (C) 2008 Slava Pestov.
+! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
-USING: alien.syntax alien.strings kernel sequences byte-arrays
-io.encodings.utf8 math core-foundation core-foundation.arrays ;
+USING: alien.syntax alien.strings io.encodings.string kernel
+sequences byte-arrays io.encodings.utf8 math core-foundation
+core-foundation.arrays destructors unicode.data ;
IN: core-foundation.strings
TYPEDEF: void* CFStringRef
@@ -41,26 +42,44 @@ FUNCTION: Boolean CFStringGetCString (
CFStringEncoding encoding
) ;
+FUNCTION: CFIndex CFStringGetBytes (
+ CFStringRef theString,
+ CFRange range,
+ CFStringEncoding encoding,
+ UInt8 lossByte,
+ Boolean isExternalRepresentation,
+ UInt8* buffer,
+ CFIndex maxBufLen,
+ CFIndex* usedBufLen
+) ;
+
FUNCTION: CFStringRef CFStringCreateWithCString (
CFAllocatorRef alloc,
char* cStr,
CFStringEncoding encoding
) ;
+: prepare-CFString ( string -- byte-array )
+ [
+ dup HEX: 10ffff >
+ [ drop CHAR: replacement-character ] when
+ ] map utf8 encode ;
+
: ( string -- alien )
- f swap utf8 string>alien kCFStringEncodingUTF8 CFStringCreateWithCString
- [ "CFStringCreateWithCString failed" throw ] unless* ;
+ [ f ] dip
+ prepare-CFString dup length
+ kCFStringEncodingUTF8 f
+ CFStringCreateWithBytes
+ [ "CFStringCreateWithBytes failed" throw ] unless* ;
: CF>string ( alien -- string )
- dup CFStringGetLength 4 * 1 + [
- dup length
- kCFStringEncodingUTF8
- CFStringGetCString
- [ "CFStringGetCString failed" throw ] unless
- ] keep utf8 alien>string ;
+ dup CFStringGetLength
+ [ 0 swap kCFStringEncodingUTF8 0 f ] keep
+ 4 * 1 + [ dup length 0 [ CFStringGetBytes drop ] keep ] keep
+ swap *CFIndex head-slice utf8 decode ;
: CF>string-array ( alien -- seq )
CF>array [ CF>string ] map ;
: ( seq -- alien )
- [ ] map [ ] [ [ CFRelease ] each ] bi ;
+ [ [ &CFRelease ] map ] with-destructors ;
diff --git a/basis/core-foundation/summary.txt b/basis/core-foundation/summary.txt
index c5f2d1b545..4adcc10e48 100644
--- a/basis/core-foundation/summary.txt
+++ b/basis/core-foundation/summary.txt
@@ -1 +1 @@
-Mac OS X CoreFoundation binding
+Binding to Mac OS X CoreFoundation library
diff --git a/basis/core-foundation/utilities/authors.txt b/basis/core-foundation/utilities/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/core-foundation/utilities/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/ui/cocoa/tools/tags.txt b/basis/core-foundation/utilities/tags.txt
similarity index 100%
rename from basis/ui/cocoa/tools/tags.txt
rename to basis/core-foundation/utilities/tags.txt
diff --git a/basis/core-foundation/utilities/utilities-tests.factor b/basis/core-foundation/utilities/utilities-tests.factor
new file mode 100644
index 0000000000..fb3deb2ca5
--- /dev/null
+++ b/basis/core-foundation/utilities/utilities-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-foundation.utilities ;
+IN: core-foundation.utilities.tests
diff --git a/basis/core-foundation/utilities/utilities.factor b/basis/core-foundation/utilities/utilities.factor
new file mode 100644
index 0000000000..3dd760f7c4
--- /dev/null
+++ b/basis/core-foundation/utilities/utilities.factor
@@ -0,0 +1,21 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: math assocs kernel sequences byte-arrays strings
+hashtables alien destructors
+core-foundation.numbers core-foundation.strings
+core-foundation.arrays core-foundation.dictionaries
+core-foundation.data core-foundation ;
+IN: core-foundation.utilities
+
+GENERIC: (>cf) ( obj -- cf )
+
+M: number (>cf) ;
+M: t (>cf) ;
+M: f (>cf) ;
+M: string (>cf) ;
+M: byte-array (>cf) ;
+M: hashtable (>cf) [ [ (>cf) &CFRelease ] bi@ ] assoc-map ;
+M: sequence (>cf) [ (>cf) &CFRelease ] map ;
+M: alien (>cf) CFRetain ;
+
+: >cf ( obj -- cf ) [ (>cf) ] with-destructors ;
\ No newline at end of file
diff --git a/basis/freetype/authors.txt b/basis/core-graphics/authors.txt
similarity index 100%
rename from basis/freetype/authors.txt
rename to basis/core-graphics/authors.txt
diff --git a/basis/core-graphics/core-graphics-docs.factor b/basis/core-graphics/core-graphics-docs.factor
new file mode 100644
index 0000000000..e69de29bb2
diff --git a/basis/core-graphics/core-graphics-tests.factor b/basis/core-graphics/core-graphics-tests.factor
new file mode 100644
index 0000000000..b032a7763a
--- /dev/null
+++ b/basis/core-graphics/core-graphics-tests.factor
@@ -0,0 +1,8 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-graphics kernel images ;
+IN: core-graphics.tests
+
+[ t ] [ { 100 200 } [ drop ] make-bitmap-image image? ] unit-test
+
+[ ] [ dummy-context drop ] unit-test
\ No newline at end of file
diff --git a/basis/core-graphics/core-graphics.factor b/basis/core-graphics/core-graphics.factor
new file mode 100644
index 0000000000..5e95e2e36e
--- /dev/null
+++ b/basis/core-graphics/core-graphics.factor
@@ -0,0 +1,130 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien alien.c-types alien.destructors alien.syntax accessors
+destructors fry kernel math math.bitwise sequences libc colors
+images images.memory core-graphics.types core-foundation.utilities ;
+IN: core-graphics
+
+! CGImageAlphaInfo
+C-ENUM:
+kCGImageAlphaNone
+kCGImageAlphaPremultipliedLast
+kCGImageAlphaPremultipliedFirst
+kCGImageAlphaLast
+kCGImageAlphaFirst
+kCGImageAlphaNoneSkipLast
+kCGImageAlphaNoneSkipFirst ;
+
+: kCGBitmapAlphaInfoMask ( -- n ) HEX: 1f ; inline
+: kCGBitmapFloatComponents ( -- n ) 1 8 shift ; inline
+
+: kCGBitmapByteOrderMask ( -- n ) HEX: 7000 ; inline
+: kCGBitmapByteOrderDefault ( -- n ) 0 12 shift ; inline
+: kCGBitmapByteOrder16Little ( -- n ) 1 12 shift ; inline
+: kCGBitmapByteOrder32Little ( -- n ) 2 12 shift ; inline
+: kCGBitmapByteOrder16Big ( -- n ) 3 12 shift ; inline
+: kCGBitmapByteOrder32Big ( -- n ) 4 12 shift ; inline
+
+: kCGBitmapByteOrder16Host ( -- n )
+ little-endian?
+ kCGBitmapByteOrder16Little
+ kCGBitmapByteOrder16Big ? ; foldable
+
+: kCGBitmapByteOrder32Host ( -- n )
+ little-endian?
+ kCGBitmapByteOrder32Little
+ kCGBitmapByteOrder32Big ? ; foldable
+
+FUNCTION: CGColorRef CGColorCreateGenericRGB (
+ CGFloat red,
+ CGFloat green,
+ CGFloat blue,
+ CGFloat alpha
+) ;
+
+: ( color -- CGColor )
+ >rgba-components CGColorCreateGenericRGB ;
+
+M: color (>cf) ;
+
+FUNCTION: CGColorSpaceRef CGColorSpaceCreateDeviceRGB ( ) ;
+
+FUNCTION: CGContextRef CGBitmapContextCreate (
+ void* data,
+ size_t width,
+ size_t height,
+ size_t bitsPerComponent,
+ size_t bytesPerRow,
+ CGColorSpaceRef colorspace,
+ CGBitmapInfo bitmapInfo
+) ;
+
+FUNCTION: void CGColorSpaceRelease ( CGColorSpaceRef ref ) ;
+
+DESTRUCTOR: CGColorSpaceRelease
+
+FUNCTION: void CGContextRelease ( CGContextRef ref ) ;
+
+DESTRUCTOR: CGContextRelease
+
+FUNCTION: void CGContextSetRGBStrokeColor (
+ CGContextRef c,
+ CGFloat red,
+ CGFloat green,
+ CGFloat blue,
+ CGFloat alpha
+) ;
+
+FUNCTION: void CGContextSetRGBFillColor (
+ CGContextRef c,
+ CGFloat red,
+ CGFloat green,
+ CGFloat blue,
+ CGFloat alpha
+) ;
+
+FUNCTION: void CGContextSetTextPosition (
+ CGContextRef c,
+ CGFloat x,
+ CGFloat y
+) ;
+
+FUNCTION: void CGContextFillRect (
+ CGContextRef c,
+ CGRect rect
+) ;
+
+FUNCTION: void CGContextSetShouldSmoothFonts (
+ CGContextRef c,
+ bool shouldSmoothFonts
+) ;
+
+FUNCTION: void* CGBitmapContextGetData ( CGContextRef c ) ;
+
+CONSTANT: kCGLRendererGenericFloatID HEX: 00020400
+
+FUNCTION: CGLError CGLSetParameter ( CGLContextObj ctx, CGLContextParameter pname, GLint* params ) ;
+
+ ( data dim -- context )
+ [ first2 8 ] [ first 4 * ] bi
+ bitmap-color-space bitmap-flags CGBitmapContextCreate
+ [ "CGBitmapContextCreate failed" throw ] unless* ;
+
+PRIVATE>
+
+: dummy-context ( -- context )
+ \ dummy-context [
+ [ 4 malloc { 1 1 } ] with-destructors
+ ] initialize-alien ;
+
+: make-bitmap-image ( dim quot -- image )
+ '[ &CGContextRelease @ ] make-memory-bitmap
+ ARGB >>component-order ; inline
diff --git a/basis/core-graphics/summary.txt b/basis/core-graphics/summary.txt
new file mode 100644
index 0000000000..f0529e32b7
--- /dev/null
+++ b/basis/core-graphics/summary.txt
@@ -0,0 +1 @@
+Binding to Mac OS X Core Graphics library
diff --git a/unmaintained/sockios/tags.txt b/basis/core-graphics/tags.txt
similarity index 55%
rename from unmaintained/sockios/tags.txt
rename to basis/core-graphics/tags.txt
index 6bf68304bb..2320bdd648 100644
--- a/unmaintained/sockios/tags.txt
+++ b/basis/core-graphics/tags.txt
@@ -1 +1,2 @@
unportable
+bindings
diff --git a/basis/core-graphics/types/authors.txt b/basis/core-graphics/types/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/core-graphics/types/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/core-graphics/types/types-docs.factor b/basis/core-graphics/types/types-docs.factor
new file mode 100644
index 0000000000..e35c81d38a
--- /dev/null
+++ b/basis/core-graphics/types/types-docs.factor
@@ -0,0 +1,29 @@
+USING: math help.markup help.syntax ;
+IN: core-graphics.types
+
+HELP:
+{ $values { "x" real } { "y" real } { "w" real } { "h" real } { "rect" "an " { $snippet "CGRect" } } }
+{ $description "Allocates a new " { $snippet "CGRect" } " in the Factor heap." } ;
+
+HELP:
+{ $values { "x" real } { "y" real } { "point" "an " { $snippet "CGPoint" } } }
+{ $description "Allocates a new " { $snippet "CGPoint" } " in the Factor heap." } ;
+
+HELP:
+{ $values { "w" real } { "h" real } { "size" "an " { $snippet "CGSize" } } }
+{ $description "Allocates a new " { $snippet "CGSize" } " in the Factor heap." } ;
+
+ARTICLE: "core-graphics.types" "Core Graphics types"
+"The Core Graphics binding defines some common C structs:"
+{ $code
+ "CGRect"
+ "CGPoint"
+ "CGSize"
+}
+"Some words for working with the above:"
+{ $subsection }
+{ $subsection }
+{ $subsection } ;
+
+IN: core-graphics.types
+ABOUT: "core-graphics.types"
diff --git a/basis/core-graphics/types/types-tests.factor b/basis/core-graphics/types/types-tests.factor
new file mode 100644
index 0000000000..d3b081fccc
--- /dev/null
+++ b/basis/core-graphics/types/types-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-graphics.types ;
+IN: core-graphics.types.tests
diff --git a/basis/core-graphics/types/types.factor b/basis/core-graphics/types/types.factor
new file mode 100644
index 0000000000..13e4285ea1
--- /dev/null
+++ b/basis/core-graphics/types/types.factor
@@ -0,0 +1,94 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: alien.c-types alien.syntax kernel layouts
+math math.rectangles arrays ;
+IN: core-graphics.types
+
+<< cell 4 = "float" "double" ? "CGFloat" typedef >>
+
+: ( x -- alien )
+ cell 4 = [ ] [ ] if ; inline
+
+: *CGFloat ( alien -- x )
+ cell 4 = [ *float ] [ *double ] if ; inline
+
+C-STRUCT: CGPoint
+ { "CGFloat" "x" }
+ { "CGFloat" "y" } ;
+
+: ( x y -- point )
+ "CGPoint"
+ [ set-CGPoint-y ] keep
+ [ set-CGPoint-x ] keep ;
+
+C-STRUCT: CGSize
+ { "CGFloat" "w" }
+ { "CGFloat" "h" } ;
+
+: ( w h -- size )
+ "CGSize"
+ [ set-CGSize-h ] keep
+ [ set-CGSize-w ] keep ;
+
+C-STRUCT: CGRect
+ { "CGPoint" "origin" }
+ { "CGSize" "size" } ;
+
+: CGPoint>loc ( CGPoint -- loc )
+ [ CGPoint-x ] [ CGPoint-y ] bi 2array ;
+
+: CGSize>dim ( CGSize -- dim )
+ [ CGSize-w ] [ CGSize-h ] bi 2array ;
+
+: CGRect>rect ( CGRect -- rect )
+ [ CGRect-origin CGPoint>loc ]
+ [ CGRect-size CGSize>dim ]
+ bi ; inline
+
+: CGRect-x ( CGRect -- x )
+ CGRect-origin CGPoint-x ; inline
+: CGRect-y ( CGRect -- y )
+ CGRect-origin CGPoint-y ; inline
+: CGRect-w ( CGRect -- w )
+ CGRect-size CGSize-w ; inline
+: CGRect-h ( CGRect -- h )
+ CGRect-size CGSize-h ; inline
+
+: set-CGRect-x ( x CGRect -- )
+ CGRect-origin set-CGPoint-x ; inline
+: set-CGRect-y ( y CGRect -- )
+ CGRect-origin set-CGPoint-y ; inline
+: set-CGRect-w ( w CGRect -- )
+ CGRect-size set-CGSize-w ; inline
+: set-CGRect-h ( h CGRect -- )
+ CGRect-size set-CGSize-h ; inline
+
+: ( x y w h -- rect )
+ "CGRect"
+ [ set-CGRect-h ] keep
+ [ set-CGRect-w ] keep
+ [ set-CGRect-y ] keep
+ [ set-CGRect-x ] keep ;
+
+: CGRect-x-y ( alien -- origin-x origin-y )
+ [ CGRect-x ] [ CGRect-y ] bi ;
+
+: CGRect-top-left ( alien -- x y )
+ [ CGRect-x ] [ [ CGRect-y ] [ CGRect-h ] bi + ] bi ;
+
+C-STRUCT: CGAffineTransform
+ { "CGFloat" "a" }
+ { "CGFloat" "b" }
+ { "CGFloat" "c" }
+ { "CGFloat" "d" }
+ { "CGFloat" "tx" }
+ { "CGFloat" "ty" } ;
+
+TYPEDEF: void* CGColorRef
+TYPEDEF: void* CGColorSpaceRef
+TYPEDEF: void* CGContextRef
+TYPEDEF: uint CGBitmapInfo
+
+TYPEDEF: int CGLError
+TYPEDEF: void* CGLContextObj
+TYPEDEF: int CGLContextParameter
\ No newline at end of file
diff --git a/basis/core-text/authors.txt b/basis/core-text/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/core-text/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/core-text/core-text-tests.factor b/basis/core-text/core-text-tests.factor
new file mode 100644
index 0000000000..a5cf69fdee
--- /dev/null
+++ b/basis/core-text/core-text-tests.factor
@@ -0,0 +1,36 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-text core-text.fonts core-foundation
+core-foundation.dictionaries destructors arrays kernel generalizations
+math accessors core-foundation.utilities combinators hashtables colors
+colors.constants ;
+IN: core-text.tests
+
+: test-font ( name -- font )
+ [ >cf &CFRelease 0.0 f CTFontCreateWithName ] with-destructors ;
+
+[ ] [ "Helvetica" test-font CFRelease ] unit-test
+
+[ ] [
+ [
+ kCTFontAttributeName "Helvetica" test-font &CFRelease 2array 1array
+ &CFRelease drop
+ ] with-destructors
+] unit-test
+
+: test-typographic-bounds ( string font -- ? )
+ [
+ test-font &CFRelease tuck COLOR: white &CFRelease
+ compute-line-metrics {
+ [ width>> float? ]
+ [ ascent>> float? ]
+ [ descent>> float? ]
+ [ leading>> float? ]
+ } cleave and and and
+ ] with-destructors ;
+
+[ t ] [ "Hello world" "Helvetica" test-typographic-bounds ] unit-test
+
+[ t ] [ "Hello world" "Chicago" test-typographic-bounds ] unit-test
+
+[ t ] [ "日本語" "Helvetica" test-typographic-bounds ] unit-test
\ No newline at end of file
diff --git a/basis/core-text/core-text.factor b/basis/core-text/core-text.factor
new file mode 100644
index 0000000000..de3b5ac715
--- /dev/null
+++ b/basis/core-text/core-text.factor
@@ -0,0 +1,145 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays alien alien.c-types alien.syntax kernel destructors
+accessors fry words hashtables strings sequences memoize assocs math
+math.vectors math.rectangles math.functions locals init namespaces
+combinators fonts colors cache core-foundation core-foundation.strings
+core-foundation.attributed-strings core-foundation.utilities
+core-graphics core-graphics.types core-text.fonts core-text.utilities ;
+IN: core-text
+
+TYPEDEF: void* CTLineRef
+
+C-GLOBAL: kCTFontAttributeName
+C-GLOBAL: kCTKernAttributeName
+C-GLOBAL: kCTLigatureAttributeName
+C-GLOBAL: kCTForegroundColorAttributeName
+C-GLOBAL: kCTParagraphStyleAttributeName
+C-GLOBAL: kCTUnderlineStyleAttributeName
+C-GLOBAL: kCTVerticalFormsAttributeName
+C-GLOBAL: kCTGlyphInfoAttributeName
+
+FUNCTION: CTLineRef CTLineCreateWithAttributedString ( CFAttributedStringRef string ) ;
+
+FUNCTION: void CTLineDraw ( CTLineRef line, CGContextRef context ) ;
+
+FUNCTION: CGFloat CTLineGetOffsetForStringIndex ( CTLineRef line, CFIndex charIndex, CGFloat* secondaryOffset ) ;
+
+FUNCTION: CFIndex CTLineGetStringIndexForPosition ( CTLineRef line, CGPoint position ) ;
+
+FUNCTION: double CTLineGetTypographicBounds ( CTLineRef line, CGFloat* ascent, CGFloat* descent, CGFloat* leading ) ;
+
+FUNCTION: CGRect CTLineGetImageBounds ( CTLineRef line, CGContextRef context ) ;
+
+ERROR: not-a-string object ;
+
+: ( string open-font color -- line )
+ [
+ [
+ dup selection? [ string>> ] when
+ dup string? [ not-a-string ] unless
+ ] 2dip
+ [
+ kCTForegroundColorAttributeName set
+ kCTFontAttributeName set
+ ] H{ } make-assoc &CFRelease
+ CTLineCreateWithAttributedString
+ ] with-destructors ;
+
+TUPLE: line line metrics image loc dim disposed ;
+
+: typographic-bounds ( line -- width ascent descent leading )
+ 0 0 0
+ [ CTLineGetTypographicBounds ] 3keep [ *CGFloat ] tri@ ; inline
+
+: store-typographic-bounds ( metrics width ascent descent leading -- metrics )
+ {
+ [ >>width ]
+ [ >>ascent ]
+ [ >>descent ]
+ [ >>leading ]
+ } spread ; inline
+
+: compute-font-metrics ( metrics font -- metrics )
+ [ CTFontGetCapHeight >>cap-height ]
+ [ CTFontGetXHeight >>x-height ]
+ bi ; inline
+
+: compute-line-metrics ( open-font line -- line-metrics )
+ [ metrics new ] 2dip
+ [ compute-font-metrics ]
+ [ typographic-bounds store-typographic-bounds ] bi*
+ compute-height ;
+
+: metrics>dim ( bounds -- dim )
+ [ width>> ] [ [ ascent>> ] [ descent>> ] bi + ] bi
+ [ ceiling >integer ]
+ bi@ 2array ;
+
+: fill-background ( context font dim -- )
+ [ background>> >rgba-components CGContextSetRGBFillColor ]
+ [ [ 0 0 ] dip first2 CGContextFillRect ]
+ bi-curry* bi ;
+
+: selection-rect ( dim line selection -- rect )
+ [ start>> ] [ end>> ] bi
+ [ f CTLineGetOffsetForStringIndex round ] bi-curry@ bi
+ [ drop nip 0 ] [ swap - swap second ] 3bi ;
+
+: CGRect-translate-x ( CGRect x -- CGRect' )
+ [ dup CGRect-x ] dip - over set-CGRect-x ;
+
+:: fill-selection-background ( context loc dim line string -- )
+ string selection? [
+ context string color>> >rgba-components CGContextSetRGBFillColor
+ context dim line string selection-rect
+ loc first CGRect-translate-x
+ CGContextFillRect
+ ] when ;
+
+: line-rect ( line -- rect )
+ dummy-context CTLineGetImageBounds ;
+
+: set-text-position ( context loc -- )
+ first2 [ neg ] bi@ CGContextSetTextPosition ;
+
+:: line-loc ( metrics loc dim -- loc )
+ loc first
+ metrics ascent>> ceiling dim second loc second + - 2array ;
+
+:: ( font string -- line )
+ [
+ [let* | open-font [ font cache-font ]
+ line [ string open-font font foreground>> |CFRelease ]
+
+ rect [ line line-rect ]
+ (loc) [ rect CGRect-origin CGPoint>loc ]
+ (dim) [ rect CGRect-size CGSize>dim ]
+ (ext) [ (loc) (dim) v+ ]
+ loc [ (loc) [ floor ] map ]
+ ext [ (loc) (dim) [ + ceiling ] 2map ]
+ dim [ ext loc [ - >integer ] 2map ]
+ metrics [ open-font line compute-line-metrics ] |
+ line metrics
+ dim [
+ {
+ [ font dim fill-background ]
+ [ loc dim line string fill-selection-background ]
+ [ loc set-text-position ]
+ [ [ line ] dip CTLineDraw ]
+ } cleave
+ ] make-bitmap-image
+ metrics loc dim line-loc
+ metrics metrics>dim
+ ]
+ f line boa
+ ] with-destructors ;
+
+M: line dispose* line>> CFRelease ;
+
+SYMBOL: cached-lines
+
+: cached-line ( font string -- line )
+ cached-lines get [ ] 2cache ;
+
+[ cached-lines set-global ] "core-text" add-init-hook
\ No newline at end of file
diff --git a/basis/core-text/fonts/authors.txt b/basis/core-text/fonts/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/core-text/fonts/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/core-text/fonts/fonts-tests.factor b/basis/core-text/fonts/fonts-tests.factor
new file mode 100644
index 0000000000..45fa2bcdc0
--- /dev/null
+++ b/basis/core-text/fonts/fonts-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-text.fonts ;
+IN: core-text.fonts.tests
diff --git a/basis/core-text/fonts/fonts.factor b/basis/core-text/fonts/fonts.factor
new file mode 100644
index 0000000000..4525509d44
--- /dev/null
+++ b/basis/core-text/fonts/fonts.factor
@@ -0,0 +1,129 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: accessors alien.syntax assocs core-foundation
+core-foundation.strings core-text.utilities destructors init
+kernel math memoize fonts combinators ;
+IN: core-text.fonts
+
+TYPEDEF: void* CTFontRef
+TYPEDEF: void* CTFontDescriptorRef
+
+! CTFontSymbolicTraits
+: kCTFontItalicTrait ( -- n ) 0 2^ ; inline
+: kCTFontBoldTrait ( -- n ) 1 2^ ; inline
+: kCTFontExpandedTrait ( -- n ) 5 2^ ; inline
+: kCTFontCondensedTrait ( -- n ) 6 2^ ; inline
+: kCTFontMonoSpaceTrait ( -- n ) 10 2^ ; inline
+: kCTFontVerticalTrait ( -- n ) 11 2^ ; inline
+: kCTFontUIOptimizedTrait ( -- n ) 12 2^ ; inline
+
+C-GLOBAL: kCTFontSymbolicTrait
+C-GLOBAL: kCTFontWeightTrait
+C-GLOBAL: kCTFontWidthTrait
+C-GLOBAL: kCTFontSlantTrait
+
+C-GLOBAL: kCTFontNameAttribute
+C-GLOBAL: kCTFontDisplayNameAttribute
+C-GLOBAL: kCTFontFamilyNameAttribute
+C-GLOBAL: kCTFontStyleNameAttribute
+C-GLOBAL: kCTFontTraitsAttribute
+C-GLOBAL: kCTFontVariationAttribute
+C-GLOBAL: kCTFontSizeAttribute
+C-GLOBAL: kCTFontMatrixAttribute
+C-GLOBAL: kCTFontCascadeListAttribute
+C-GLOBAL: kCTFontCharacterSetAttribute
+C-GLOBAL: kCTFontLanguagesAttribute
+C-GLOBAL: kCTFontBaselineAdjustAttribute
+C-GLOBAL: kCTFontMacintoshEncodingsAttribute
+C-GLOBAL: kCTFontFeaturesAttribute
+C-GLOBAL: kCTFontFeatureSettingsAttribute
+C-GLOBAL: kCTFontFixedAdvanceAttribute
+C-GLOBAL: kCTFontOrientationAttribute
+
+FUNCTION: CTFontDescriptorRef CTFontDescriptorCreateWithAttributes (
+ CFDictionaryRef attributes
+) ;
+
+FUNCTION: CTFontRef CTFontCreateWithName (
+ CFStringRef name,
+ CGFloat size,
+ CGAffineTransform* matrix
+) ;
+
+FUNCTION: CTFontRef CTFontCreateWithFontDescriptor (
+ CTFontDescriptorRef descriptor,
+ CGFloat size,
+ CGAffineTransform* matrix
+) ;
+
+FUNCTION: CTFontRef CTFontCreateCopyWithSymbolicTraits (
+ CTFontRef font,
+ CGFloat size,
+ CGAffineTransform* matrix,
+ uint32_t symTraitValue,
+ uint32_t symTraitMask
+) ;
+
+FUNCTION: CGFloat CTFontGetAscent ( CTFontRef font ) ;
+
+FUNCTION: CGFloat CTFontGetDescent ( CTFontRef font ) ;
+
+FUNCTION: CGFloat CTFontGetLeading ( CTFontRef font ) ;
+
+FUNCTION: CGFloat CTFontGetCapHeight ( CTFontRef font ) ;
+
+FUNCTION: CGFloat CTFontGetXHeight ( CTFontRef font ) ;
+
+CONSTANT: font-names
+ H{
+ { "monospace" "Monaco" }
+ { "sans-serif" "Lucida Grande" }
+ { "serif" "Times" }
+ }
+
+: font-name ( string -- string' )
+ font-names at-default ;
+
+: (bold) ( x -- y ) kCTFontBoldTrait bitor ; inline
+
+: (italic) ( x -- y ) kCTFontItalicTrait bitor ; inline
+
+: font-traits ( font -- n )
+ [ 0 ] dip
+ [ bold?>> [ (bold) ] when ]
+ [ italic?>> [ (italic) ] when ] bi ;
+
+: apply-font-traits ( font style -- font' )
+ [ drop ] [ [ 0.0 f ] dip font-traits dup ] 2bi
+ CTFontCreateCopyWithSymbolicTraits
+ dup [ [ CFRelease ] dip ] [ drop ] if ;
+
+MEMO: (cache-font) ( font -- open-font )
+ [
+ [
+ [ name>> font-name &CFRelease ] [ size>> ] bi
+ f CTFontCreateWithName
+ ] keep apply-font-traits
+ ] with-destructors ;
+
+: cache-font ( font -- open-font )
+ strip-font-colors (cache-font) ;
+
+MEMO: (cache-font-metrics) ( font -- metrics )
+ [ metrics new ] dip
+ (cache-font) {
+ [ CTFontGetAscent >>ascent ]
+ [ CTFontGetDescent >>descent ]
+ [ CTFontGetLeading >>leading ]
+ [ CTFontGetCapHeight >>cap-height ]
+ [ CTFontGetXHeight >>x-height ]
+ } cleave
+ compute-height ;
+
+: cache-font-metrics ( font -- metrics )
+ strip-font-colors (cache-font-metrics) ;
+
+[
+ \ (cache-font) reset-memoized
+ \ (cache-font-metrics) reset-memoized
+] "core-text.fonts" add-init-hook
diff --git a/unmaintained/swap/tags.txt b/basis/core-text/fonts/tags.txt
similarity index 55%
rename from unmaintained/swap/tags.txt
rename to basis/core-text/fonts/tags.txt
index 6bf68304bb..2320bdd648 100644
--- a/unmaintained/swap/tags.txt
+++ b/basis/core-text/fonts/tags.txt
@@ -1 +1,2 @@
unportable
+bindings
diff --git a/basis/core-text/summary.txt b/basis/core-text/summary.txt
new file mode 100644
index 0000000000..f6baca134a
--- /dev/null
+++ b/basis/core-text/summary.txt
@@ -0,0 +1 @@
+Binding for Mac OS X Core Text library
diff --git a/basis/core-text/tags.txt b/basis/core-text/tags.txt
new file mode 100644
index 0000000000..2320bdd648
--- /dev/null
+++ b/basis/core-text/tags.txt
@@ -0,0 +1,2 @@
+unportable
+bindings
diff --git a/basis/core-text/utilities/authors.txt b/basis/core-text/utilities/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/core-text/utilities/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/core-text/utilities/utilities-tests.factor b/basis/core-text/utilities/utilities-tests.factor
new file mode 100644
index 0000000000..65914a3fcd
--- /dev/null
+++ b/basis/core-text/utilities/utilities-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test core-text.utilities ;
+IN: core-text.utilities.tests
diff --git a/basis/core-text/utilities/utilities.factor b/basis/core-text/utilities/utilities.factor
new file mode 100644
index 0000000000..8c085d40be
--- /dev/null
+++ b/basis/core-text/utilities/utilities.factor
@@ -0,0 +1,9 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: words parser alien alien.c-types kernel fry accessors ;
+IN: core-text.utilities
+
+: C-GLOBAL:
+ CREATE-WORD
+ dup name>> '[ _ f dlsym *void* ]
+ (( -- value )) define-declared ; parsing
diff --git a/basis/debugger/debugger.factor b/basis/debugger/debugger.factor
index 5f7431ecf3..45bc5bf50a 100644
--- a/basis/debugger/debugger.factor
+++ b/basis/debugger/debugger.factor
@@ -252,8 +252,8 @@ M: already-disposed summary drop "Attempting to operate on disposed object" ;
M: no-current-vocab summary
drop "Not in a vocabulary; IN: form required" ;
-M: no-word-error summary
- drop "Word not found in current vocabulary search path" ;
+M: no-word-error error.
+ "No word named ``" write name>> write "'' found in current vocabulary search path" print ;
M: staging-violation summary
drop
diff --git a/basis/definitions/icons/authors.txt b/basis/definitions/icons/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/definitions/icons/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/definitions/icons/class-predicate-word.tiff b/basis/definitions/icons/class-predicate-word.tiff
new file mode 100644
index 0000000000..f2a5df964d
Binary files /dev/null and b/basis/definitions/icons/class-predicate-word.tiff differ
diff --git a/basis/definitions/icons/class-word.tiff b/basis/definitions/icons/class-word.tiff
new file mode 100644
index 0000000000..16e94f70b8
Binary files /dev/null and b/basis/definitions/icons/class-word.tiff differ
diff --git a/basis/definitions/icons/constant-word.tiff b/basis/definitions/icons/constant-word.tiff
new file mode 100644
index 0000000000..69ee5fa6ac
Binary files /dev/null and b/basis/definitions/icons/constant-word.tiff differ
diff --git a/basis/definitions/icons/generic-word.tiff b/basis/definitions/icons/generic-word.tiff
new file mode 100644
index 0000000000..17741d05c6
Binary files /dev/null and b/basis/definitions/icons/generic-word.tiff differ
diff --git a/basis/definitions/icons/help-article.tiff b/basis/definitions/icons/help-article.tiff
new file mode 100644
index 0000000000..5fb3375520
Binary files /dev/null and b/basis/definitions/icons/help-article.tiff differ
diff --git a/basis/definitions/icons/icons-tests.factor b/basis/definitions/icons/icons-tests.factor
new file mode 100644
index 0000000000..47e106f8ec
--- /dev/null
+++ b/basis/definitions/icons/icons-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test definitions.icons ;
+IN: definitions.icons.tests
diff --git a/basis/definitions/icons/icons.factor b/basis/definitions/icons/icons.factor
new file mode 100644
index 0000000000..fb25ccf715
--- /dev/null
+++ b/basis/definitions/icons/icons.factor
@@ -0,0 +1,40 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: assocs classes.predicate fry generic io.pathnames kernel
+macros sequences vocabs words words.symbol words.constant
+lexer parser help.topics ;
+IN: definitions.icons
+
+GENERIC: definition-icon ( definition -- path )
+
+>
+
+ICON: predicate-class class-predicate-word
+ICON: generic generic-word
+ICON: macro macro-word
+ICON: parsing-word parsing-word
+ICON: primitive primitive-word
+ICON: symbol symbol-word
+ICON: constant constant-word
+ICON: word normal-word
+ICON: vocab-link unopen-vocab
+ICON: word-link word-help-article
+ICON: link help-article
+
+PRIVATE>
+
+M: vocab definition-icon
+ vocab-main "runnable-vocab" "open-vocab" ? definition-icon-path ;
+
\ No newline at end of file
diff --git a/basis/definitions/icons/macro-word.tiff b/basis/definitions/icons/macro-word.tiff
new file mode 100644
index 0000000000..040a243667
Binary files /dev/null and b/basis/definitions/icons/macro-word.tiff differ
diff --git a/basis/definitions/icons/normal-word.tiff b/basis/definitions/icons/normal-word.tiff
new file mode 100644
index 0000000000..ad837ebdb0
Binary files /dev/null and b/basis/definitions/icons/normal-word.tiff differ
diff --git a/basis/definitions/icons/open-vocab.tiff b/basis/definitions/icons/open-vocab.tiff
new file mode 100644
index 0000000000..e12a8e8880
Binary files /dev/null and b/basis/definitions/icons/open-vocab.tiff differ
diff --git a/basis/definitions/icons/parsing-word.tiff b/basis/definitions/icons/parsing-word.tiff
new file mode 100644
index 0000000000..220ad1bd19
Binary files /dev/null and b/basis/definitions/icons/parsing-word.tiff differ
diff --git a/basis/definitions/icons/primitive-word.tiff b/basis/definitions/icons/primitive-word.tiff
new file mode 100644
index 0000000000..ade51951d9
Binary files /dev/null and b/basis/definitions/icons/primitive-word.tiff differ
diff --git a/basis/definitions/icons/runnable-vocab.tiff b/basis/definitions/icons/runnable-vocab.tiff
new file mode 100644
index 0000000000..eef52e32d8
Binary files /dev/null and b/basis/definitions/icons/runnable-vocab.tiff differ
diff --git a/basis/definitions/icons/symbol-word.tiff b/basis/definitions/icons/symbol-word.tiff
new file mode 100644
index 0000000000..a00f84e2e4
Binary files /dev/null and b/basis/definitions/icons/symbol-word.tiff differ
diff --git a/basis/definitions/icons/unopen-vocab.tiff b/basis/definitions/icons/unopen-vocab.tiff
new file mode 100644
index 0000000000..892e64b83a
Binary files /dev/null and b/basis/definitions/icons/unopen-vocab.tiff differ
diff --git a/basis/definitions/icons/word-help-article.tiff b/basis/definitions/icons/word-help-article.tiff
new file mode 100644
index 0000000000..8ec1bf7c11
Binary files /dev/null and b/basis/definitions/icons/word-help-article.tiff differ
diff --git a/basis/delegate/delegate-docs.factor b/basis/delegate/delegate-docs.factor
index 5a2f4802e9..42b727852e 100644
--- a/basis/delegate/delegate-docs.factor
+++ b/basis/delegate/delegate-docs.factor
@@ -1,4 +1,4 @@
-USING: help.syntax help.markup ;
+USING: help.syntax help.markup delegate.private ;
IN: delegate
HELP: define-protocol
@@ -8,13 +8,13 @@ HELP: define-protocol
HELP: PROTOCOL:
{ $syntax "PROTOCOL: protocol-name words... ;" }
-{ $description "Defines an explicit protocol, which can be used as a basis for delegation or mimicry." } ;
+{ $description "Defines an explicit protocol, which can be used as a basis for delegation." } ;
{ define-protocol POSTPONE: PROTOCOL: } related-words
HELP: define-consult
-{ $values { "class" "a class" } { "group" "a protocol, generic word or tuple class" } { "quot" "a quotation" } }
-{ $description "Defines a class to consult, using the given quotation, on the generic words contained in the group." }
+{ $values { "consultation" consultation } }
+{ $description "Defines a class to consult, using the quotation, on the generic words contained in the group." }
{ $notes "Usually, " { $link POSTPONE: CONSULT: } " should be used instead. This is only for runtime use." } ;
HELP: CONSULT:
@@ -22,6 +22,12 @@ HELP: CONSULT:
{ $values { "group" "a protocol, generic word or tuple class" } { "class" "a class" } { "getter" "code to get where the method should be forwarded" } }
{ $description "Defines a class to consult, using the given code, on the generic words contained in the group. This means that, when one of the words in the group is called on an object of this class, the quotation will be called, and then the generic word called again. If the getter is empty, this will cause an infinite loop. Consultation overwrites the existing methods, but others can be defined afterwards." } ;
+HELP: SLOT-PROTOCOL:
+{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
+{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ;
+
+{ define-protocol POSTPONE: PROTOCOL: } related-words
+
{ define-consult POSTPONE: CONSULT: } related-words
HELP: group-words
@@ -40,6 +46,8 @@ $nl
"Defining new protocols:"
{ $subsection POSTPONE: PROTOCOL: }
{ $subsection define-protocol }
+"Defining new protocols consisting of slot accessors:"
+{ $subsection POSTPONE: SLOT-PROTOCOL: }
"Defining consultation:"
{ $subsection POSTPONE: CONSULT: }
{ $subsection define-consult }
diff --git a/basis/delegate/delegate-tests.factor b/basis/delegate/delegate-tests.factor
index 7d297af1ed..e2bea82e68 100644
--- a/basis/delegate/delegate-tests.factor
+++ b/basis/delegate/delegate-tests.factor
@@ -1,6 +1,7 @@
USING: delegate kernel arrays tools.test words math definitions
compiler.units parser generic prettyprint io.streams.string
-accessors eval ;
+accessors eval multiline generic.standard delegate.protocols
+delegate.private assocs ;
IN: delegate.tests
TUPLE: hello this that ;
@@ -35,10 +36,10 @@ M: hello bing hello-test ;
[ 3 ] [ 1 0 f 2 whoa ] unit-test
[ ] [ 3 [ "USING: accessors delegate ; IN: delegate.tests CONSULT: baz goodbye these>> ;" eval ] times ] unit-test
-[ H{ { goodbye [ these>> ] } } ] [ baz protocol-consult ] unit-test
+[ H{ { goodbye T{ consultation f baz goodbye [ these>> ] } } } ] [ baz protocol-consult ] unit-test
[ H{ } ] [ bee protocol-consult ] unit-test
-[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ;\n" ] [ [ baz see ] with-string-writer ] unit-test
+[ "USING: delegate ;\nIN: delegate.tests\nPROTOCOL: baz foo bar { whoa 1 } ; inline\n" ] [ [ baz see ] with-string-writer ] unit-test
GENERIC: one
M: integer one ;
@@ -91,3 +92,108 @@ CONSULT: slot-protocol-test-2 slot-protocol-test-3 d>> ;
T{ slot-protocol-test-3 f T{ slot-protocol-test-2 f "a" "b" 5 } }
[ a>> ] [ b>> ] [ c>> ] tri
] unit-test
+
+GENERIC: do-me ( x -- )
+
+M: f do-me drop ;
+
+[ ] [ f do-me ] unit-test
+
+TUPLE: a-tuple ;
+
+PROTOCOL: silly-protocol do-me ;
+
+! Replacing a method definition with a consultation would cause problems
+[ [ ] ] [
+ <" IN: delegate.tests
+ USE: kernel
+
+ M: a-tuple do-me drop ; "> "delegate-test" parse-stream
+] unit-test
+
+[ ] [ T{ a-tuple } do-me ] unit-test
+
+! Change method definition to consultation
+[ [ ] ] [
+ <" IN: delegate.tests
+ USE: kernel
+ USE: delegate
+ CONSULT: silly-protocol a-tuple drop f ; "> "delegate-test" parse-stream
+] unit-test
+
+! Method should be there
+[ ] [ T{ a-tuple } do-me ] unit-test
+
+! Now try removing the consulation
+[ [ ] ] [
+ <" IN: delegate.tests "> "delegate-test" parse-stream
+] unit-test
+
+! Method should be gone
+[ T{ a-tuple } do-me ] [ no-method? ] must-fail-with
+
+! A slot protocol issue
+DEFER: slot-protocol-test-3
+SLOT: y
+
+[ f ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
+
+[ [ ] ] [
+ <" IN: delegate.tests
+USING: accessors delegate ;
+TUPLE: slot-protocol-test-3 x ;
+CONSULT: y>> slot-protocol-test-3 x>> ;">
+ "delegate-test-1" parse-stream
+] unit-test
+
+[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
+
+[ [ ] ] [
+ <" IN: delegate.tests
+TUPLE: slot-protocol-test-3 x y ;">
+ "delegate-test-1" parse-stream
+] unit-test
+
+! We now have a real accessor for the y slot; we don't want it to
+! get lost
+[ t ] [ \ slot-protocol-test-3 \ y>> method >boolean ] unit-test
+
+! We want to be able to override methods after consultation
+[ [ ] ] [
+ <" IN: delegate.tests
+ USING: delegate kernel sequences delegate.protocols accessors ;
+ TUPLE: override-method-test seq ;
+ CONSULT: sequence-protocol override-method-test seq>> ;
+ M: override-method-test like drop ; ">
+ "delegate-test-2" parse-stream
+] unit-test
+
+DEFER: seq-delegate
+
+! See if removing a consultation updates protocol-consult word prop
+[ [ ] ] [
+ <" IN: delegate.tests
+ USING: accessors delegate delegate.protocols ;
+ TUPLE: seq-delegate seq ;
+ CONSULT: sequence-protocol seq-delegate seq>> ;">
+ "remove-consult-test" parse-stream
+] unit-test
+
+[ t ] [
+ seq-delegate
+ sequence-protocol \ protocol-consult word-prop
+ key?
+] unit-test
+
+[ [ ] ] [
+ <" IN: delegate.tests
+ USING: delegate delegate.protocols ;
+ TUPLE: seq-delegate seq ;">
+ "remove-consult-test" parse-stream
+] unit-test
+
+[ f ] [
+ seq-delegate
+ sequence-protocol \ protocol-consult word-prop
+ key?
+] unit-test
\ No newline at end of file
diff --git a/basis/delegate/delegate.factor b/basis/delegate/delegate.factor
index 4da2244114..0c16b7c336 100644
--- a/basis/delegate/delegate.factor
+++ b/basis/delegate/delegate.factor
@@ -1,11 +1,14 @@
! Copyright (C) 2007, 2008 Daniel Ehrenberg
+! Portions copyright (C) 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
-USING: accessors parser generic kernel classes classes.tuple
-words slots assocs sequences arrays vectors definitions
-math hashtables sets generalizations namespaces make
-words.symbol ;
+USING: accessors arrays assocs classes.tuple definitions generic
+generic.standard hashtables kernel lexer math parser
+generic.parser sequences sets slots words words.symbol fry
+compiler.units ;
IN: delegate
+> 2array 1array ;
+
M: tuple-class group-words
all-slots [
name>>
@@ -24,26 +30,74 @@ M: tuple-class group-words
! Consultation
-: consult-method ( word class quot -- )
- [ drop swap first create-method ]
- [ nip [ , dup second , \ ndip , first , ] [ ] make ] 3bi
+TUPLE: consultation group class quot loc ;
+
+: ( group class quot -- consultation )
+ f consultation boa ;
+
+: create-consult-method ( word consultation -- method )
+ [ class>> swap first create-method dup fake-definition ] keep
+ [ drop ] [ "consultation" set-word-prop ] 2bi ;
+
+PREDICATE: consult-method < method-body "consultation" word-prop ;
+
+M: consult-method reset-word
+ [ call-next-method ] [ f "consultation" set-word-prop ] bi ;
+
+: consult-method-quot ( quot word -- object )
+ [ second [ [ dip ] curry ] times ] [ first ] bi
+ '[ _ call _ execute ] ;
+
+: consult-method ( word consultation -- )
+ [ create-consult-method ]
+ [ quot>> swap consult-method-quot ] 2bi
define ;
: change-word-prop ( word prop quot -- )
- rot props>> swap change-at ; inline
+ [ swap props>> ] dip change-at ; inline
-: register-protocol ( group class quot -- )
- rot \ protocol-consult [ swapd ?set-at ] change-word-prop ;
+: each-generic ( consultation quot -- )
+ [ [ group>> group-words ] keep ] dip curry each ; inline
-: define-consult ( group class quot -- )
- [ register-protocol ]
- [ [ group-words ] 2dip [ consult-method ] 2curry each ]
- 3bi ;
+: register-consult ( consultation -- )
+ [ group>> \ protocol-consult ] [ ] [ class>> ] tri
+ '[ [ _ _ ] dip ?set-at ] change-word-prop ;
+
+: consult-methods ( consultation -- )
+ [ consult-method ] each-generic ;
+
+: unregister-consult ( consultation -- )
+ [ class>> ] [ group>> ] bi
+ \ protocol-consult word-prop delete-at ;
+
+: unconsult-method ( word consultation -- )
+ [ class>> swap first method ] keep
+ over [
+ over "consultation" word-prop eq?
+ [ forget ] [ drop ] if
+ ] [ 2drop ] if ;
+
+: unconsult-methods ( consultation -- )
+ [ unconsult-method ] each-generic ;
+
+PRIVATE>
+
+: define-consult ( consultation -- )
+ [ register-consult ] [ consult-methods ] bi ;
: CONSULT:
- scan-word scan-word parse-definition define-consult ; parsing
+ scan-word scan-word parse-definition
+ [ save-location ] [ define-consult ] bi ; parsing
+
+M: consultation where loc>> ;
+
+M: consultation set-where (>>loc) ;
+
+M: consultation forget*
+ [ unconsult-methods ] [ unregister-consult ] bi ;
! Protocols
+alist ] [ added-words ] 2bi
- [ swap first2 consult-method ] cross-2each ;
+ [ drop protocol-consult values ] [ added-words ] 2bi
+ [ swap consult-method ] cross-2each ;
: initialize-protocol-props ( protocol wordlist -- )
[
@@ -77,28 +131,35 @@ M: tuple-class group-words
: fill-in-depth ( wordlist -- wordlist' )
[ dup word? [ 0 2array ] when ] map ;
+: show-words ( wordlist' -- wordlist )
+ [ dup second zero? [ first ] when ] map ;
+
+PRIVATE>
+
: define-protocol ( protocol wordlist -- )
- fill-in-depth
- [ forget-old-definitions ]
- [ add-new-definitions ]
- [ initialize-protocol-props ] 2tri ;
+ [ drop define-symbol ] [
+ fill-in-depth
+ [ forget-old-definitions ]
+ [ add-new-definitions ]
+ [ initialize-protocol-props ] 2tri
+ ] 2bi ;
: PROTOCOL:
- CREATE-WORD
- [ define-symbol ]
- [ f "inline" set-word-prop ]
- [ parse-definition define-protocol ] tri ; parsing
+ CREATE-WORD parse-definition define-protocol ; parsing
PREDICATE: protocol < word protocol-words ; ! Subclass of symbol?
M: protocol forget*
[ f forget-old-definitions ] [ call-next-method ] bi ;
-: show-words ( wordlist' -- wordlist )
- [ dup second zero? [ first ] when ] map ;
M: protocol definition protocol-words show-words ;
M: protocol definer drop \ PROTOCOL: \ ; ;
M: protocol group-words protocol-words ;
+
+: SLOT-PROTOCOL:
+ CREATE-WORD ";" parse-tokens
+ [ [ reader-word ] [ writer-word ] bi 2array ] map concat
+ define-protocol ; parsing
\ No newline at end of file
diff --git a/basis/delegate/protocols/protocols.factor b/basis/delegate/protocols/protocols.factor
index edbec804c1..f568a3e388 100644
--- a/basis/delegate/protocols/protocols.factor
+++ b/basis/delegate/protocols/protocols.factor
@@ -1,27 +1,25 @@
! Copyright (C) 2007 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
USING: delegate sequences.private sequences assocs
-io io.styles definitions kernel continuations ;
+io definitions kernel continuations ;
IN: delegate.protocols
PROTOCOL: sequence-protocol
- clone clone-like like new-sequence new-resizable nth
- nth-unsafe set-nth set-nth-unsafe length set-length
- lengthen ;
+like new-sequence new-resizable nth nth-unsafe
+set-nth set-nth-unsafe length set-length
+lengthen ;
PROTOCOL: assoc-protocol
- at* assoc-size >alist set-at assoc-clone-like
- delete-at clear-assoc new-assoc assoc-like ;
+at* assoc-size >alist set-at assoc-clone-like
+delete-at clear-assoc new-assoc assoc-like ;
PROTOCOL: input-stream-protocol
- stream-read1 stream-read stream-read-partial stream-readln
- stream-read-until ;
+stream-read1 stream-read stream-read-partial stream-readln
+stream-read-until ;
PROTOCOL: output-stream-protocol
- stream-flush stream-write1 stream-write stream-format
- stream-nl make-span-stream make-block-stream
- make-cell-stream stream-write-table ;
+stream-flush stream-write1 stream-write stream-nl ;
PROTOCOL: definition-protocol
- where set-where forget uses
- synopsis* definer definition ;
+where set-where forget uses
+synopsis* definer definition ;
diff --git a/unmaintained/bitfields/tags.txt b/basis/delegate/tags.txt
similarity index 100%
rename from unmaintained/bitfields/tags.txt
rename to basis/delegate/tags.txt
diff --git a/basis/documents/documents-docs.factor b/basis/documents/documents-docs.factor
index 974645b284..a0b1eeb118 100644
--- a/basis/documents/documents-docs.factor
+++ b/basis/documents/documents-docs.factor
@@ -91,39 +91,8 @@ HELP: clear-doc
{ $description "Removes all text from the document." }
{ $side-effects "document" } ;
-HELP: prev-elt
-{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
-{ $contract "Outputs the location of the first occurrence of the element prior to " { $snippet "loc" } "." } ;
-
-{ prev-elt next-elt } related-words
-
-HELP: next-elt
-{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
-{ $contract "Outputs the location of the first occurrence of the element following " { $snippet "loc" } "." } ;
-
-HELP: char-elt
-{ $class-description "An element representing a single character." } ;
-
-HELP: one-word-elt
-{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the word at the current location." } ;
-
-{ one-word-elt word-elt } related-words
-
-HELP: word-elt
-{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next word from the current location." } ;
-
-HELP: one-line-elt
-{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the line at the current location." } ;
-
-{ one-line-elt line-elt } related-words
-
-HELP: line-elt
-{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next line from the current location." } ;
-
-HELP: doc-elt
-{ $class-description "An element representing the entire document. The " { $link prev-elt } " word outputs the start of the document and the " { $link next-elt } " word outputs the end of the document." } ;
-
ARTICLE: "documents" "Documents"
+"The " { $vocab-link "documents" } " vocabulary implements " { $emphasis "documents" } ", which are models storing a passage of text as a sequence of lines. Operations are defined for operating on subranges of the text, and " { $link "ui.gadgets.editors" } " can display these models."
{ $subsection document }
{ $subsection }
"Getting and setting the contents of the entire document:"
@@ -138,24 +107,18 @@ ARTICLE: "documents" "Documents"
{ $subsection remove-doc-range }
"A combinator:"
{ $subsection each-line }
-{ $see-also "gadgets-editors" } ;
+{ $subsection "document-locs" }
+{ $subsection "documents.elements" }
+{ $see-also "ui.gadgets.editors" } ;
-ARTICLE: "document-locs-elts" "Locations and elements"
+ARTICLE: "document-locs" "Document locations"
"Locations in the document are represented as a line/column number pair, with both indices being zero-based. There are some words for manipulating locations:"
{ $subsection +col }
{ $subsection +line }
{ $subsection =col }
{ $subsection =line }
-"New locations can be created out of existing ones by finding the start or end of a document element nearest to a given location."
-{ $subsection prev-elt }
-{ $subsection next-elt }
-"The different types of document elements correspond to the standard editing taxonomy:"
-{ $subsection char-elt }
-{ $subsection one-word-elt }
-{ $subsection word-elt }
-{ $subsection one-line-elt }
-{ $subsection line-elt }
-{ $subsection doc-elt }
"Miscellaneous words for working with locations:"
{ $subsection lines-equal? }
{ $subsection validate-loc } ;
+
+ABOUT: "documents"
diff --git a/basis/documents/documents-tests.factor b/basis/documents/documents-tests.factor
index 88e471cce1..b0ff3bc8d8 100644
--- a/basis/documents/documents-tests.factor
+++ b/basis/documents/documents-tests.factor
@@ -1,5 +1,6 @@
IN: documents.tests
-USING: documents namespaces tools.test make arrays kernel fry ;
+USING: documents documents.private accessors sequences
+namespaces tools.test make arrays kernel fry ;
! Tests
@@ -88,19 +89,65 @@ USING: documents namespaces tools.test make arrays kernel fry ;
"doc" get doc-string
] unit-test
- "doc" set
-"Hello world" "doc" get set-doc-string
-[ { 0 0 } ] [ { 0 0 } "doc" get T{ one-word-elt } prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 2 } "doc" get T{ one-word-elt } prev-elt ] unit-test
-[ { 0 0 } ] [ { 0 5 } "doc" get T{ one-word-elt } prev-elt ] unit-test
-[ { 0 5 } ] [ { 0 2 } "doc" get T{ one-word-elt } next-elt ] unit-test
-[ { 0 5 } ] [ { 0 5 } "doc" get T{ one-word-elt } next-elt ] unit-test
-
"doc" set
"Hello\nworld, how are\nyou?" "doc" get set-doc-string
[ { 2 4 } ] [ "doc" get doc-end ] unit-test
-[ { 0 0 } ] [ { 0 3 } "doc" get T{ line-elt } prev-elt ] unit-test
-[ { 0 3 } ] [ { 1 3 } "doc" get T{ line-elt } prev-elt ] unit-test
-[ { 2 4 } ] [ { 2 1 } "doc" get T{ line-elt } next-elt ] unit-test
+! Undo/redo
+[ ] [ "d" set ] unit-test
+
+[ ] [ "Hello, world." "d" get set-doc-string ] unit-test
+
+[
+ T{ edit
+ { old-string "" }
+ { new-string "Hello, world." }
+ { from { 0 0 } }
+ { old-to { 0 0 } }
+ { new-to { 0 13 } }
+ }
+] [ "d" get undos>> first ] unit-test
+
+[ ] [ "Goodbye" { 0 0 } { 0 5 } "d" get set-doc-range ] unit-test
+
+[ "Goodbye, world." ] [ "d" get doc-string ] unit-test
+
+[ ] [ "cruel " { 0 9 } { 0 9 } "d" get set-doc-range ] unit-test
+
+[ 3 ] [ "d" get undos>> length ] unit-test
+
+[ "Goodbye, cruel world." ] [ "d" get doc-string ] unit-test
+
+[ "" { 0 9 } { 0 15 } ] [
+ "d" get undos>> peek
+ [ old-string>> ] [ from>> ] [ new-to>> ] tri
+] unit-test
+
+[ ] [ "d" get undo ] unit-test
+
+[ "Goodbye, world." ] [ "d" get doc-string ] unit-test
+
+[ ] [ "d" get undo ] unit-test
+
+[ "Hello, world." ] [ "d" get doc-string ] unit-test
+
+[ ] [ "d" get redo ] unit-test
+
+[ "Goodbye, world." ] [ "d" get doc-string ] unit-test
+
+[ ] [ "d" set ] unit-test
+
+[ ] [ "d" get clear-doc ] unit-test
+
+[ ] [ "d" get clear-doc ] unit-test
+
+[ 0 ] [ "d" get undos>> length ] unit-test
+
+[ ] [ "d" set ] unit-test
+
+[ ] [ "d" get value>> "value" set ] unit-test
+
+[ ] [ "Hello world" "d" get set-doc-string ] unit-test
+
+[ { "" } ] [ "value" get ] unit-test
\ No newline at end of file
diff --git a/basis/documents/documents.factor b/basis/documents/documents.factor
index 29f865cf3c..451c912779 100644
--- a/basis/documents/documents.factor
+++ b/basis/documents/documents.factor
@@ -1,8 +1,8 @@
-! Copyright (C) 2006, 2008 Slava Pestov
+! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays io kernel math models namespaces make
sequences strings splitting combinators unicode.categories
-math.order math.ranges ;
+math.order math.ranges fry locals ;
IN: documents
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
@@ -15,11 +15,21 @@ IN: documents
: lines-equal? ( loc1 loc2 -- ? ) [ first ] bi@ number= ;
-TUPLE: document < model locs ;
+TUPLE: edit old-string new-string from old-to new-to ;
+
+C: edit
+
+TUPLE: document < model locs undos redos inside-undo? ;
+
+: clear-undo ( document -- )
+ V{ } clone >>undos
+ V{ } clone >>redos
+ drop ;
: ( -- document )
- V{ "" } clone document new-model
- V{ } clone >>locs ;
+ { "" } document new-model
+ V{ } clone >>locs
+ dup clear-undo ;
: add-loc ( loc document -- ) locs>> push ;
@@ -30,41 +40,43 @@ TUPLE: document < model locs ;
: doc-line ( n document -- string ) value>> nth ;
+: line-end ( line# document -- loc )
+ [ drop ] [ doc-line length ] 2bi 2array ;
+
: doc-lines ( from to document -- slice )
- [ 1+ ] dip value>> ;
+ [ 1+ ] [ value>> ] bi* ;
-: start-on-line ( document from line# -- n1 )
- [ dup first ] dip = [ nip second ] [ 2drop 0 ] if ;
+: start-on-line ( from line# document -- n1 )
+ drop over first =
+ [ second ] [ drop 0 ] if ;
-: end-on-line ( document to line# -- n2 )
- over first over = [
- drop second nip
- ] [
- nip swap doc-line length
- ] if ;
+:: end-on-line ( to line# document -- n2 )
+ to first line# =
+ [ to second ] [ line# document doc-line length ] if ;
: each-line ( from to quot -- )
- 2over = [
- 3drop
- ] [
+ 2over = [ 3drop ] [
[ [ first ] bi@ [a,b] ] dip each
] if ; inline
-: start/end-on-line ( from to line# -- n1 n2 )
- tuck
- [ [ document get ] 2dip start-on-line ]
- [ [ document get ] 2dip end-on-line ]
- 2bi* ;
+: map-lines ( from to quot -- results )
+ accumulator [ each-line ] dip ; inline
-: (doc-range) ( from to line# -- )
- [ start/end-on-line ] keep document get doc-line , ;
+: start/end-on-line ( from to line# document -- n1 n2 )
+ [ start-on-line ] [ end-on-line ] bi-curry bi-curry bi* ;
-: doc-range ( from to document -- string )
- [
- document set 2dup [
- [ 2dup ] dip (doc-range)
- ] each-line 2drop
- ] { } make "\n" join ;
+: last-line# ( document -- line )
+ value>> length 1- ;
+
+CONSTANT: doc-start { 0 0 }
+
+: doc-end ( document -- loc )
+ [ last-line# ] keep line-end ;
+
+ ;
: text+loc ( lines loc -- loc )
over [
@@ -84,158 +96,98 @@ TUPLE: document < model locs ;
: loc-col/str ( loc document -- str col )
[ first2 swap ] dip nth swap ;
-: prepare-insert ( newinput from to lines -- newinput )
- tuck [ loc-col/str head-slice ] [ loc-col/str tail-slice ] 2bi*
+: prepare-insert ( new-lines from to lines -- new-lines )
+ [ loc-col/str head-slice ] [ loc-col/str tail-slice ] bi-curry bi*
pick append-last over prepend-first ;
-: (set-doc-range) ( newlines from to lines -- )
+: (set-doc-range) ( doc-lines from to lines -- changed-lines )
[ prepare-insert ] 3keep
[ [ first ] bi@ 1+ ] dip
replace-slice ;
-: set-doc-range ( string from to document -- )
- [
- [ [ string-lines ] dip [ text+loc ] 2keep ] 2dip
- [ [ (set-doc-range) ] keep ] change-model
- ] keep update-locs ;
+: entire-doc ( document -- start end document )
+ [ [ doc-start ] dip doc-end ] keep ;
+
+: with-undo ( document quot: ( document -- ) -- )
+ [ t >>inside-undo? ] dip keep f >>inside-undo? drop ; inline
+
+PRIVATE>
+
+: doc-range ( from to document -- string )
+ [ 2dup ] dip
+ '[ [ 2dup ] dip _ (doc-range) ] map-lines
+ 2nip "\n" join ;
+
+: add-undo ( edit document -- )
+ dup inside-undo?>> [ 2drop ] [
+ [ undos>> push ] keep
+ redos>> delete-all
+ ] if ;
+
+:: set-doc-range ( string from to document -- )
+ from to = string empty? and [
+ string string-lines :> new-lines
+ new-lines from text+loc :> new-to
+ from to document doc-range :> old-string
+ old-string string from to new-to document add-undo
+ new-lines from to document [ (set-doc-range) ] change-model
+ new-to document update-locs
+ ] unless ;
+
+: change-doc-range ( from to document quot -- )
+ '[ doc-range @ ] 3keep set-doc-range ; inline
: remove-doc-range ( from to document -- )
[ "" ] 3dip set-doc-range ;
-: last-line# ( document -- line )
- value>> length 1- ;
-
: validate-line ( line document -- line )
last-line# min 0 max ;
: validate-col ( col line document -- col )
doc-line length min 0 max ;
-: line-end ( line# document -- loc )
- dupd doc-line length 2array ;
-
: line-end? ( loc document -- ? )
[ first2 swap ] dip doc-line length = ;
-: doc-end ( document -- loc )
- [ last-line# ] keep line-end ;
-
: validate-loc ( loc document -- newloc )
- over first over value>> length >= [
+ 2dup [ first ] [ value>> length ] bi* >= [
nip doc-end
] [
over first 0 < [
2drop { 0 0 }
] [
- [ first2 swap tuck ] dip validate-col 2array
+ [ first2 over ] dip validate-col 2array
] if
] if ;
: doc-string ( document -- str )
- value>> "\n" join ;
+ entire-doc doc-range ;
: set-doc-string ( string document -- )
- [ string-lines V{ } like ] dip [ set-model ] keep
- [ doc-end ] [ update-locs ] bi ;
+ entire-doc set-doc-range ;
: clear-doc ( document -- )
- "" swap set-doc-string ;
+ [ "" ] dip set-doc-string ;
-GENERIC: prev-elt ( loc document elt -- newloc )
-GENERIC: next-elt ( loc document elt -- newloc )
+> ] _ tri ] dip set-doc-range ] with-undo ; inline
-: elt-string ( loc document elt -- string )
- [ prev/next-elt ] [ drop ] 2bi doc-range ;
+: undo-edit ( edit document -- )
+ [ old-string>> ] [ new-to>> ] undo/redo-edit ;
-TUPLE: char-elt ;
+: redo-edit ( edit document -- )
+ [ new-string>> ] [ old-to>> ] undo/redo-edit ;
-: (prev-char) ( loc document quot -- loc )
- {
- { [ pick { 0 0 } = ] [ 2drop ] }
- { [ pick second zero? ] [ drop [ first 1- ] dip line-end ] }
- [ call ]
- } cond ; inline
+: undo/redo ( document source-quot dest-quot do-quot -- )
+ [ dupd call [ drop ] ] 2dip
+ '[ pop swap [ @ push ] _ 2bi ] if-empty ; inline
-: (next-char) ( loc document quot -- loc )
- {
- { [ 2over doc-end = ] [ 2drop ] }
- { [ 2over line-end? ] [ 2drop first 1+ 0 2array ] }
- [ call ]
- } cond ; inline
+PRIVATE>
-M: char-elt prev-elt
- drop [ drop -1 +col ] (prev-char) ;
+: undo ( document -- )
+ [ undos>> ] [ redos>> ] [ undo-edit ] undo/redo ;
-M: char-elt next-elt
- drop [ drop 1 +col ] (next-char) ;
-
-TUPLE: one-char-elt ;
-
-M: one-char-elt prev-elt 2drop ;
-
-M: one-char-elt next-elt 2drop ;
-
-: (word-elt) ( loc document quot -- loc )
- pick [
- [ [ first2 swap ] dip doc-line ] dip call
- ] dip =col ; inline
-
-: ((word-elt)) ( n seq -- ? n seq ) [ ?nth blank? ] 2keep ;
-
-: break-detector ( ? -- quot )
- [ [ blank? ] dip xor ] curry ; inline
-
-: (prev-word) ( ? col str -- col )
- rot break-detector find-last-from drop ?1+ ;
-
-: (next-word) ( ? col str -- col )
- [ rot break-detector find-from drop ] keep
- over not [ nip length ] [ drop ] if ;
-
-TUPLE: one-word-elt ;
-
-M: one-word-elt prev-elt
- drop
- [ [ [ f ] dip 1- ] dip (prev-word) ] (word-elt) ;
-
-M: one-word-elt next-elt
- drop
- [ [ f ] 2dip (next-word) ] (word-elt) ;
-
-TUPLE: word-elt ;
-
-M: word-elt prev-elt
- drop
- [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
- (prev-char) ;
-
-M: word-elt next-elt
- drop
- [ [ ((word-elt)) (next-word) ] (word-elt) ]
- (next-char) ;
-
-TUPLE: one-line-elt ;
-
-M: one-line-elt prev-elt
- 2drop first 0 2array ;
-
-M: one-line-elt next-elt
- drop [ first dup ] dip doc-line length 2array ;
-
-TUPLE: line-elt ;
-
-M: line-elt prev-elt
- 2drop dup first zero? [ drop { 0 0 } ] [ -1 +line ] if ;
-
-M: line-elt next-elt
- drop over first over last-line# number=
- [ nip doc-end ] [ drop 1 +line ] if ;
-
-TUPLE: doc-elt ;
-
-M: doc-elt prev-elt 3drop { 0 0 } ;
-
-M: doc-elt next-elt drop nip doc-end ;
+: redo ( document -- )
+ [ redos>> ] [ undos>> ] [ redo-edit ] undo/redo ;
\ No newline at end of file
diff --git a/basis/documents/elements/authors.txt b/basis/documents/elements/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/documents/elements/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/documents/elements/elements-docs.factor b/basis/documents/elements/elements-docs.factor
new file mode 100644
index 0000000000..935f927c30
--- /dev/null
+++ b/basis/documents/elements/elements-docs.factor
@@ -0,0 +1,50 @@
+USING: help.markup help.syntax documents ;
+IN: documents.elements
+
+HELP: prev-elt
+{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
+{ $contract "Outputs the location of the first occurrence of the element prior to " { $snippet "loc" } "." } ;
+
+{ prev-elt next-elt } related-words
+
+HELP: next-elt
+{ $values { "loc" "a pair of integers" } { "document" document } { "elt" "an element" } { "newloc" "a pair of integers" } }
+{ $contract "Outputs the location of the first occurrence of the element following " { $snippet "loc" } "." } ;
+
+HELP: char-elt
+{ $class-description "An element representing a single character." } ;
+
+HELP: one-word-elt
+{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the word at the current location." } ;
+
+{ one-word-elt word-elt } related-words
+
+HELP: word-elt
+{ $class-description "An element representing a single word. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next word from the current location." } ;
+
+HELP: one-line-elt
+{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the beginning and the end of the line at the current location." } ;
+
+{ one-line-elt line-elt } related-words
+
+HELP: line-elt
+{ $class-description "An element representing a single line. The " { $link prev-elt } " and " { $link next-elt } " words return the location of the previous and next line from the current location." } ;
+
+HELP: doc-elt
+{ $class-description "An element representing the entire document. The " { $link prev-elt } " word outputs the start of the document and the " { $link next-elt } " word outputs the end of the document." } ;
+
+ARTICLE: "documents.elements" "Document elements"
+"Document elements, defined in the " { $vocab-link "documents.elements" } " vocabulary, overlay a hierarchy of structure on top of the flat sequence of characters presented by the document."
+$nl
+"The different types of document elements correspond to the standard editing taxonomy:"
+{ $subsection char-elt }
+{ $subsection one-word-elt }
+{ $subsection word-elt }
+{ $subsection one-line-elt }
+{ $subsection line-elt }
+{ $subsection doc-elt }
+"New locations can be created out of existing ones by finding the start or end of a document element nearest to a given location."
+{ $subsection prev-elt }
+{ $subsection next-elt } ;
+
+ABOUT: "documents.elements"
\ No newline at end of file
diff --git a/basis/documents/elements/elements-tests.factor b/basis/documents/elements/elements-tests.factor
new file mode 100644
index 0000000000..a3f05d7a71
--- /dev/null
+++ b/basis/documents/elements/elements-tests.factor
@@ -0,0 +1,70 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test namespaces documents documents.elements multiline ;
+IN: document.elements.tests
+
+ "doc" set
+"123\nabc" "doc" get set-doc-string
+
+! char-elt
+[ { 0 0 } ] [ { 0 0 } "doc" get char-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 1 } "doc" get char-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 0 } "doc" get char-elt prev-elt ] unit-test
+
+[ { 1 3 } ] [ { 1 3 } "doc" get char-elt next-elt ] unit-test
+[ { 0 2 } ] [ { 0 1 } "doc" get char-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 0 3 } "doc" get char-elt next-elt ] unit-test
+
+! word-elt
+ "doc" set
+"Hello world\nanother line" "doc" get set-doc-string
+
+[ { 0 0 } ] [ { 0 0 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 6 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 6 } ] [ { 0 8 } "doc" get word-elt prev-elt ] unit-test
+[ { 0 11 } ] [ { 1 0 } "doc" get word-elt prev-elt ] unit-test
+
+[ { 0 5 } ] [ { 0 0 } "doc" get word-elt next-elt ] unit-test
+[ { 0 6 } ] [ { 0 5 } "doc" get word-elt next-elt ] unit-test
+[ { 0 11 } ] [ { 0 6 } "doc" get word-elt next-elt ] unit-test
+[ { 1 0 } ] [ { 0 11 } "doc" get word-elt next-elt ] unit-test
+
+! one-word-elt
+[ { 0 0 } ] [ { 0 0 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 2 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 0 } ] [ { 0 5 } "doc" get one-word-elt prev-elt ] unit-test
+[ { 0 5 } ] [ { 0 2 } "doc" get one-word-elt next-elt ] unit-test
+[ { 0 5 } ] [ { 0 5 } "doc" get one-word-elt next-elt ] unit-test
+
+! line-elt
+ "doc" set
+"Hello\nworld, how are\nyou?" "doc" get set-doc-string
+
+[ { 0 0 } ] [ { 0 3 } "doc" get line-elt prev-elt ] unit-test
+[ { 0 3 } ] [ { 1 3 } "doc" get line-elt prev-elt ] unit-test
+[ { 2 4 } ] [ { 2 1 } "doc" get line-elt next-elt ] unit-test
+
+! one-line-elt
+[ { 1 0 } ] [ { 1 3 } "doc" get one-line-elt prev-elt ] unit-test
+[ { 1 14 } ] [ { 1 3 } "doc" get one-line-elt next-elt ] unit-test
+
+! page-elt
+ "doc" set
+<" First line
+Second line
+Third line
+Fourth line
+Fifth line
+Sixth line"> "doc" get set-doc-string
+
+[ { 0 0 } ] [ { 3 3 } "doc" get 4 prev-elt ] unit-test
+[ { 1 2 } ] [ { 5 2 } "doc" get 4 prev-elt ] unit-test
+
+[ { 4 3 } ] [ { 0 3 } "doc" get 4 next-elt ] unit-test
+[ { 5 10 } ] [ { 4 2 } "doc" get 4 next-elt ] unit-test
+
+! doc-elt
+[ { 0 0 } ] [ { 3 4 } "doc" get doc-elt prev-elt ] unit-test
+[ { 5 10 } ] [ { 3 4 } "doc" get doc-elt next-elt ] unit-test
\ No newline at end of file
diff --git a/basis/documents/elements/elements.factor b/basis/documents/elements/elements.factor
new file mode 100644
index 0000000000..adb498df13
--- /dev/null
+++ b/basis/documents/elements/elements.factor
@@ -0,0 +1,121 @@
+! Copyright (C) 2006, 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: arrays combinators documents fry kernel math sequences
+unicode.categories accessors ;
+IN: documents.elements
+
+GENERIC: prev-elt ( loc document elt -- newloc )
+GENERIC: next-elt ( loc document elt -- newloc )
+
+: prev/next-elt ( loc document elt -- start end )
+ [ prev-elt ] [ next-elt ] 3bi ;
+
+: elt-string ( loc document elt -- string )
+ [ prev/next-elt ] [ drop ] 2bi doc-range ;
+
+: set-elt-string ( string loc document elt -- )
+ [ prev/next-elt ] [ drop ] 2bi set-doc-range ;
+
+SINGLETON: char-elt
+
+
+
+M: char-elt prev-elt
+ drop [ drop -1 +col ] (prev-char) ;
+
+M: char-elt next-elt
+ drop [ drop 1 +col ] (next-char) ;
+
+SINGLETON: one-char-elt
+
+M: one-char-elt prev-elt 2drop ;
+
+M: one-char-elt next-elt 2drop ;
+
+
+
+SINGLETON: one-word-elt
+
+M: one-word-elt prev-elt
+ drop
+ [ [ 1- ] dip f (prev-word) ] (word-elt) ;
+
+M: one-word-elt next-elt
+ drop
+ [ f (next-word) ] (word-elt) ;
+
+SINGLETON: word-elt
+
+M: word-elt prev-elt
+ drop
+ [ [ [ 1- ] dip ((word-elt)) (prev-word) ] (word-elt) ]
+ (prev-char) ;
+
+M: word-elt next-elt
+ drop
+ [ [ ((word-elt)) (next-word) ] (word-elt) ]
+ (next-char) ;
+
+SINGLETON: one-line-elt
+
+M: one-line-elt prev-elt
+ 2drop first 0 2array ;
+
+M: one-line-elt next-elt
+ drop [ first dup ] dip doc-line length 2array ;
+
+TUPLE: page-elt { lines read-only } ;
+
+C: page-elt
+
+M: page-elt prev-elt
+ nip
+ 2dup [ first ] [ lines>> ] bi* <
+ [ 2drop { 0 0 } ] [ lines>> neg +line ] if ;
+
+M: page-elt next-elt
+ 3dup [ first ] [ last-line# ] [ lines>> ] tri* - >
+ [ drop nip doc-end ] [ nip lines>> +line ] if ;
+
+CONSTANT: line-elt T{ page-elt f 1 }
+
+SINGLETON: doc-elt
+
+M: doc-elt prev-elt 3drop { 0 0 } ;
+
+M: doc-elt next-elt drop nip doc-end ;
\ No newline at end of file
diff --git a/basis/farkup/farkup-tests.factor b/basis/farkup/farkup-tests.factor
index 60a9f785e6..246da48b32 100644
--- a/basis/farkup/farkup-tests.factor
+++ b/basis/farkup/farkup-tests.factor
@@ -99,6 +99,7 @@ link-no-follow? off
[ "
" ] [ "[[image:lol.jpg|teh lol]]" convert-farkup ] unit-test
[ "http://lol.com
" ] [ "[[http://lol.com]]" convert-farkup ] unit-test
[ "haha
" ] [ "[[http://lol.com|haha]]" convert-farkup ] unit-test
+[ "haha
" ] [ "[[http://lol.com/search?q=sex|haha]]" convert-farkup ] unit-test
[ "Bar
" ] [ "[[Foo/Bar]]" convert-farkup ] unit-test
"/wiki/view/" relative-link-prefix [
diff --git a/basis/farkup/farkup.factor b/basis/farkup/farkup.factor
index 50ee938659..4041d92773 100755
--- a/basis/farkup/farkup.factor
+++ b/basis/farkup/farkup.factor
@@ -165,12 +165,12 @@ CONSTANT: invalid-url "javascript:alert('Invalid URL in farkup');"
{ [ dup [ 127 > ] any? ] [ drop invalid-url ] }
{ [ dup first "/\\" member? ] [ drop invalid-url ] }
{ [ CHAR: : over member? ] [ dup absolute-url? [ drop invalid-url ] unless ] }
- [ relative-link-prefix get prepend "" like ]
- } cond url-encode ;
+ [ relative-link-prefix get prepend "" like url-encode ]
+ } cond ;
: write-link ( href text -- xml )
- [ check-url link-no-follow? get "true" and ] dip
- [XML nofollow=<->><-> XML] ;
+ [ check-url link-no-follow? get "nofollow" and ] dip
+ [XML rel=<->><-> XML] ;
: write-image-link ( href text -- xml )
disable-images? get [
diff --git a/basis/fonts/authors.txt b/basis/fonts/authors.txt
new file mode 100644
index 0000000000..d4f5d6b3ae
--- /dev/null
+++ b/basis/fonts/authors.txt
@@ -0,0 +1 @@
+Slava Pestov
\ No newline at end of file
diff --git a/basis/fonts/fonts-docs.factor b/basis/fonts/fonts-docs.factor
new file mode 100644
index 0000000000..c529efc100
--- /dev/null
+++ b/basis/fonts/fonts-docs.factor
@@ -0,0 +1,41 @@
+! Copyright (C) 2009 Slava Pestov
+! See http://factorcode.org/license.txt for BSD license.
+USING: help.markup help.syntax kernel colors ;
+IN: fonts
+
+HELP:
+{ $values { "font" font } }
+{ $description "Creates a new font." } ;
+
+HELP: font
+{ $class-description "The class of fonts." } ;
+
+HELP: font-with-background
+{ $values
+ { "font" font } { "color" color }
+ { "font'" font }
+}
+{ $description "Creates a new font equal to the given font, except with a different " { $slot "background" } " slot." } ;
+
+HELP: font-with-foreground
+{ $values
+ { "font" font } { "color" color }
+ { "font'" font }
+}
+{ $description "Creates a new font equal to the given font, except with a different " { $slot "foreground" } " slot." } ;
+
+ARTICLE: "fonts" "Fonts"
+"The " { $vocab-link "fonts" } " vocabulary implements a data type for fonts that other vocabularies, for example " { $link "ui" } ", can use. A font combines a font name, size, style, and color information into a single object."
+{ $subsection font }
+{ $subsection }
+"Modifying fonts:"
+{ $subsection font-with-foreground }
+{ $subsection font-with-background }
+"Useful constants:"
+{ $subsection monospace-font }
+{ $subsection sans-serif-font }
+{ $subsection serif-font }
+"A data type for font metrics. The " { $vocab-link "fonts" } " vocabulary does not provide any means of computing font metrics, it simply defines a common data type that other vocabularies, such as " { $vocab-link "ui.text" } " may use:"
+{ $subsection metrics } ;
+
+ABOUT: "fonts"
diff --git a/basis/fonts/fonts-tests.factor b/basis/fonts/fonts-tests.factor
new file mode 100644
index 0000000000..25856e0cd8
--- /dev/null
+++ b/basis/fonts/fonts-tests.factor
@@ -0,0 +1,4 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: tools.test fonts ;
+IN: fonts.tests
diff --git a/basis/fonts/fonts.factor b/basis/fonts/fonts.factor
new file mode 100644
index 0000000000..fb89bdbfb0
--- /dev/null
+++ b/basis/fonts/fonts.factor
@@ -0,0 +1,68 @@
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: kernel colors colors.constants accessors combinators math ;
+IN: fonts
+
+TUPLE: font
+name
+size
+bold?
+italic?
+{ foreground initial: COLOR: black }
+{ background initial: COLOR: white } ;
+
+: ( -- font )
+ font new ; inline
+
+: font-with-foreground ( font color -- font' )
+ [ clone ] dip >>foreground ; inline
+
+: font-with-background ( font color -- font' )
+ [ clone ] dip >>background ; inline
+
+: font-with-size ( font size -- font' )
+ [ clone ] dip >>size ; inline
+
+: reverse-video-font ( font -- font )
+ clone dup
+ [ foreground>> ] [ background>> ] bi
+ [ >>background ] [ >>foreground ] bi* ;
+
+: derive-font ( base font -- font' )
+ [
+ [ clone ] dip over {
+ [ [ name>> ] either? >>name ]
+ [ [ size>> ] either? >>size ]
+ [ [ bold?>> ] either? >>bold? ]
+ [ [ italic?>> ] either? >>italic? ]
+ [ [ foreground>> ] either? >>foreground ]
+ [ [ background>> ] either? >>background ]
+ } 2cleave
+ ] when* ;
+
+: serif-font ( -- font )
+
+ "serif" >>name
+ 12 >>size ;
+
+: sans-serif-font ( -- font )
+
+ "sans-serif" >>name
+ 12 >>size ;
+
+: monospace-font ( -- font )
+
+ "monospace" >>name
+ 12 >>size ;
+
+: strip-font-colors ( font -- font' )
+ clone f >>background f >>foreground ;
+
+TUPLE: metrics width ascent descent height leading cap-height x-height ;
+
+: compute-height ( metrics -- metrics )
+ dup [ ascent>> ] [ descent>> ] bi + >>height ; inline
+
+TUPLE: selection string start end color ;
+
+C: selection
\ No newline at end of file
diff --git a/basis/fonts/summary.txt b/basis/fonts/summary.txt
new file mode 100644
index 0000000000..c2cf825a1a
--- /dev/null
+++ b/basis/fonts/summary.txt
@@ -0,0 +1 @@
+Fonts as a first-class data type
diff --git a/basis/fry/fry.factor b/basis/fry/fry.factor
index e62a42749f..9ffad43cf4 100644
--- a/basis/fry/fry.factor
+++ b/basis/fry/fry.factor
@@ -53,4 +53,4 @@ M: callable deep-fry
M: object deep-fry , ;
-: '[ \ ] parse-until fry over push-all ; parsing
+: '[ parse-quotation fry over push-all ; parsing
diff --git a/basis/functors/functors.factor b/basis/functors/functors.factor
index 0b9c9caa45..6592a3c4f2 100644
--- a/basis/functors/functors.factor
+++ b/basis/functors/functors.factor
@@ -122,20 +122,13 @@ DEFER: ;FUNCTOR delimiter
functor-words use get delq ;
: parse-functor-body ( -- form )
- t in-lambda? [
- V{ } clone
- push-functor-words
- "WHERE" parse-bindings* \ ;FUNCTOR (parse-lambda)
- parsed-lambda
- pop-functor-words
- >quotation
- ] with-variable ;
+ push-functor-words
+ "WHERE" parse-bindings*
+ [ \ ;FUNCTOR parse-until >quotation ] ((parse-lambda)) 1quotation
+ pop-functor-words ;
: (FUNCTOR:) ( -- word def )
- CREATE
- parse-locals dup push-locals
- parse-functor-body swap pop-locals
- rewrite-closures first ;
+ CREATE-WORD [ parse-functor-body ] parse-locals-definition ;
PRIVATE>
diff --git a/basis/generalizations/generalizations.factor b/basis/generalizations/generalizations.factor
index 9b2b2456c2..0aa042d4f2 100644
--- a/basis/generalizations/generalizations.factor
+++ b/basis/generalizations/generalizations.factor
@@ -2,7 +2,7 @@
! Cavazos, Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private math combinators
-macros quotations fry ;
+macros quotations fry effects ;
IN: generalizations
<<
@@ -94,4 +94,4 @@ MACRO: nweave ( n -- )
: nappend-as ( n exemplar -- seq )
[ narray concat ] dip like ; inline
-: nappend ( n -- seq ) narray concat ; inline
+: nappend ( n -- seq ) narray concat ; inline
\ No newline at end of file
diff --git a/basis/glib/authors.txt b/basis/glib/authors.txt
new file mode 100644
index 0000000000..367ba74d80
--- /dev/null
+++ b/basis/glib/authors.txt
@@ -0,0 +1,2 @@
+Matthew Willis
+Slava Pestov
diff --git a/basis/glib/glib.factor b/basis/glib/glib.factor
new file mode 100755
index 0000000000..1805f4bff9
--- /dev/null
+++ b/basis/glib/glib.factor
@@ -0,0 +1,37 @@
+! Copyright (C) 2008 Matthew Willis.
+! Copyright (C) 2009 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license
+USING: alien alien.syntax alien.destructors combinators system ;
+IN: glib
+
+<<
+
+{
+ { [ os winnt? ] [ "glib" "libglib-2.0-0.dll" "cdecl" add-library ] }
+ { [ os macosx? ] [ "glib" "/opt/local/lib/libglib-2.0.0.dylib" "cdecl" add-library ] }
+ { [ os unix? ] [ ] }
+} cond
+
+{
+ { [ os winnt? ] [ "gobject" "libgobject-2.0-0.dll" "cdecl" add-library ] }
+ { [ os macosx? ] [ "gobject" "/opt/local/lib/libgobject-2.0.0.dylib" "cdecl" add-library ] }
+ { [ os unix? ] [ ] }
+} cond
+
+>>
+
+LIBRARY: glib
+
+TYPEDEF: void* gpointer
+TYPEDEF: int gint
+TYPEDEF: bool gboolean
+
+FUNCTION: void
+g_free ( gpointer mem ) ;
+
+LIBRARY: gobject
+
+FUNCTION: void
+g_object_unref ( gpointer object ) ;
+
+DESTRUCTOR: g_object_unref
diff --git a/basis/glib/summary.txt b/basis/glib/summary.txt
new file mode 100644
index 0000000000..a4b5d805a4
--- /dev/null
+++ b/basis/glib/summary.txt
@@ -0,0 +1 @@
+Binding for GLib
diff --git a/basis/freetype/tags.txt b/basis/glib/tags.txt
similarity index 100%
rename from basis/freetype/tags.txt
rename to basis/glib/tags.txt
diff --git a/basis/globs/globs-tests.factor b/basis/globs/globs-tests.factor
index 446f1ee0a9..45eb27ea62 100644
--- a/basis/globs/globs-tests.factor
+++ b/basis/globs/globs-tests.factor
@@ -14,5 +14,6 @@ USING: tools.test globs ;
[ f ] [ "foo.java" "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.txt" "*.{xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.xml" "*.{xml,txt}" glob-matches? ] unit-test
-[ f ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
+[ f ] [ "foo." "*.{xml,txt}" glob-matches? ] unit-test
+[ t ] [ "foo." "*.{,xml,txt}" glob-matches? ] unit-test
[ t ] [ "foo.{" "*.{" glob-matches? ] unit-test
diff --git a/basis/globs/globs.factor b/basis/globs/globs.factor
index 14ddb0ed9b..173187574b 100644
--- a/basis/globs/globs.factor
+++ b/basis/globs/globs.factor
@@ -1,42 +1,42 @@
-! Copyright (C) 2007 Slava Pestov.
+! Copyright (C) 2007, 2009 Slava Pestov, Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
-USING: parser-combinators parser-combinators.regexp lists sequences kernel
-promises strings unicode.case ;
+USING: sequences kernel regexp.combinators regexp.matchers strings unicode.case
+peg.ebnf regexp arrays ;
IN: globs
-
-: 'char' ( -- parser )
- [ ",*?" member? not ] satisfy ;
+Character = "\\" .:c => [[ c 1string ]]
+ | !(","|"}") . => [[ 1string ]]
-: 'string' ( -- parser )
- 'char' <+> [ >lower token ] <@ ;
+RangeCharacter = !("]") .
-: 'escaped-char' ( -- parser )
- "\\" token any-char-parser &> [ 1token ] <@ ;
+Range = RangeCharacter:a "-" RangeCharacter:b => [[ a b ]]
+ | RangeCharacter => [[ 1string ]]
-: 'escaped-string' ( -- parser )
- 'string' 'escaped-char' <|> ;
+StartRange = .:a "-" RangeCharacter:b => [[ a b ]]
+ | . => [[ 1string ]]
-DEFER: 'term'
+Ranges = StartRange:s Range*:r => [[ r s prefix ]]
-: 'glob' ( -- parser )
- 'term' <*> [ ] <@ ;
+CharClass = "^"?:n Ranges:e => [[ e n [