Merge commit 'origin/master' into emacs
Jose A. Ortega Ruiz
commit
90410f9c4b
|
|
@ -113,12 +113,6 @@ the command prompt using the console application:
|
|||
|
||||
factor.com -i=boot.<cpu>.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:
|
||||
|
||||
<http://factorcode.org/dlls>
|
||||
|
||||
Once bootstrapped, double-clicking factor.exe or factor.com starts
|
||||
the Factor UI.
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: functors destructors accessors kernel parser words ;
|
||||
USING: functors destructors accessors kernel parser words
|
||||
effects generalizations sequences ;
|
||||
IN: alien.destructors
|
||||
|
||||
SLOT: alien
|
||||
|
|
@ -11,6 +12,7 @@ F-destructor DEFINES-CLASS ${F}-destructor
|
|||
<F-destructor> DEFINES <${F}-destructor>
|
||||
&F DEFINES &${F}
|
||||
|F DEFINES |${F}
|
||||
N [ F stack-effect out>> length ]
|
||||
|
||||
WHERE
|
||||
|
||||
|
|
@ -18,7 +20,7 @@ TUPLE: F-destructor alien disposed ;
|
|||
|
||||
: <F-destructor> ( alien -- destructor ) f F-destructor boa ; inline
|
||||
|
||||
M: F-destructor dispose* alien>> F ;
|
||||
M: F-destructor dispose* alien>> F N ndrop ;
|
||||
|
||||
: &F ( alien -- alien ) dup <F-destructor> &dispose drop ; inline
|
||||
|
||||
|
|
|
|||
|
|
@ -7,10 +7,10 @@ IN: alien.fortran
|
|||
ARTICLE: "alien.fortran-abis" "Fortran ABIs"
|
||||
"Fortran does not have a standard ABI like C does. Factor supports the following Fortran ABIs:"
|
||||
{ $list
|
||||
{ { $subsection gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
|
||||
{ { $subsection f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
|
||||
{ { $subsection intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
|
||||
{ { $subsection intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
|
||||
{ { $link gfortran-abi } " is used by gfortran, the Fortran compiler included with GCC 4." }
|
||||
{ { $link f2c-abi } " is used by the F2C Fortran-to-C translator and G77, the Fortran compiler included with GCC 3.x and earlier. It is also used by gfortran when compiling with the -ff2c flag." }
|
||||
{ { $link intel-unix-abi } " is used by the Intel Fortran Compiler on Linux and Mac OS X." }
|
||||
{ { $link intel-windows-abi } " is used by the Intel Fortran Compiler on Windows." }
|
||||
}
|
||||
"A library's ABI is specified when that library is opened by the " { $link add-fortran-library } " word." ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.functions namespaces sequences
|
||||
strings system vocabs.loader threads accessors combinators
|
||||
locals classes.tuple math.order summary combinators.short-circuit ;
|
||||
USING: accessors arrays classes.tuple combinators combinators.short-circuit
|
||||
kernel locals math math.functions math.order namespaces sequences strings
|
||||
summary system threads vocabs.loader ;
|
||||
IN: calendar
|
||||
|
||||
HOOK: gmt-offset os ( -- hours minutes seconds )
|
||||
|
|
@ -136,7 +136,7 @@ CONSTANT: day-abbreviations3
|
|||
GENERIC: leap-year? ( obj -- ? )
|
||||
|
||||
M: integer leap-year? ( year -- ? )
|
||||
dup 100 mod zero? 400 4 ? mod zero? ;
|
||||
dup 100 divisor? 400 4 ? divisor? ;
|
||||
|
||||
M: timestamp leap-year? ( timestamp -- ? )
|
||||
year>> leap-year? ;
|
||||
|
|
@ -348,7 +348,7 @@ M: duration time-
|
|||
#! good for any date since October 15, 1582
|
||||
[
|
||||
dup 2 <= [ [ 1- ] [ 12 + ] bi* ] when
|
||||
[ dup [ 4 /i + ] keep [ 100 /i - ] keep 400 /i + ] dip
|
||||
[ dup [ 4 /i + ] [ 100 /i - ] [ 400 /i + ] tri ] dip
|
||||
[ 1+ 3 * 5 /i + ] keep 2 * +
|
||||
] dip 1+ + 7 mod ;
|
||||
|
||||
|
|
|
|||
|
|
@ -4,6 +4,9 @@ USING: accessors fry generalizations kernel macros math.order
|
|||
stack-checker math ;
|
||||
IN: combinators.smart
|
||||
|
||||
MACRO: drop-outputs ( quot -- quot' )
|
||||
dup infer out>> '[ @ _ ndrop ] ;
|
||||
|
||||
MACRO: output>sequence ( quot exemplar -- newquot )
|
||||
[ dup infer out>> ] dip
|
||||
'[ @ _ _ nsequence ] ;
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ M: topic url-of topic>filename ;
|
|||
: help>html ( topic -- xml )
|
||||
[ article-title ]
|
||||
[ drop help-stylesheet ]
|
||||
[ [ help ] with-html-writer ]
|
||||
[ [ print-topic ] with-html-writer ]
|
||||
tri simple-page ;
|
||||
|
||||
: generate-help-file ( topic -- )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
IN: help.tips
|
||||
USING: help.markup help.syntax debugger prettyprint see help help.vocabs
|
||||
help.apropos tools.time stack-checker editors ;
|
||||
help.apropos tools.time stack-checker editors memory ;
|
||||
|
||||
TIP: "To look at the most recent error, run " { $link :error } ". To look at the most recent error's callstack, run " { $link :c } "." ;
|
||||
|
||||
|
|
@ -20,6 +20,10 @@ TIP: "Power tools: " { $links see edit help about apropos time infer. } ;
|
|||
|
||||
TIP: "Tips of the day implement the " { $link "definition-protocol" } " and new tips of the day can be defined using the " { $link POSTPONE: TIP: } " parsing word." ;
|
||||
|
||||
TIP: "Try some simple demo applications, then look at the source code in " { $snippet "extra/" } ": " { $snippet "\"demos\" run" } ;
|
||||
|
||||
TIP: "To save time on reloading big libraries such as the " { $vocab-link "furnace" } " web framework, save the image after loading them using the " { $link save } " word." ;
|
||||
|
||||
HELP: TIP:
|
||||
{ $syntax "TIP: content ;" }
|
||||
{ $values { "content" "a markup element" } }
|
||||
|
|
|
|||
|
|
@ -1,11 +1,13 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: combinators kernel ;
|
||||
USING: combinators kernel accessors ;
|
||||
IN: images
|
||||
|
||||
SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
|
||||
|
||||
UNION: alpha-channel BGRA RGBA ABGR ARGB R16G16B16A16 R32G32B32A32 ;
|
||||
|
||||
: bytes-per-pixel ( component-order -- n )
|
||||
{
|
||||
{ L [ 1 ] }
|
||||
|
|
@ -29,4 +31,6 @@ TUPLE: image dim component-order upside-down? bitmap ;
|
|||
|
||||
: <image> ( -- image ) image new ; inline
|
||||
|
||||
: has-alpha? ( image -- ? ) component-order>> alpha-channel? ;
|
||||
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
|
@ -61,6 +61,18 @@ M: ARGB normalize-component-order*
|
|||
M: ABGR normalize-component-order*
|
||||
drop ARGB>RGBA BGRA>RGBA ;
|
||||
|
||||
: fix-XBGR ( bitmap -- bitmap' )
|
||||
dup 4 <sliced-groups> [ [ 255 0 ] dip set-nth ] each ;
|
||||
|
||||
M: XBGR normalize-component-order*
|
||||
drop fix-XBGR ABGR normalize-component-order* ;
|
||||
|
||||
: fix-BGRX ( bitmap -- bitmap' )
|
||||
dup 4 <sliced-groups> [ [ 255 3 ] dip set-nth ] each ;
|
||||
|
||||
M: BGRX normalize-component-order*
|
||||
drop fix-BGRX BGRA normalize-component-order* ;
|
||||
|
||||
: normalize-scan-line-order ( image -- image )
|
||||
dup upside-down?>> [
|
||||
dup dim>> first 4 * '[
|
||||
|
|
|
|||
|
|
@ -0,0 +1,23 @@
|
|||
USING: alien.fortran help.markup help.syntax math.blas.config multiline ;
|
||||
IN: math.blas.config
|
||||
|
||||
ARTICLE: "math.blas.config" "Configuring the BLAS interface"
|
||||
"The " { $link "math.blas-summary" } " chooses the underlying BLAS interface to use based on the values of the following global variables:"
|
||||
{ $subsection blas-library }
|
||||
{ $subsection blas-fortran-abi }
|
||||
"The interface attempts to set default values based on the ones encountered on the Factor project's build machines. If these settings don't work with your system's BLAS, or you wish to use a commercial BLAS, you may change the global values of those variables in your " { $link "factor-rc" } ". For example, to use AMD's ACML library on Windows with " { $snippet "math.blas" } ", your " { $snippet "factor-rc" } " would look like this:"
|
||||
{ $code <"
|
||||
USING: math.blas.config namespaces ;
|
||||
"X:\\path\\to\\acml.dll" blas-library set-global
|
||||
intel-windows-abi blas-fortran-abi set-global
|
||||
"> }
|
||||
"To take effect, the " { $snippet "blas-library" } " and " { $snippet "blas-fortran-abi" } " variables must be set before any other " { $snippet "math.blas" } " vocabularies are loaded."
|
||||
;
|
||||
|
||||
HELP: blas-library
|
||||
{ $description "The name of the shared library containing the BLAS interface to load. The value of this variable must be a valid shared library name that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
|
||||
|
||||
HELP: blas-fortran-abi
|
||||
{ $description "The Fortran ABI used by the BLAS interface specified in the " { $link blas-library } " variable. The value of " { $snippet "blas-fortran-abi" } " must be one of the " { $link "alien.fortran-abis" } " that can be passed to " { $link add-fortran-library } ". To take effect, this variable must be set before any other " { $snippet "math.blas" } " vocabularies are loaded. See " { $link "math.blas.config" } " for details and examples." } ;
|
||||
|
||||
ABOUT: "math.blas.config"
|
||||
|
|
@ -0,0 +1,23 @@
|
|||
USING: alien.fortran combinators kernel namespaces system ;
|
||||
IN: math.blas.config
|
||||
|
||||
SYMBOLS: blas-library blas-fortran-abi ;
|
||||
|
||||
blas-library [
|
||||
{
|
||||
{ [ os macosx? ] [ "libblas.dylib" ] }
|
||||
{ [ os windows? ] [ "blas.dll" ] }
|
||||
[ "libblas.so" ]
|
||||
} cond
|
||||
] initialize
|
||||
|
||||
blas-fortran-abi [
|
||||
{
|
||||
{ [ os macosx? ] [ intel-unix-abi ] }
|
||||
{ [ os windows? cpu x86.32? and ] [ f2c-abi ] }
|
||||
{ [ os windows? cpu x86.64? and ] [ gfortran-abi ] }
|
||||
{ [ os freebsd? ] [ gfortran-abi ] }
|
||||
{ [ os linux? cpu x86.32? and ] [ gfortran-abi ] }
|
||||
[ f2c-abi ]
|
||||
} cond
|
||||
] initialize
|
||||
|
|
@ -1,18 +1,9 @@
|
|||
USING: alien alien.fortran kernel system combinators
|
||||
alien.libraries ;
|
||||
USING: alien.fortran kernel math.blas.config namespaces ;
|
||||
IN: math.blas.ffi
|
||||
|
||||
<<
|
||||
"blas" {
|
||||
{ [ os macosx? ] [ "libblas.dylib" intel-unix-abi add-fortran-library ] }
|
||||
{ [ os windows? cpu x86.32? and ] [ "blas.dll" f2c-abi add-fortran-library ] }
|
||||
{ [ os windows? cpu x86.64? and ] [ "blas.dll" gfortran-abi add-fortran-library ] }
|
||||
{
|
||||
[ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ]
|
||||
[ "libblas.so" gfortran-abi add-fortran-library ]
|
||||
}
|
||||
[ "libblas.so" f2c-abi add-fortran-library ]
|
||||
} cond
|
||||
"blas" blas-library blas-fortran-abi [ get ] bi@
|
||||
add-fortran-library
|
||||
>>
|
||||
|
||||
LIBRARY: blas
|
||||
|
|
|
|||
|
|
@ -2,13 +2,14 @@ USING: alien byte-arrays help.markup help.syntax math math.blas.vectors sequence
|
|||
IN: math.blas.matrices
|
||||
|
||||
ARTICLE: "math.blas-summary" "Basic Linear Algebra Subroutines (BLAS) interface"
|
||||
"Factor provides an interface to high-performance vector and matrix math routines available in the system's BLAS library. A set of specialized types are provided for handling packed, unboxed vector data:"
|
||||
"Factor provides an interface to high-performance vector and matrix math routines available in implementations of the BLAS math library. A set of specialized types are provided for handling packed, unboxed vector data:"
|
||||
{ $subsection "math.blas-types" }
|
||||
"Scalar-vector and vector-vector operations are available in the " { $vocab-link "math.blas.vectors" } " vocabulary:"
|
||||
{ $subsection "math.blas.vectors" }
|
||||
"Vector-matrix and matrix-matrix operations are available in the " { $vocab-link "math.blas.matrices" } " vocabulary:"
|
||||
{ $subsection "math.blas.matrices" }
|
||||
"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary." ;
|
||||
"The low-level BLAS Fortran interface can be accessed directly through the " { $vocab-link "math.blas.ffi" } " vocabulary. The BLAS interface can be configured to use different underlying BLAS implementations:"
|
||||
{ $subsection "math.blas.config" } ;
|
||||
|
||||
ARTICLE: "math.blas-types" "BLAS interface types"
|
||||
"BLAS vectors come in single- and double-precision, real and complex flavors:"
|
||||
|
|
|
|||
|
|
@ -13,7 +13,8 @@ ARTICLE: "integer-functions" "Integer functions"
|
|||
"Tests:"
|
||||
{ $subsection power-of-2? }
|
||||
{ $subsection even? }
|
||||
{ $subsection odd? } ;
|
||||
{ $subsection odd? }
|
||||
{ $subsection divisor? } ;
|
||||
|
||||
ARTICLE: "arithmetic-functions" "Arithmetic functions"
|
||||
"Computing additive and multiplicative inverses:"
|
||||
|
|
@ -269,6 +270,11 @@ HELP: gcd
|
|||
{ $description "Computes the positive greatest common divisor " { $snippet "d" } " of " { $snippet "x" } " and " { $snippet "y" } ", and another value " { $snippet "a" } " satisfying:" { $code "a*y = d mod x" } }
|
||||
{ $notes "If " { $snippet "d" } " is 1, then " { $snippet "a" } " is the inverse of " { $snippet "y" } " modulo " { $snippet "x" } "." } ;
|
||||
|
||||
HELP: divisor?
|
||||
{ $values { "m" integer } { "n" integer } { "?" "a boolean" } }
|
||||
{ $description "Tests if " { $snippet "n" } " is a divisor of " { $snippet "m" } ". This is the same thing as asking if " { $snippet "m" } " is divisible by " { $snippet "n" } "." }
|
||||
{ $notes "Returns t for both negative and positive divisors, as well as for trivial and non-trivial divisors." } ;
|
||||
|
||||
HELP: mod-inv
|
||||
{ $values { "x" integer } { "n" integer } { "y" integer } }
|
||||
{ $description "Outputs an integer " { $snippet "y" } " such that " { $snippet "xy = 1 (mod n)" } "." }
|
||||
|
|
|
|||
|
|
@ -32,13 +32,13 @@ IN: math.functions.tests
|
|||
|
||||
[ 1.0 ] [ 0 cosh ] unit-test
|
||||
[ 0.0 ] [ 1 acosh ] unit-test
|
||||
|
||||
|
||||
[ 1.0 ] [ 0 cos ] unit-test
|
||||
[ 0.0 ] [ 1 acos ] unit-test
|
||||
|
||||
|
||||
[ 0.0 ] [ 0 sinh ] unit-test
|
||||
[ 0.0 ] [ 0 asinh ] unit-test
|
||||
|
||||
|
||||
[ 0.0 ] [ 0 sin ] unit-test
|
||||
[ 0.0 ] [ 0 asin ] unit-test
|
||||
|
||||
|
|
@ -97,11 +97,17 @@ IN: math.functions.tests
|
|||
|
||||
: verify-gcd ( a b -- ? )
|
||||
2dup gcd
|
||||
[ rot * swap rem ] dip = ;
|
||||
[ rot * swap rem ] dip = ;
|
||||
|
||||
[ t ] [ 123 124 verify-gcd ] unit-test
|
||||
[ t ] [ 50 120 verify-gcd ] unit-test
|
||||
|
||||
[ t ] [ 0 42 divisor? ] unit-test
|
||||
[ t ] [ 42 7 divisor? ] unit-test
|
||||
[ t ] [ 42 -7 divisor? ] unit-test
|
||||
[ t ] [ 42 42 divisor? ] unit-test
|
||||
[ f ] [ 42 16 divisor? ] unit-test
|
||||
|
||||
[ 3 ] [ 5 7 mod-inv ] unit-test
|
||||
[ 78572682077 ] [ 234829342 342389423843 mod-inv ] unit-test
|
||||
|
||||
|
|
@ -150,4 +156,4 @@ IN: math.functions.tests
|
|||
1067811677921310779
|
||||
2135623355842621559
|
||||
[ >bignum ] tri@ ^mod
|
||||
] unit-test
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -111,6 +111,9 @@ PRIVATE>
|
|||
: lcm ( a b -- c )
|
||||
[ * ] 2keep gcd nip /i ; foldable
|
||||
|
||||
: divisor? ( m n -- ? )
|
||||
mod 0 = ;
|
||||
|
||||
: mod-inv ( x n -- y )
|
||||
[ nip ] [ gcd 1 = ] 2bi
|
||||
[ dup 0 < [ + ] [ nip ] if ]
|
||||
|
|
@ -198,7 +201,7 @@ M: real sin fsin ;
|
|||
|
||||
GENERIC: sinh ( x -- y ) foldable
|
||||
|
||||
M: complex sinh
|
||||
M: complex sinh
|
||||
>float-rect
|
||||
[ [ fsinh ] [ fcos ] bi* * ]
|
||||
[ [ fcosh ] [ fsin ] bi* * ] 2bi rect> ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2007-2009 Samuel Tardieu.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays combinators kernel make math math.primes sequences ;
|
||||
USING: arrays combinators kernel make math math.functions math.primes sequences ;
|
||||
IN: math.primes.factors
|
||||
|
||||
<PRIVATE
|
||||
|
|
@ -11,7 +11,7 @@ IN: math.primes.factors
|
|||
swap ;
|
||||
|
||||
: write-factor ( n d -- n' d' )
|
||||
2dup mod zero? [
|
||||
2dup divisor? [
|
||||
[ [ count-factor ] keep swap 2array , ] keep
|
||||
! If the remainder is a prime number, increase d so that
|
||||
! the caller stops looking for factors.
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: accessors assocs cache colors.constants destructors fry kernel
|
||||
opengl opengl.gl combinators images images.tesselation grouping
|
||||
specialized-arrays.float locals sequences math math.vectors
|
||||
math.matrices generalizations fry columns ;
|
||||
math.matrices generalizations fry columns arrays ;
|
||||
IN: opengl.textures
|
||||
|
||||
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
|
||||
|
|
@ -17,6 +17,7 @@ M: BGR component-order>format drop GL_BGR GL_UNSIGNED_BYTE ;
|
|||
M: RGBA component-order>format drop GL_RGBA GL_UNSIGNED_BYTE ;
|
||||
M: ARGB component-order>format drop GL_BGRA_EXT GL_UNSIGNED_INT_8_8_8_8_REV ;
|
||||
M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
|
||||
M: BGRX component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
|
||||
|
||||
GENERIC: draw-texture ( texture -- )
|
||||
|
||||
|
|
@ -24,7 +25,7 @@ GENERIC: draw-scaled-texture ( dim texture -- )
|
|||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
|
||||
TUPLE: single-texture image loc dim texture-coords texture display-list disposed ;
|
||||
|
||||
: repeat-last ( seq n -- seq' )
|
||||
over peek pad-tail concat ;
|
||||
|
|
@ -44,7 +45,7 @@ TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
|
|||
tri * group ; inline
|
||||
|
||||
: power-of-2-image ( image -- image )
|
||||
dup dim>> [ 0 = ] all? [
|
||||
dup dim>> [ [ 0 = ] [ power-of-2? ] bi or ] all? [
|
||||
clone dup
|
||||
[ image-rows ]
|
||||
[ dim>> [ next-power-of-2 ] map ]
|
||||
|
|
@ -92,26 +93,30 @@ TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
|
|||
|
||||
: draw-textured-rect ( dim texture -- )
|
||||
[
|
||||
(draw-textured-rect)
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
[ image>> has-alpha? [ GL_BLEND glDisable ] unless ]
|
||||
[ (draw-textured-rect) GL_TEXTURE_2D 0 glBindTexture ]
|
||||
[ image>> has-alpha? [ GL_BLEND glEnable ] unless ]
|
||||
tri
|
||||
] with-texturing ;
|
||||
|
||||
: texture-coords ( dim -- coords )
|
||||
[ dup next-power-of-2 /f ] map
|
||||
{ { 0 0 } { 1 0 } { 1 1 } { 0 1 } } [ v* ] with map
|
||||
: texture-coords ( texture -- coords )
|
||||
[
|
||||
[ dim>> ] [ image>> dim>> ] bi v/
|
||||
{ { 0 0 } { 1 0 } { 1 1 } { 0 1 } }
|
||||
[ v* ] with map
|
||||
] keep
|
||||
image>> upside-down?>> [ [ first2 1 swap - 2array ] map ] when
|
||||
float-array{ } join ;
|
||||
|
||||
: make-texture-display-list ( texture -- dlist )
|
||||
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
|
||||
|
||||
: <single-texture> ( image loc -- texture )
|
||||
single-texture new swap >>loc
|
||||
swap
|
||||
[ dim>> >>dim ] keep
|
||||
[ dim>> product 0 = ] keep '[
|
||||
_
|
||||
[ dim>> texture-coords >>texture-coords ]
|
||||
[ power-of-2-image make-texture >>texture ] bi
|
||||
: <single-texture> ( image loc dim -- texture )
|
||||
[ power-of-2-image ] 2dip
|
||||
single-texture new swap >>dim swap >>loc swap >>image
|
||||
dup image>> dim>> product 0 = [
|
||||
dup texture-coords >>texture-coords
|
||||
dup image>> make-texture >>texture
|
||||
dup make-texture-display-list >>display-list
|
||||
] unless ;
|
||||
|
||||
|
|
@ -133,19 +138,20 @@ TUPLE: multi-texture grid display-list loc disposed ;
|
|||
|
||||
: <texture-grid> ( image-grid loc -- grid )
|
||||
[ dup image-locs ] dip
|
||||
'[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
|
||||
'[ [ _ v+ over dim>> <single-texture> |dispose ] 2map ] 2map ;
|
||||
|
||||
: draw-textured-grid ( grid -- )
|
||||
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
|
||||
|
||||
: grid-has-alpha? ( grid -- ? )
|
||||
first first image>> has-alpha? ;
|
||||
|
||||
: make-textured-grid-display-list ( grid -- dlist )
|
||||
GL_COMPILE [
|
||||
[
|
||||
[
|
||||
[
|
||||
[ dim>> ] keep (draw-textured-rect)
|
||||
] each
|
||||
] each
|
||||
[ grid-has-alpha? [ GL_BLEND glDisable ] unless ]
|
||||
[ [ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ]
|
||||
[ grid-has-alpha? [ GL_BLEND glEnable ] unless ] tri
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] with-texturing
|
||||
] make-dlist ;
|
||||
|
|
@ -163,11 +169,14 @@ M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
|
|||
|
||||
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
|
||||
|
||||
CONSTANT: max-texture-size { 256 256 }
|
||||
CONSTANT: max-texture-size { 512 512 }
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <texture> ( image loc -- texture )
|
||||
over dim>> max-texture-size [ <= ] 2all?
|
||||
: small-texture? ( dim -- ? )
|
||||
max-texture-size [ <= ] 2all? ;
|
||||
|
||||
: <texture> ( image loc dim -- texture )
|
||||
pick dim>> small-texture?
|
||||
[ <single-texture> ]
|
||||
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
|
||||
[ drop [ max-texture-size tesselate ] dip <multi-texture> ] if ;
|
||||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types arrays assocs byte-arrays io
|
||||
io.binary io.streams.string kernel math math.parser namespaces
|
||||
make parser prettyprint quotations sequences strings vectors
|
||||
make parser quotations sequences strings vectors
|
||||
words macros math.functions math.bitwise fry generalizations
|
||||
combinators.smart io.streams.byte-array io.encodings.binary
|
||||
math.vectors combinators multiline endian ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,16 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: functors kernel math.order sequences sorting ;
|
||||
IN: sorting.functor
|
||||
|
||||
FUNCTOR: define-sorting ( NAME QUOT -- )
|
||||
|
||||
NAME<=> DEFINES ${NAME}<=>
|
||||
NAME>=< DEFINES ${NAME}>=<
|
||||
|
||||
WHERE
|
||||
|
||||
: NAME<=> ( obj1 obj2 -- <=> ) QUOT bi@ <=> ;
|
||||
: NAME>=< ( obj1 obj2 -- >=< ) NAME<=> invert-comparison ;
|
||||
|
||||
;FUNCTOR
|
||||
|
|
@ -25,46 +25,11 @@ HELP: human>=<
|
|||
}
|
||||
{ $description "Compares two objects using the " { $link human<=> } " word and inverts the result." } ;
|
||||
|
||||
HELP: human-compare
|
||||
{ $values
|
||||
{ "obj1" object } { "obj2" object } { "quot" quotation }
|
||||
{ "<=>" "an ordering specifier" }
|
||||
}
|
||||
{ $description "Compares the results of applying the quotation to both objects via <=>." } ;
|
||||
|
||||
HELP: human-sort
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "seq'" sequence }
|
||||
}
|
||||
{ $description "Sorts a sequence of objects by comparing the magnitude of any integers in the input string using the <=> word." } ;
|
||||
|
||||
HELP: human-sort-keys
|
||||
{ $values
|
||||
{ "seq" "an alist" }
|
||||
{ "sortedseq" "a new sorted sequence" }
|
||||
}
|
||||
{ $description "Sorts the elements comparing first elements of pairs using the " { $link human<=> } " word." } ;
|
||||
|
||||
HELP: human-sort-values
|
||||
{ $values
|
||||
{ "seq" "an alist" }
|
||||
{ "sortedseq" "a new sorted sequence" }
|
||||
}
|
||||
{ $description "Sorts the elements comparing second elements of pairs using the " { $link human<=> } " word." } ;
|
||||
|
||||
{ <=> >=< human-compare human-sort human-sort-keys human-sort-values } related-words
|
||||
|
||||
ARTICLE: "sorting.human" "Human-friendly sorting"
|
||||
"The " { $vocab-link "sorting.human" } " vocabulary sorts by numbers as a human would -- by comparing their magnitudes -- rather than in a lexicographic way. For example, sorting a1, a10, a03, a2 with human sort returns a1, a2, a03, a10, while sorting with natural sort returns a03, a1, a10, a2." $nl
|
||||
"Comparing two objects:"
|
||||
{ $subsection human<=> }
|
||||
{ $subsection human>=< }
|
||||
{ $subsection human-compare }
|
||||
"Sort a sequence:"
|
||||
{ $subsection human-sort }
|
||||
{ $subsection human-sort-keys }
|
||||
{ $subsection human-sort-values }
|
||||
"Splitting a string into substrings and integers:"
|
||||
{ $subsection find-numbers } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
USING: sorting.human tools.test ;
|
||||
USING: sorting.human tools.test sorting.slots ;
|
||||
IN: sorting.human.tests
|
||||
|
||||
\ human-sort must-infer
|
||||
|
||||
[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } human-sort ] unit-test
|
||||
[ { "x1y" "x2" "x10y" } ] [ { "x1y" "x10y" "x2" } { human<=> } sort-by ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,22 +1,9 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: peg.ebnf math.parser kernel assocs sorting fry
|
||||
math.order sequences ascii splitting.monotonic ;
|
||||
USING: math.parser peg.ebnf sorting.functor ;
|
||||
IN: sorting.human
|
||||
|
||||
: find-numbers ( string -- seq )
|
||||
[EBNF Result = ([0-9]+ => [[ string>number ]] | (!([0-9]) .)+)* EBNF] ;
|
||||
|
||||
: human<=> ( obj1 obj2 -- <=> ) [ find-numbers ] bi@ <=> ;
|
||||
|
||||
: human>=< ( obj1 obj2 -- >=< ) human<=> invert-comparison ; inline
|
||||
|
||||
: human-compare ( obj1 obj2 quot -- <=> ) bi@ human<=> ; inline
|
||||
|
||||
: human-sort ( seq -- seq' ) [ human<=> ] sort ;
|
||||
|
||||
: human-sort-keys ( seq -- sortedseq )
|
||||
[ [ first ] human-compare ] sort ;
|
||||
|
||||
: human-sort-values ( seq -- sortedseq )
|
||||
[ [ second ] human-compare ] sort ;
|
||||
<< "human" [ find-numbers ] define-sorting >>
|
||||
|
|
|
|||
|
|
@ -14,7 +14,7 @@ HELP: compare-slots
|
|||
HELP: sort-by-slots
|
||||
{ $values
|
||||
{ "seq" sequence } { "sort-specs" "a sequence of accessors ending with a comparator" }
|
||||
{ "seq'" sequence }
|
||||
{ "sortedseq" sequence }
|
||||
}
|
||||
{ $description "Sorts a sequence of tuples by the sort-specs in " { $snippet "sort-spec" } ". A sort-spec is a sequence of slot accessors ending in a comparator." }
|
||||
{ $examples
|
||||
|
|
@ -39,11 +39,20 @@ HELP: split-by-slots
|
|||
}
|
||||
{ $description "Splits a sequence of tuples into a sequence of slices of tuples that have the same values in all slots in the accessor sequence. This word is only useful for splitting a sorted sequence, but is more efficient than partitioning in such a case." } ;
|
||||
|
||||
HELP: sort-by
|
||||
{ $values
|
||||
{ "seq" sequence } { "sort-seq" "a sequence of comparators" }
|
||||
{ "sortedseq" sequence }
|
||||
}
|
||||
{ $description "Sorts a sequence by comparing elements by comparators, using subsequent comparators when there is a tie." } ;
|
||||
|
||||
ARTICLE: "sorting.slots" "Sorting by slots"
|
||||
"The " { $vocab-link "sorting.slots" } " vocabulary can sort tuples by slot in ascending or descending order, using subsequent slots as tie-breakers." $nl
|
||||
"Comparing two objects by a sequence of slots:"
|
||||
{ $subsection compare-slots }
|
||||
"Sorting a sequence by a sequence of slots:"
|
||||
{ $subsection sort-by-slots } ;
|
||||
"Sorting a sequence of tuples by a slot/comparator pairs:"
|
||||
{ $subsection sort-by-slots }
|
||||
"Sorting a sequence by a sequence of comparators:"
|
||||
{ $subsection sort-by } ;
|
||||
|
||||
ABOUT: "sorting.slots"
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors math.order sorting.slots tools.test
|
||||
sorting.human arrays sequences kernel assocs multiline ;
|
||||
sorting.human arrays sequences kernel assocs multiline
|
||||
sorting.functor ;
|
||||
IN: sorting.literals.tests
|
||||
|
||||
TUPLE: sort-test a b c tuple2 ;
|
||||
|
|
@ -76,6 +77,9 @@ TUPLE: tuple2 d ;
|
|||
[ { } ]
|
||||
[ { } { { a>> <=> } { b>> >=< } { c>> <=> } } sort-by-slots ] unit-test
|
||||
|
||||
[ { } ]
|
||||
[ { } { } sort-by-slots ] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
T{ sort-test { a 6 } { tuple2 T{ tuple2 { d 1 } } } }
|
||||
|
|
@ -143,3 +147,15 @@ TUPLE: tuple2 d ;
|
|||
T{ sort-test { a 5 } { tuple2 T{ tuple2 { d 4 } } } }
|
||||
} { { tuple2>> d>> } { a>> } } split-by-slots [ >array ] map
|
||||
] unit-test
|
||||
|
||||
|
||||
[ { "a" "b" "c" } ] [ { "b" "c" "a" } { <=> <=> } sort-by ] unit-test
|
||||
[ { "b" "c" "a" } ] [ { "b" "c" "a" } { } sort-by ] unit-test
|
||||
|
||||
<< "length-test" [ length ] define-sorting >>
|
||||
|
||||
[ { { 1 } { 1 2 3 } { 1 3 2 } { 3 2 1 } } ]
|
||||
[
|
||||
{ { 3 2 1 } { 1 2 3 } { 1 3 2 } { 1 } }
|
||||
{ length-test<=> <=> } sort-by
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -7,13 +7,16 @@ IN: sorting.slots
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: short-circuit-comparator ( obj1 obj2 word -- comparator/? )
|
||||
execute dup +eq+ eq? [ drop f ] when ;
|
||||
|
||||
: slot-comparator ( seq -- quot )
|
||||
[
|
||||
but-last-slice
|
||||
[ '[ [ _ execute ] bi@ ] ] map concat
|
||||
] [
|
||||
peek
|
||||
'[ @ _ execute dup +eq+ eq? [ drop f ] when ]
|
||||
'[ @ _ short-circuit-comparator ]
|
||||
] bi ;
|
||||
|
||||
PRIVATE>
|
||||
|
|
@ -22,9 +25,21 @@ MACRO: compare-slots ( sort-specs -- <=> )
|
|||
#! sort-spec: { accessors comparator }
|
||||
[ slot-comparator ] map '[ _ 2|| +eq+ or ] ;
|
||||
|
||||
: sort-by-slots ( seq sort-specs -- seq' )
|
||||
: sort-by-slots ( seq sort-specs -- sortedseq )
|
||||
'[ _ compare-slots ] sort ;
|
||||
|
||||
MACRO: compare-seq ( seq -- quot )
|
||||
[ '[ _ short-circuit-comparator ] ] map '[ _ 2|| +eq+ or ] ;
|
||||
|
||||
: sort-by ( seq sort-seq -- sortedseq )
|
||||
'[ _ compare-seq ] sort ;
|
||||
|
||||
: sort-keys-by ( seq sort-seq -- sortedseq )
|
||||
'[ [ first ] bi@ _ compare-seq ] sort ;
|
||||
|
||||
: sort-values-by ( seq sort-seq -- sortedseq )
|
||||
'[ [ second ] bi@ _ compare-seq ] sort ;
|
||||
|
||||
MACRO: split-by-slots ( accessor-seqs -- quot )
|
||||
[ [ '[ [ _ execute ] bi@ ] ] map concat [ = ] compose ] map
|
||||
'[ [ _ 2&& ] slice monotonic-slice ] ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,40 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test sorting.title sorting.slots ;
|
||||
IN: sorting.title.tests
|
||||
|
||||
: sort-me ( -- seq )
|
||||
{
|
||||
"The Beatles"
|
||||
"A river runs through it"
|
||||
"Another"
|
||||
"la vida loca"
|
||||
"Basketball"
|
||||
"racquetball"
|
||||
"Los Fujis"
|
||||
"los Fujis"
|
||||
"La cucaracha"
|
||||
"a day to remember"
|
||||
"of mice and men"
|
||||
"on belay"
|
||||
"for the horde"
|
||||
} ;
|
||||
[
|
||||
{
|
||||
"Another"
|
||||
"Basketball"
|
||||
"The Beatles"
|
||||
"La cucaracha"
|
||||
"a day to remember"
|
||||
"for the horde"
|
||||
"Los Fujis"
|
||||
"los Fujis"
|
||||
"of mice and men"
|
||||
"on belay"
|
||||
"racquetball"
|
||||
"A river runs through it"
|
||||
"la vida loca"
|
||||
}
|
||||
] [
|
||||
sort-me { title<=> } sort-by
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sorting.functor regexp kernel accessors sequences
|
||||
unicode.case ;
|
||||
IN: sorting.title
|
||||
|
||||
<< "title" [ >lower dup R/ ^(the|a|an|el|la|los|las|il) / first-match [ to>> tail-slice ] when* ] define-sorting >>
|
||||
|
|
@ -605,6 +605,8 @@ M: object infer-call*
|
|||
|
||||
\ fflush { alien } { } define-primitive
|
||||
|
||||
\ fseek { alien integer integer } { } define-primitive
|
||||
|
||||
\ fclose { alien } { } define-primitive
|
||||
|
||||
\ <wrapper> { object } { wrapper } define-primitive
|
||||
|
|
|
|||
|
|
@ -42,11 +42,12 @@ IN: tools.deploy.macosx
|
|||
|
||||
: create-app-dir ( vocab bundle-name -- vm )
|
||||
[
|
||||
nip
|
||||
[ copy-dll ]
|
||||
[ copy-nib ]
|
||||
[ "Contents/Resources" append-path make-directories ]
|
||||
tri
|
||||
nip {
|
||||
[ copy-dll ]
|
||||
[ copy-nib ]
|
||||
[ "Contents/Resources" append-path make-directories ]
|
||||
[ "Contents/Resources" copy-theme ]
|
||||
} cleave
|
||||
]
|
||||
[ create-app-plist ]
|
||||
[ "Contents/MacOS/" append-path copy-vm ] 2tri
|
||||
|
|
|
|||
|
|
@ -157,7 +157,8 @@ IN: tools.deploy.shaker
|
|||
"specializer"
|
||||
"step-into"
|
||||
"step-into?"
|
||||
"superclass"
|
||||
! UI needs this
|
||||
! "superclass"
|
||||
"transform-n"
|
||||
"transform-quot"
|
||||
"tuple-dispatch-generic"
|
||||
|
|
@ -276,7 +277,6 @@ IN: tools.deploy.shaker
|
|||
lexer-factory
|
||||
print-use-hook
|
||||
root-cache
|
||||
vocab-roots
|
||||
vocabs:dictionary
|
||||
vocabs:load-vocab-hook
|
||||
word
|
||||
|
|
|
|||
|
|
@ -9,11 +9,6 @@ IN: tools.deploy.windows
|
|||
: copy-dll ( bundle-name -- )
|
||||
"resource:factor.dll" swap copy-file-into ;
|
||||
|
||||
: copy-pango ( bundle-name -- )
|
||||
"resource:build-support/dlls.txt" ascii file-lines
|
||||
[ "resource:" prepend-path ] map
|
||||
swap copy-files-into ;
|
||||
|
||||
:: copy-vm ( executable bundle-name extension -- vm )
|
||||
vm "." split1-last drop extension append
|
||||
bundle-name executable ".exe" append append-path
|
||||
|
|
@ -22,9 +17,7 @@ IN: tools.deploy.windows
|
|||
: create-exe-dir ( vocab bundle-name -- vm )
|
||||
dup copy-dll
|
||||
deploy-ui? get [
|
||||
[ copy-pango ]
|
||||
[ "" copy-theme ]
|
||||
[ ".exe" copy-vm ] tri
|
||||
[ "" copy-theme ] [ ".exe" copy-vm ] bi
|
||||
] [ ".com" copy-vm ] if ;
|
||||
|
||||
M: winnt deploy*
|
||||
|
|
|
|||
|
|
@ -1,16 +1,16 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! Portions copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types alien.strings arrays assocs ui
|
||||
ui.private ui.gadgets ui.gadgets.private ui.backend
|
||||
ui.clipboards ui.gadgets.worlds ui.gestures ui.event-loop io
|
||||
kernel math math.vectors namespaces make sequences strings
|
||||
vectors words windows.kernel32 windows.gdi32 windows.user32
|
||||
windows.opengl32 windows.messages windows.types windows.nt
|
||||
windows threads libc combinators fry combinators.short-circuit
|
||||
continuations command-line shuffle opengl ui.render ascii
|
||||
math.bitwise locals accessors math.rectangles math.order ascii
|
||||
calendar io.encodings.utf16n ;
|
||||
USING: alien alien.c-types alien.strings arrays assocs ui ui.private
|
||||
ui.gadgets ui.gadgets.private ui.backend ui.clipboards
|
||||
ui.gadgets.worlds ui.gestures ui.event-loop io kernel math
|
||||
math.vectors namespaces make sequences strings vectors words
|
||||
windows.kernel32 windows.gdi32 windows.user32 windows.opengl32
|
||||
windows.messages windows.types windows.offscreen windows.nt windows
|
||||
threads libc combinators fry combinators.short-circuit continuations
|
||||
command-line shuffle opengl ui.render ascii math.bitwise locals
|
||||
accessors math.rectangles math.order ascii calendar
|
||||
io.encodings.utf16n ;
|
||||
IN: ui.backend.windows
|
||||
|
||||
SINGLETON: windows-ui-backend
|
||||
|
|
@ -433,12 +433,7 @@ M: windows-ui-backend do-events
|
|||
style 0 ex-style AdjustWindowRectEx win32-error=0/f ;
|
||||
|
||||
: make-RECT ( world -- RECT )
|
||||
[ window-loc>> dup ] [ dim>> ] bi v+
|
||||
"RECT" <c-object>
|
||||
over first over set-RECT-right
|
||||
swap second over set-RECT-bottom
|
||||
over first over set-RECT-left
|
||||
swap second over set-RECT-top ;
|
||||
[ window-loc>> ] [ dim>> ] bi <RECT> ;
|
||||
|
||||
: default-position-RECT ( RECT -- )
|
||||
dup get-RECT-dimensions [ 2drop ] 2dip
|
||||
|
|
@ -501,35 +496,12 @@ M: windows-ui-backend (open-window) ( world -- )
|
|||
hWnd>> show-window ;
|
||||
|
||||
M: win-base select-gl-context ( handle -- )
|
||||
[ hDC>> ] keep hRC>> wglMakeCurrent win32-error=0/f
|
||||
[ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
|
||||
GdiFlush drop ;
|
||||
|
||||
M: win-base flush-gl-context ( handle -- )
|
||||
hDC>> SwapBuffers win32-error=0/f ;
|
||||
|
||||
: (bitmap-info) ( dim -- BITMAPINFO )
|
||||
"BITMAPINFO" <c-object> [
|
||||
BITMAPINFO-bmiHeader {
|
||||
[ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
|
||||
[ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
|
||||
[ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
|
||||
[ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
|
||||
[ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
|
||||
[ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
|
||||
[ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
|
||||
[ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
|
||||
[ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
|
||||
[ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
|
||||
[ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
|
||||
} 2cleave
|
||||
] keep ;
|
||||
|
||||
: make-offscreen-dc-and-bitmap ( dim -- hDC hBitmap bits )
|
||||
f CreateCompatibleDC
|
||||
dup rot (bitmap-info) DIB_RGB_COLORS f <void*>
|
||||
[ f 0 CreateDIBSection ] keep *void*
|
||||
[ 2dup SelectObject drop ] dip ;
|
||||
|
||||
: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
|
||||
make-offscreen-dc-and-bitmap [
|
||||
[ dup offscreen-pfd-dwFlags setup-pixel-format ]
|
||||
|
|
@ -548,13 +520,12 @@ M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
|
|||
! each pixel; it's left as zero
|
||||
|
||||
: (make-opaque) ( byte-array -- byte-array' )
|
||||
[ length 4 / ]
|
||||
[ length 4 /i ]
|
||||
[ '[ 255 swap 4 * 3 + _ set-nth ] each ]
|
||||
[ ] tri ;
|
||||
|
||||
: (opaque-pixels) ( world -- pixels )
|
||||
[ handle>> bits>> ] [ dim>> first2 * 4 * ] bi
|
||||
memory>byte-array (make-opaque) ;
|
||||
[ handle>> bits>> ] [ dim>> ] bi bitmap>byte-array (make-opaque) ;
|
||||
|
||||
M: windows-ui-backend offscreen-pixels ( world -- alien w h )
|
||||
[ (opaque-pixels) ] [ dim>> first2 ] bi ;
|
||||
|
|
|
|||
|
|
@ -141,7 +141,7 @@ M: editor ungraft*
|
|||
: scroll>caret ( editor -- )
|
||||
dup graft-state>> second [
|
||||
[
|
||||
[ caret-loc ] [ caret-dim { 1 0 } v+ ] bi <rect>
|
||||
[ caret-loc ] [ caret-dim { 2 1 } v+ ] bi <rect>
|
||||
] keep scroll>rect
|
||||
] [ drop ] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -11,6 +11,7 @@ CONSTANT: horizontal { 1 0 }
|
|||
CONSTANT: vertical { 0 1 }
|
||||
|
||||
TUPLE: gadget < rect
|
||||
id
|
||||
pref-dim
|
||||
parent
|
||||
children
|
||||
|
|
@ -28,7 +29,7 @@ model ;
|
|||
|
||||
M: gadget equal? 2drop f ;
|
||||
|
||||
M: gadget hashcode* drop gadget hashcode* ;
|
||||
M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;
|
||||
|
||||
M: gadget model-changed 2drop ;
|
||||
|
||||
|
|
|
|||
|
|
@ -30,6 +30,9 @@ M: line-gadget line-height font>> font-metrics height>> ceiling ;
|
|||
: validate-line ( m gadget -- n )
|
||||
control-value [ drop f ] [ length 1- min 0 max ] if-empty ;
|
||||
|
||||
: valid-line? ( n gadget -- ? )
|
||||
control-value length 1- 0 swap between? ;
|
||||
|
||||
: visible-line ( gadget quot -- n )
|
||||
'[
|
||||
[ clip get @ origin get [ second ] bi@ - ] dip
|
||||
|
|
|
|||
|
|
@ -49,13 +49,13 @@ M: pane-stream stream-element-type drop +character+ ;
|
|||
: pane-caret&mark ( pane -- caret mark )
|
||||
[ caret>> ] [ mark>> ] bi ; inline
|
||||
|
||||
: selected-children ( pane -- seq )
|
||||
: selected-subtree ( pane -- seq )
|
||||
[ pane-caret&mark sort-pair ] keep gadget-subtree ;
|
||||
|
||||
M: pane gadget-selection? pane-caret&mark and ;
|
||||
|
||||
M: pane gadget-selection ( pane -- string/f )
|
||||
selected-children gadget-text ;
|
||||
selected-subtree gadget-text ;
|
||||
|
||||
: init-prototype ( pane -- pane )
|
||||
<shelf> +baseline+ >>align >>prototype ; inline
|
||||
|
|
@ -72,31 +72,12 @@ M: pane gadget-selection ( pane -- string/f )
|
|||
[ >>last-line ] [ 1 track-add ] bi
|
||||
dup prepare-last-line ; inline
|
||||
|
||||
GENERIC: draw-selection ( loc obj -- )
|
||||
|
||||
: if-fits ( rect quot -- )
|
||||
[ clip get over contains-rect? ] dip [ drop ] if ; inline
|
||||
|
||||
M: gadget draw-selection ( loc gadget -- )
|
||||
swap offset-rect [
|
||||
rect-bounds gl-fill-rect
|
||||
] if-fits ;
|
||||
|
||||
M: node draw-selection ( loc node -- )
|
||||
2dup value>> swap offset-rect [
|
||||
drop 2dup
|
||||
[ value>> loc>> v+ ] keep
|
||||
children>> [ draw-selection ] with each
|
||||
] if-fits 2drop ;
|
||||
|
||||
M: pane draw-gadget*
|
||||
M: pane selected-children
|
||||
dup gadget-selection? [
|
||||
[ selection-color>> gl-color ]
|
||||
[
|
||||
[ loc>> vneg ] keep selected-children
|
||||
[ draw-selection ] with each
|
||||
] bi
|
||||
] [ drop ] if ;
|
||||
[ selected-subtree leaves ]
|
||||
[ selection-color>> ]
|
||||
bi
|
||||
] [ drop f f ] if ;
|
||||
|
||||
: scroll-pane ( pane -- )
|
||||
dup scrolls?>> [ scroll>bottom ] [ drop ] if ;
|
||||
|
|
|
|||
|
|
@ -54,10 +54,10 @@ M: viewport pref-dim* gadget-child pref-viewport-dim ;
|
|||
2dup control-value = [ 2drop ] [ set-control-value ] if ;
|
||||
|
||||
: (scroll>rect) ( rect scroller -- )
|
||||
[ [ loc>> ] [ dim>> { 1 1 } v+ ] bi <rect> ] dip
|
||||
{
|
||||
[ scroller-value vneg offset-rect ]
|
||||
[ viewport>> dim>> rect-min ]
|
||||
[ viewport>> loc>> offset-rect ]
|
||||
[ viewport>> [ v- { 0 0 } vmin ] [ v- { 0 0 } vmax ] with-rect-extents v+ ]
|
||||
[ scroller-value v+ ]
|
||||
[ scroll ]
|
||||
|
|
|
|||
|
|
@ -268,12 +268,13 @@ M: table model-changed
|
|||
: mouse-row ( table -- n )
|
||||
[ hand-rel second ] keep y>line ;
|
||||
|
||||
: if-mouse-row ( table true: ( table mouse-index -- ) false: ( table -- ) -- )
|
||||
[ [ mouse-row ] keep 2dup valid-line? ]
|
||||
[ ] [ '[ nip @ ] ] tri* if ; inline
|
||||
|
||||
: table-button-down ( table -- )
|
||||
dup takes-focus?>> [ dup request-focus ] when
|
||||
dup control-value empty? [ drop ] [
|
||||
dup [ mouse-row ] keep validate-line
|
||||
[ >>mouse-index ] [ (select-row) ] bi
|
||||
] if ;
|
||||
[ swap [ >>mouse-index ] [ (select-row) ] bi ] [ drop ] if-mouse-row ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
|
|
@ -283,11 +284,14 @@ PRIVATE>
|
|||
[ 2drop ]
|
||||
if ;
|
||||
|
||||
: row-action? ( table -- ? )
|
||||
[ [ mouse-row ] keep valid-line? ]
|
||||
[ single-click?>> hand-click# get 2 = or ] bi and ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: table-button-up ( table -- )
|
||||
dup single-click?>> hand-click# get 2 = or
|
||||
[ row-action ] [ update-selected-value ] if ;
|
||||
dup row-action? [ row-action ] [ update-selected-value ] if ;
|
||||
|
||||
: select-row ( table n -- )
|
||||
over validate-line
|
||||
|
|
@ -320,13 +324,6 @@ PRIVATE>
|
|||
: next-page ( table -- )
|
||||
1 prev/next-page ;
|
||||
|
||||
: valid-row? ( row table -- ? )
|
||||
control-value length 1- 0 swap between? ;
|
||||
|
||||
: if-mouse-row ( table true false -- )
|
||||
[ [ mouse-row ] keep 2dup valid-row? ]
|
||||
[ ] [ '[ nip @ ] ] tri* if ; inline
|
||||
|
||||
: show-mouse-help ( table -- )
|
||||
[
|
||||
swap
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@ PRIVATE>
|
|||
|
||||
: rendered-image ( path -- texture )
|
||||
world get image-texture-cache
|
||||
[ cached-image { 0 0 } <texture> ] cache ;
|
||||
[ cached-image [ { 0 0 } ] keep dim>> <texture> ] cache ;
|
||||
|
||||
: draw-image ( image-name -- )
|
||||
rendered-image draw-texture ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: math.rectangles math.vectors namespaces kernel accessors
|
||||
combinators sequences opengl opengl.gl opengl.glu colors
|
||||
assocs combinators sequences opengl opengl.gl opengl.glu colors
|
||||
colors.constants ui.gadgets ui.pens ;
|
||||
IN: ui.render
|
||||
|
||||
|
|
@ -55,21 +55,57 @@ SYMBOL: origin
|
|||
|
||||
GENERIC: draw-children ( gadget -- )
|
||||
|
||||
! For gadget selection
|
||||
SYMBOL: selected-gadgets
|
||||
|
||||
SYMBOL: selection-background
|
||||
|
||||
GENERIC: selected-children ( gadget -- assoc/f selection-background )
|
||||
|
||||
M: gadget selected-children drop f f ;
|
||||
|
||||
! For text rendering
|
||||
SYMBOL: background
|
||||
|
||||
SYMBOL: foreground
|
||||
|
||||
GENERIC: gadget-background ( gadget -- color )
|
||||
|
||||
M: gadget gadget-background dup interior>> pen-background ;
|
||||
|
||||
GENERIC: gadget-foreground ( gadget -- color )
|
||||
|
||||
M: gadget gadget-foreground dup interior>> pen-foreground ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: draw-selection-background ( gadget -- )
|
||||
selection-background get background set
|
||||
selection-background get gl-color
|
||||
[ { 0 0 } ] dip dim>> gl-fill-rect ;
|
||||
|
||||
: draw-standard-background ( object -- )
|
||||
dup interior>> dup [ draw-interior ] [ 2drop ] if ;
|
||||
|
||||
: draw-background ( gadget -- )
|
||||
origin get [
|
||||
[
|
||||
dup selected-gadgets get key?
|
||||
[ draw-selection-background ]
|
||||
[ draw-standard-background ] if
|
||||
] [ draw-gadget* ] bi
|
||||
] with-translation ;
|
||||
|
||||
: draw-border ( object -- )
|
||||
dup boundary>> dup [
|
||||
origin get [ draw-boundary ] with-translation
|
||||
] [ 2drop ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: (draw-gadget) ( gadget -- )
|
||||
dup loc>> origin get v+ origin [
|
||||
[
|
||||
origin get [
|
||||
[ dup interior>> dup [ draw-interior ] [ 2drop ] if ]
|
||||
[ draw-gadget* ]
|
||||
bi
|
||||
] with-translation
|
||||
]
|
||||
[ draw-children ]
|
||||
[
|
||||
dup boundary>> dup [
|
||||
origin get [ draw-boundary ] with-translation
|
||||
] [ 2drop ] if
|
||||
] tri
|
||||
[ draw-background ] [ draw-children ] [ draw-border ] tri
|
||||
] with-variable ;
|
||||
|
||||
: >absolute ( rect -- rect )
|
||||
|
|
@ -88,27 +124,24 @@ GENERIC: draw-children ( gadget -- )
|
|||
[ [ (draw-gadget) ] with-clipping ]
|
||||
} cond ;
|
||||
|
||||
! For text rendering
|
||||
SYMBOL: background
|
||||
|
||||
SYMBOL: foreground
|
||||
|
||||
GENERIC: gadget-background ( gadget -- color )
|
||||
|
||||
M: gadget gadget-background dup interior>> pen-background ;
|
||||
|
||||
GENERIC: gadget-foreground ( gadget -- color )
|
||||
|
||||
M: gadget gadget-foreground dup interior>> pen-foreground ;
|
||||
|
||||
M: gadget draw-children
|
||||
[ visible-children ]
|
||||
[ gadget-background ]
|
||||
[ gadget-foreground ] tri [
|
||||
[ foreground set ] when*
|
||||
[ background set ] when*
|
||||
[ draw-gadget ] each
|
||||
] with-scope ;
|
||||
dup children>> [
|
||||
{
|
||||
[ visible-children ]
|
||||
[ selected-children ]
|
||||
[ gadget-background ]
|
||||
[ gadget-foreground ]
|
||||
} cleave [
|
||||
|
||||
{
|
||||
[ [ selected-gadgets set ] when* ]
|
||||
[ [ selection-background set ] when* ]
|
||||
[ [ background set ] when* ]
|
||||
[ [ foreground set ] when* ]
|
||||
} spread
|
||||
[ draw-gadget ] each
|
||||
] with-scope
|
||||
] [ drop ] if ;
|
||||
|
||||
CONSTANT: selection-color T{ rgba f 0.8 0.8 1.0 1.0 }
|
||||
|
||||
|
|
|
|||
|
|
@ -10,9 +10,6 @@ IN: ui.text.core-text
|
|||
|
||||
SINGLETON: core-text-renderer
|
||||
|
||||
M: core-text-renderer init-text-rendering
|
||||
<cache-assoc> >>text-handle drop ;
|
||||
|
||||
M: core-text-renderer string-dim
|
||||
[ " " string-dim { 0 1 } v* ]
|
||||
[ cached-line dim>> ]
|
||||
|
|
@ -22,9 +19,11 @@ M: core-text-renderer flush-layout-cache
|
|||
cached-lines get purge-cache ;
|
||||
|
||||
: rendered-line ( font string -- texture )
|
||||
world get world-text-handle
|
||||
[ cached-line [ image>> ] [ loc>> ] bi <texture> ]
|
||||
2cache ;
|
||||
world get world-text-handle [
|
||||
cached-line
|
||||
[ image>> ] [ loc>> ] [ image>> dim>> ] tri
|
||||
<texture>
|
||||
] 2cache ;
|
||||
|
||||
M: core-text-renderer draw-string ( font string -- )
|
||||
rendered-line draw-texture ;
|
||||
|
|
|
|||
|
|
@ -7,9 +7,6 @@ IN: ui.text.pango
|
|||
|
||||
SINGLETON: pango-renderer
|
||||
|
||||
M: pango-renderer init-text-rendering
|
||||
<cache-assoc> >>text-handle drop ;
|
||||
|
||||
M: pango-renderer string-dim
|
||||
[ " " string-dim { 0 1 } v* ]
|
||||
[ cached-layout logical-rect>> dim>> [ >integer ] map ] if-empty ;
|
||||
|
|
@ -18,9 +15,11 @@ M: pango-renderer flush-layout-cache
|
|||
cached-layouts get purge-cache ;
|
||||
|
||||
: rendered-layout ( font string -- texture )
|
||||
world get world-text-handle
|
||||
[ cached-layout [ image>> ] [ text-position vneg ] bi <texture> ]
|
||||
2cache ;
|
||||
world get world-text-handle [
|
||||
cached-layout
|
||||
[ image>> ] [ text-position vneg ] [ image>> dim>> ] tri
|
||||
<texture>
|
||||
] 2cache ;
|
||||
|
||||
M: pango-renderer draw-string ( font string -- )
|
||||
rendered-layout draw-texture ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
UI text rendering implementation using cross-platform Pango library
|
||||
|
|
@ -1,6 +1,22 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test ui.text fonts ;
|
||||
USING: tools.test ui.text fonts math accessors kernel sequences ;
|
||||
IN: ui.text.tests
|
||||
|
||||
[ 0.0 ] [ 0 sans-serif-font "aaa" offset>x ] unit-test
|
||||
[ t ] [ 0 sans-serif-font "aaa" offset>x zero? ] unit-test
|
||||
[ t ] [ 1 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
|
||||
[ t ] [ 3 sans-serif-font "aaa" offset>x 0.0 > ] unit-test
|
||||
[ t ] [ 1 monospace-font "a" offset>x 0.0 > ] unit-test
|
||||
[ 0 ] [ 0 sans-serif-font "aaa" x>offset ] unit-test
|
||||
[ 3 ] [ 100 sans-serif-font "aaa" x>offset ] unit-test
|
||||
[ 0 ] [ 0 sans-serif-font "" x>offset ] unit-test
|
||||
|
||||
[ t ] [
|
||||
sans-serif-font "aaa" line-metrics
|
||||
[ [ ascent>> ] [ descent>> ] bi + ] [ height>> ] bi =
|
||||
] unit-test
|
||||
|
||||
[ f ] [ sans-serif-font "\0a" text-dim first zero? ] unit-test
|
||||
[ t ] [ sans-serif-font "" text-dim first zero? ] unit-test
|
||||
|
||||
[ f ] [ sans-serif-font font-metrics height>> zero? ] unit-test
|
||||
|
|
|
|||
|
|
@ -1,17 +1,16 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel arrays sequences math math.order opengl opengl.gl
|
||||
strings fonts colors accessors namespaces ui.gadgets.worlds ;
|
||||
USING: kernel arrays sequences math math.order cache opengl
|
||||
opengl.gl strings fonts colors accessors namespaces
|
||||
ui.gadgets.worlds ;
|
||||
IN: ui.text
|
||||
|
||||
<PRIVATE
|
||||
|
||||
SYMBOL: font-renderer
|
||||
|
||||
HOOK: init-text-rendering font-renderer ( world -- )
|
||||
|
||||
: world-text-handle ( world -- handle )
|
||||
dup text-handle>> [ dup init-text-rendering ] unless
|
||||
dup text-handle>> [ <cache-assoc> >>text-handle ] unless
|
||||
text-handle>> ;
|
||||
|
||||
HOOK: flush-layout-cache font-renderer ( -- )
|
||||
|
|
@ -79,7 +78,7 @@ USING: vocabs.loader namespaces system combinators ;
|
|||
"ui-backend" get [
|
||||
{
|
||||
{ [ os macosx? ] [ "core-text" ] }
|
||||
{ [ os windows? ] [ "pango" ] }
|
||||
{ [ os windows? ] [ "uniscribe" ] }
|
||||
{ [ os unix? ] [ "pango" ] }
|
||||
} cond
|
||||
] unless* "ui.text." prepend require
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
UI text rendering implementation using the MS Windows Uniscribe library
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,42 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs cache kernel math math.vectors sequences fonts
|
||||
namespaces opengl.textures ui.text ui.text.private ui.gadgets.worlds
|
||||
windows.uniscribe ;
|
||||
IN: ui.text.uniscribe
|
||||
|
||||
SINGLETON: uniscribe-renderer
|
||||
|
||||
M: uniscribe-renderer string-dim
|
||||
[ " " string-dim { 0 1 } v* ]
|
||||
[ cached-script-string size>> ] if-empty ;
|
||||
|
||||
M: uniscribe-renderer flush-layout-cache
|
||||
cached-script-strings get purge-cache ;
|
||||
|
||||
: rendered-script-string ( font string -- texture )
|
||||
world get world-text-handle
|
||||
[ cached-script-string [ image>> { 0 0 } ] [ size>> ] bi <texture> ]
|
||||
2cache ;
|
||||
|
||||
M: uniscribe-renderer draw-string ( font string -- )
|
||||
dup dup selection? [ string>> ] when empty?
|
||||
[ 2drop ] [ rendered-script-string draw-texture ] if ;
|
||||
|
||||
M: uniscribe-renderer x>offset ( x font string -- n )
|
||||
[ 2drop 0 ] [
|
||||
cached-script-string x>line-offset 0 = [ 1+ ] unless
|
||||
] if-empty ;
|
||||
|
||||
M: uniscribe-renderer offset>x ( n font string -- x )
|
||||
[ 2drop 0 ] [ cached-script-string line-offset>x ] if-empty ;
|
||||
|
||||
M: uniscribe-renderer font-metrics ( font -- metrics )
|
||||
" " cached-script-string metrics>> clone f >>width ;
|
||||
|
||||
M: uniscribe-renderer line-metrics ( font string -- metrics )
|
||||
[ " " line-metrics clone 0 >>width ]
|
||||
[ cached-script-string metrics>> 50 >>width 10 >>cap-height 10 >>x-height ]
|
||||
if-empty ;
|
||||
|
||||
uniscribe-renderer font-renderer set-global
|
||||
|
|
@ -141,6 +141,7 @@ GENERIC# accept-completion-hook 1 ( item popup -- )
|
|||
t >>selection-required?
|
||||
t >>single-click?
|
||||
30 >>min-cols
|
||||
10 >>min-rows
|
||||
10 >>max-rows
|
||||
dup '[ _ accept-completion ] >>action ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2007, 2008 Slava Pestov.
|
||||
! Copyright (C) 2007, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors namespaces make sequences kernel math arrays io
|
||||
ui.gadgets generic combinators ;
|
||||
ui.gadgets generic combinators fry sets ;
|
||||
IN: ui.traverse
|
||||
|
||||
TUPLE: node value children ;
|
||||
|
|
@ -85,3 +85,13 @@ M: node gadget-text*
|
|||
|
||||
: gadget-at-path ( parent path -- gadget )
|
||||
[ swap nth-gadget ] each ;
|
||||
|
||||
GENERIC# leaves* 1 ( tree assoc -- )
|
||||
|
||||
M: node leaves* [ children>> ] dip leaves* ;
|
||||
|
||||
M: array leaves* '[ _ leaves* ] each ;
|
||||
|
||||
M: gadget leaves* conjoin ;
|
||||
|
||||
: leaves ( tree -- assoc ) H{ } clone [ leaves* ] keep ;
|
||||
|
|
@ -12,3 +12,8 @@ IN: unicode.categories.tests
|
|||
[ "Lo" ] [ HEX: 3450 category ] unit-test
|
||||
[ "Lo" ] [ HEX: 4DB5 category ] unit-test
|
||||
[ "Cs" ] [ HEX: DD00 category ] unit-test
|
||||
[ t ] [ CHAR: \t blank? ] unit-test
|
||||
[ t ] [ CHAR: \s blank? ] unit-test
|
||||
[ t ] [ CHAR: \r blank? ] unit-test
|
||||
[ t ] [ CHAR: \n blank? ] unit-test
|
||||
[ f ] [ CHAR: a blank? ] unit-test
|
||||
|
|
|
|||
|
|
@ -3,7 +3,7 @@
|
|||
USING: unicode.categories.syntax sequences unicode.data ;
|
||||
IN: unicode.categories
|
||||
|
||||
CATEGORY: blank Zs Zl Zp | "\r\n" member? ;
|
||||
CATEGORY: blank Zs Zl Zp | "\r\n\t" member? ;
|
||||
CATEGORY: letter Ll | "Other_Lowercase" property? ;
|
||||
CATEGORY: LETTER Lu | "Other_Uppercase" property? ;
|
||||
CATEGORY: Letter Lu Ll Lt Lm Lo Nl ;
|
||||
|
|
|
|||
|
|
@ -65,9 +65,8 @@ HELP: derive-url
|
|||
} ;
|
||||
|
||||
HELP: ensure-port
|
||||
{ $values { "url" url } }
|
||||
{ $description "If the URL does not specify a port number, fill in the default for the URL's protocol. If the protocol is unknown, the port number is not changed." }
|
||||
{ $side-effects "url" }
|
||||
{ $values { "url" url } { "url'" url } }
|
||||
{ $description "If the URL does not specify a port number, create a new URL which is equal except the port number is set to the default for the URL's protocol. If the protocol is unknown, outputs an exact copy of the input URL." }
|
||||
{ $examples
|
||||
{ $example
|
||||
"USING: accessors prettyprint urls ;"
|
||||
|
|
|
|||
|
|
@ -175,8 +175,8 @@ PRIVATE>
|
|||
] [ protocol>> ] bi
|
||||
secure-protocol? [ >secure-addr ] when ;
|
||||
|
||||
: ensure-port ( url -- url )
|
||||
dup protocol>> '[ _ protocol-port or ] change-port ;
|
||||
: ensure-port ( url -- url' )
|
||||
clone dup protocol>> '[ _ protocol-port or ] change-port ;
|
||||
|
||||
! Literal syntax
|
||||
SYNTAX: URL" lexer get skip-blank parse-string >url parsed ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,37 @@
|
|||
USING: assocs memoize locals kernel accessors init fonts math
|
||||
combinators windows windows.types windows.gdi32 ;
|
||||
IN: windows.fonts
|
||||
|
||||
: windows-font-name ( string -- string' )
|
||||
H{
|
||||
{ "sans-serif" "Tahoma" }
|
||||
{ "serif" "Times New Roman" }
|
||||
{ "monospace" "Courier New" }
|
||||
} at-default ;
|
||||
|
||||
MEMO:: (cache-font) ( font -- HFONT )
|
||||
font size>> neg ! nHeight
|
||||
0 0 0 ! nWidth, nEscapement, nOrientation
|
||||
font bold?>> FW_BOLD FW_NORMAL ? ! fnWeight
|
||||
font italic?>> TRUE FALSE ? ! fdwItalic
|
||||
FALSE ! fdwUnderline
|
||||
FALSE ! fdWStrikeOut
|
||||
DEFAULT_CHARSET ! fdwCharSet
|
||||
OUT_OUTLINE_PRECIS ! fdwOutputPrecision
|
||||
CLIP_DEFAULT_PRECIS ! fdwClipPrecision
|
||||
DEFAULT_QUALITY ! fdwQuality
|
||||
DEFAULT_PITCH ! fdwPitchAndFamily
|
||||
font name>> windows-font-name
|
||||
CreateFont
|
||||
dup win32-error=0/f ;
|
||||
|
||||
: cache-font ( font -- HFONT ) strip-font-colors (cache-font) ;
|
||||
|
||||
[ \ (cache-font) reset-memoized ] "windows.fonts" add-init-hook
|
||||
|
||||
: TEXTMETRIC>metrics ( TEXTMETRIC -- metrics )
|
||||
[ metrics new 0 >>width ] dip {
|
||||
[ TEXTMETRICW-tmHeight >>height ]
|
||||
[ TEXTMETRICW-tmAscent >>ascent ]
|
||||
[ TEXTMETRICW-tmDescent >>descent ]
|
||||
} cleave ;
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
IN: windows.offscreen.tests
|
||||
USING: windows.offscreen effects tools.test kernel images ;
|
||||
|
||||
{ 1 1 } [ [ [ ] make-bitmap-image ] with-memory-dc ] must-infer-as
|
||||
[ t ] [ [ { 10 10 } swap [ ] make-bitmap-image ] with-memory-dc image? ] unit-test
|
||||
|
|
@ -0,0 +1,53 @@
|
|||
! Copyright (C) 2009 Joe Groff, Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.c-types kernel combinators sequences
|
||||
math windows.gdi32 windows.types images destructors
|
||||
accessors fry locals ;
|
||||
IN: windows.offscreen
|
||||
|
||||
: (bitmap-info) ( dim -- BITMAPINFO )
|
||||
"BITMAPINFO" <c-object> [
|
||||
BITMAPINFO-bmiHeader {
|
||||
[ nip "BITMAPINFOHEADER" heap-size swap set-BITMAPINFOHEADER-biSize ]
|
||||
[ [ first ] dip set-BITMAPINFOHEADER-biWidth ]
|
||||
[ [ second ] dip set-BITMAPINFOHEADER-biHeight ]
|
||||
[ nip 1 swap set-BITMAPINFOHEADER-biPlanes ]
|
||||
[ nip 32 swap set-BITMAPINFOHEADER-biBitCount ]
|
||||
[ nip BI_RGB swap set-BITMAPINFOHEADER-biCompression ]
|
||||
[ [ first2 * 4 * ] dip set-BITMAPINFOHEADER-biSizeImage ]
|
||||
[ nip 72 swap set-BITMAPINFOHEADER-biXPelsPerMeter ]
|
||||
[ nip 72 swap set-BITMAPINFOHEADER-biYPelsPerMeter ]
|
||||
[ nip 0 swap set-BITMAPINFOHEADER-biClrUsed ]
|
||||
[ nip 0 swap set-BITMAPINFOHEADER-biClrImportant ]
|
||||
} 2cleave
|
||||
] keep ;
|
||||
|
||||
: make-bitmap ( dim dc -- hBitmap bits )
|
||||
[ nip ]
|
||||
[
|
||||
swap (bitmap-info) DIB_RGB_COLORS f <void*>
|
||||
[ f 0 CreateDIBSection ] keep *void*
|
||||
] 2bi
|
||||
[ [ SelectObject drop ] keep ] dip ;
|
||||
|
||||
: make-offscreen-dc-and-bitmap ( dim -- dc hBitmap bits )
|
||||
[ f CreateCompatibleDC ] dip over make-bitmap ;
|
||||
|
||||
: bitmap>byte-array ( bits dim -- byte-array )
|
||||
product 4 * memory>byte-array ;
|
||||
|
||||
: bitmap>image ( bits dim -- image )
|
||||
[ bitmap>byte-array ] keep
|
||||
<image>
|
||||
swap >>dim
|
||||
swap >>bitmap
|
||||
BGRX >>component-order
|
||||
t >>upside-down? ;
|
||||
|
||||
: with-memory-dc ( quot: ( hDC -- ) -- )
|
||||
[ [ f CreateCompatibleDC &DeleteDC ] dip call ] with-destructors ; inline
|
||||
|
||||
:: make-bitmap-image ( dim dc quot -- image )
|
||||
dim dc make-bitmap [ &DeleteObject drop ] dip
|
||||
quot dip
|
||||
dim bitmap>image ; inline
|
||||
|
|
@ -0,0 +1 @@
|
|||
Utility words for memory DCs and bitmaps
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax namespaces kernel words ;
|
||||
USING: alien alien.c-types alien.syntax namespaces kernel words
|
||||
sequences math math.bitwise math.vectors colors ;
|
||||
IN: windows.types
|
||||
|
||||
TYPEDEF: char CHAR
|
||||
|
|
@ -244,14 +245,14 @@ C-STRUCT: RECT
|
|||
{ "LONG" "right" }
|
||||
{ "LONG" "bottom" } ;
|
||||
|
||||
! C-STRUCT: PAINTSTRUCT
|
||||
! { "HDC" " hdc" }
|
||||
! { "BOOL" "fErase" }
|
||||
! { "RECT" "rcPaint" }
|
||||
! { "BOOL" "fRestore" }
|
||||
! { "BOOL" "fIncUpdate" }
|
||||
! { "BYTE[32]" "rgbReserved" }
|
||||
! ;
|
||||
C-STRUCT: PAINTSTRUCT
|
||||
{ "HDC" " hdc" }
|
||||
{ "BOOL" "fErase" }
|
||||
{ "RECT" "rcPaint" }
|
||||
{ "BOOL" "fRestore" }
|
||||
{ "BOOL" "fIncUpdate" }
|
||||
{ "BYTE[32]" "rgbReserved" }
|
||||
;
|
||||
|
||||
C-STRUCT: BITMAPINFOHEADER
|
||||
{ "DWORD" "biSize" }
|
||||
|
|
@ -283,6 +284,10 @@ C-STRUCT: POINT
|
|||
{ "LONG" "x" }
|
||||
{ "LONG" "y" } ;
|
||||
|
||||
C-STRUCT: SIZE
|
||||
{ "LONG" "cx" }
|
||||
{ "LONG" "cy" } ;
|
||||
|
||||
C-STRUCT: MSG
|
||||
{ "HWND" "hWnd" }
|
||||
{ "UINT" "message" }
|
||||
|
|
@ -327,6 +332,14 @@ C-STRUCT: RECT
|
|||
{ "LONG" "right" }
|
||||
{ "LONG" "bottom" } ;
|
||||
|
||||
: <RECT> ( loc dim -- RECT )
|
||||
over v+
|
||||
"RECT" <c-object>
|
||||
over first over set-RECT-right
|
||||
swap second over set-RECT-bottom
|
||||
over first over set-RECT-left
|
||||
swap second over set-RECT-top ;
|
||||
|
||||
TYPEDEF: RECT* PRECT
|
||||
TYPEDEF: RECT* LPRECT
|
||||
TYPEDEF: PIXELFORMATDESCRIPTOR PFD
|
||||
|
|
@ -363,3 +376,36 @@ C-STRUCT: ACCEL
|
|||
{ "WORD" "key" }
|
||||
{ "WORD" "cmd" } ;
|
||||
TYPEDEF: ACCEL* LPACCEL
|
||||
|
||||
TYPEDEF: DWORD COLORREF
|
||||
TYPEDEF: DWORD* LPCOLORREF
|
||||
|
||||
: RGB ( r g b -- COLORREF )
|
||||
{ 16 8 0 } bitfield ; inline
|
||||
|
||||
: color>RGB ( color -- COLORREF )
|
||||
>rgba-components drop [ 255 * >integer ] tri@ RGB ;
|
||||
|
||||
C-STRUCT: TEXTMETRICW
|
||||
{ "LONG" "tmHeight" }
|
||||
{ "LONG" "tmAscent" }
|
||||
{ "LONG" "tmDescent" }
|
||||
{ "LONG" "tmInternalLeading" }
|
||||
{ "LONG" "tmExternalLeading" }
|
||||
{ "LONG" "tmAveCharWidth" }
|
||||
{ "LONG" "tmMaxCharWidth" }
|
||||
{ "LONG" "tmWeight" }
|
||||
{ "LONG" "tmOverhang" }
|
||||
{ "LONG" "tmDigitizedAspectX" }
|
||||
{ "LONG" "tmDigitizedAspectY" }
|
||||
{ "WCHAR" "tmFirstChar" }
|
||||
{ "WCHAR" "tmLastChar" }
|
||||
{ "WCHAR" "tmDefaultChar" }
|
||||
{ "WCHAR" "tmBreakChar" }
|
||||
{ "BYTE" "tmItalic" }
|
||||
{ "BYTE" "tmUnderlined" }
|
||||
{ "BYTE" "tmStruckOut" }
|
||||
{ "BYTE" "tmPitchAndFamily" }
|
||||
{ "BYTE" "tmCharSet" } ;
|
||||
|
||||
TYPEDEF: TEXTMETRICW* LPTEXTMETRIC
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1 @@
|
|||
High-level wrapper around Uniscribe binding
|
||||
|
|
@ -0,0 +1 @@
|
|||
unportable
|
||||
|
|
@ -0,0 +1,118 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel assocs math sequences fry io.encodings.string
|
||||
io.encodings.utf16n accessors arrays combinators destructors locals
|
||||
cache namespaces init images.normalization fonts alien.c-types
|
||||
windows windows.usp10 windows.offscreen windows.gdi32
|
||||
windows.ole32 windows.types windows.fonts opengl.textures ;
|
||||
IN: windows.uniscribe
|
||||
|
||||
TUPLE: script-string font string metrics ssa size image disposed ;
|
||||
|
||||
: line-offset>x ( n script-string -- x )
|
||||
2dup string>> length = [
|
||||
ssa>> ! ssa
|
||||
swap 1- ! icp
|
||||
TRUE ! fTrailing
|
||||
] [
|
||||
ssa>>
|
||||
swap ! icp
|
||||
FALSE ! fTrailing
|
||||
] if
|
||||
0 <int> [ ScriptStringCPtoX ole32-error ] keep *int ;
|
||||
|
||||
: x>line-offset ( x script-string -- n trailing )
|
||||
ssa>> ! ssa
|
||||
swap ! iX
|
||||
0 <int> ! pCh
|
||||
0 <int> ! piTrailing
|
||||
[ ScriptStringXtoCP ole32-error ] 2keep [ *int ] bi@ ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: make-script-string ( dc string -- script-string )
|
||||
dup selection? [ string>> ] when
|
||||
[ utf16n encode ] ! pString
|
||||
[ length ] bi ! cString
|
||||
dup 1.5 * 16 + >integer ! cGlyphs -- MSDN says this is "recommended size"
|
||||
-1 ! iCharset -- Unicode
|
||||
SSA_GLYPHS ! dwFlags
|
||||
0 ! iReqWidth
|
||||
f ! psControl
|
||||
f ! psState
|
||||
f ! piDx
|
||||
f ! pTabdef
|
||||
f ! pbInClass
|
||||
f <void*> ! pssa
|
||||
[ ScriptStringAnalyse ] keep
|
||||
[ ole32-error ] [ |ScriptStringFree *void* ] bi* ;
|
||||
|
||||
: set-dc-colors ( dc font -- )
|
||||
[ background>> color>RGB SetBkColor drop ]
|
||||
[ foreground>> color>RGB SetTextColor drop ] 2bi ;
|
||||
|
||||
: selection-start/end ( script-string -- iMinSel iMaxSel )
|
||||
string>> dup selection? [ [ start>> ] [ end>> ] bi ] [ drop 0 0 ] if ;
|
||||
|
||||
: (draw-script-string) ( script-string -- )
|
||||
[
|
||||
ssa>> ! ssa
|
||||
0 ! iX
|
||||
0 ! iY
|
||||
0 ! uOptions
|
||||
f ! prc
|
||||
]
|
||||
[ selection-start/end ] bi
|
||||
! iMinSel
|
||||
! iMaxSel
|
||||
FALSE ! fDisabled
|
||||
ScriptStringOut ole32-error ;
|
||||
|
||||
: draw-script-string ( dc script-string -- )
|
||||
[ font>> set-dc-colors ] keep (draw-script-string) ;
|
||||
|
||||
: script-string-bitmap-size ( script-string -- dim )
|
||||
size>> dup small-texture? [ [ next-power-of-2 ] map ] when ;
|
||||
|
||||
:: make-script-string-image ( dc script-string -- image )
|
||||
script-string script-string-bitmap-size dc
|
||||
[ dc script-string draw-script-string ] make-bitmap-image ;
|
||||
|
||||
: set-dc-font ( dc font -- )
|
||||
cache-font SelectObject win32-error=0/f ;
|
||||
|
||||
: script-string-size ( script-string -- dim )
|
||||
ssa>> ScriptString_pSize
|
||||
dup win32-error=0/f
|
||||
[ SIZE-cx ] [ SIZE-cy ] bi 2array ;
|
||||
|
||||
: dc-metrics ( dc -- metrics )
|
||||
"TEXTMETRICW" <c-object>
|
||||
[ GetTextMetrics drop ] keep
|
||||
TEXTMETRIC>metrics ;
|
||||
|
||||
: <script-string> ( font string -- script-string )
|
||||
[ script-string new ] 2dip
|
||||
[ >>font ] [ >>string ] bi*
|
||||
[
|
||||
{
|
||||
[ over font>> set-dc-font ]
|
||||
[ dc-metrics >>metrics ]
|
||||
[ over string>> make-script-string >>ssa ]
|
||||
[ drop dup script-string-size >>size ]
|
||||
[ over make-script-string-image >>image ]
|
||||
} cleave
|
||||
] with-memory-dc ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
M: script-string dispose*
|
||||
ssa>> <void*> ScriptStringFree ole32-error ;
|
||||
|
||||
SYMBOL: cached-script-strings
|
||||
|
||||
: cached-script-string ( string font -- script-string )
|
||||
cached-script-strings get-global [ <script-string> ] 2cache ;
|
||||
|
||||
[ <cache-assoc> cached-script-strings set-global ]
|
||||
"windows.uniscribe" add-init-hook
|
||||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien.syntax ;
|
||||
USING: alien.syntax alien.destructors ;
|
||||
IN: windows.usp10
|
||||
|
||||
LIBRARY: usp10
|
||||
|
|
@ -262,6 +262,8 @@ FUNCTION: HRESULT ScriptStringFree (
|
|||
SCRIPT_STRING_ANALYSIS* pssa
|
||||
) ;
|
||||
|
||||
DESTRUCTOR: ScriptStringFree
|
||||
|
||||
FUNCTION: SIZE* ScriptString_pSize ( SCRIPT_STRING_ANALYSIS ssa ) ;
|
||||
|
||||
FUNCTION: int* ScriptString_pcOutChars ( SCRIPT_STRING_ANALYSIS ssa ) ;
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2005, 2006 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.syntax alien.c-types alien.strings arrays
|
||||
combinators kernel math namespaces parser prettyprint sequences
|
||||
combinators kernel math namespaces parser sequences
|
||||
windows.errors windows.types windows.kernel32 words
|
||||
io.encodings.utf16n ;
|
||||
IN: windows
|
||||
|
|
|
|||
|
|
@ -1,12 +0,0 @@
|
|||
libcairo-2.dll
|
||||
libgio-2.0-0.dll
|
||||
libglib-2.0-0.dll
|
||||
libgmodule-2.0-0.dll
|
||||
libgobject-2.0-0.dll
|
||||
libgthread-2.0-0.dll
|
||||
libpango-1.0-0.dll
|
||||
libpangocairo-1.0-0.dll
|
||||
libpangowin32-1.0-0.dll
|
||||
libpng12-0.dll
|
||||
libtiff3.dll
|
||||
zlib1.dll
|
||||
|
|
@ -445,16 +445,6 @@ get_url() {
|
|||
check_ret $DOWNLOADER
|
||||
}
|
||||
|
||||
maybe_download_dlls() {
|
||||
if [[ $OS == winnt ]] ; then
|
||||
for file in `cat build-support/dlls.txt`; do
|
||||
get_url http://factorcode.org/dlls/$file
|
||||
chmod 777 *.dll
|
||||
check_ret chmod
|
||||
done
|
||||
fi
|
||||
}
|
||||
|
||||
get_config_info() {
|
||||
find_build_info
|
||||
check_installed_programs
|
||||
|
|
@ -472,7 +462,6 @@ install() {
|
|||
cd_factor
|
||||
make_factor
|
||||
get_boot_image
|
||||
maybe_download_dlls
|
||||
bootstrap
|
||||
}
|
||||
|
||||
|
|
@ -547,7 +536,6 @@ case "$1" in
|
|||
update) update; update_bootstrap ;;
|
||||
bootstrap) get_config_info; bootstrap ;;
|
||||
report) find_build_info ;;
|
||||
dlls) get_config_info; maybe_download_dlls;;
|
||||
net-bootstrap) get_config_info; update_boot_images; bootstrap ;;
|
||||
make-target) ECHO=false; find_build_info; echo $MAKE_TARGET ;;
|
||||
*) usage ;;
|
||||
|
|
|
|||
|
|
@ -510,6 +510,7 @@ tuple
|
|||
{ "fputc" "io.streams.c" (( ch alien -- )) }
|
||||
{ "fwrite" "io.streams.c" (( string alien -- )) }
|
||||
{ "fflush" "io.streams.c" (( alien -- )) }
|
||||
{ "fseek" "io.streams.c" (( alien offset whence -- )) }
|
||||
{ "fclose" "io.streams.c" (( alien -- )) }
|
||||
{ "<wrapper>" "kernel" (( obj -- wrapper )) }
|
||||
{ "(clone)" "kernel" (( obj -- newobj )) }
|
||||
|
|
|
|||
|
|
@ -1,11 +1,24 @@
|
|||
! Copyright (C) 2004, 2008 Slava Pestov.
|
||||
! Copyright (C) 2004, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel kernel.private namespaces make io io.encodings
|
||||
sequences math generic threads.private classes io.backend
|
||||
io.files continuations destructors byte-arrays accessors ;
|
||||
io.files continuations destructors byte-arrays accessors
|
||||
combinators ;
|
||||
IN: io.streams.c
|
||||
|
||||
TUPLE: c-writer handle disposed ;
|
||||
TUPLE: c-stream handle disposed ;
|
||||
|
||||
M: c-stream dispose* handle>> fclose ;
|
||||
|
||||
M: c-stream stream-seek
|
||||
handle>> swap {
|
||||
{ seek-absolute [ 0 ] }
|
||||
{ seek-relative [ 1 ] }
|
||||
{ seek-end [ 2 ] }
|
||||
[ bad-seek-type ]
|
||||
} case fseek ;
|
||||
|
||||
TUPLE: c-writer < c-stream ;
|
||||
|
||||
: <c-writer> ( handle -- stream ) f c-writer boa ;
|
||||
|
||||
|
|
@ -17,9 +30,7 @@ M: c-writer stream-write dup check-disposed handle>> fwrite ;
|
|||
|
||||
M: c-writer stream-flush dup check-disposed handle>> fflush ;
|
||||
|
||||
M: c-writer dispose* handle>> fclose ;
|
||||
|
||||
TUPLE: c-reader handle disposed ;
|
||||
TUPLE: c-reader < c-stream ;
|
||||
|
||||
: <c-reader> ( handle -- stream ) f c-reader boa ;
|
||||
|
||||
|
|
@ -43,9 +54,6 @@ M: c-reader stream-read-until
|
|||
[ swap read-until-loop ] B{ } make swap
|
||||
over empty? over not and [ 2drop f f ] when ;
|
||||
|
||||
M: c-reader dispose*
|
||||
handle>> fclose ;
|
||||
|
||||
M: c-io-backend init-io ;
|
||||
|
||||
: stdin-handle ( -- alien ) 11 getenv ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,26 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test c.preprocessor kernel accessors multiline ;
|
||||
IN: c.preprocessor.tests
|
||||
|
||||
[ "vocab:c/tests/test1/test1.c" start-preprocess-file ]
|
||||
[ include-nested-too-deeply? ] must-fail-with
|
||||
|
||||
[ "yo\n\n\n\nyo4\n" ]
|
||||
[ "vocab:c/tests/test2/test2.c" start-preprocess-file nip ] unit-test
|
||||
|
||||
/*
|
||||
[ "vocab:c/tests/test3/test3.c" start-preprocess-file ]
|
||||
[ "\"BOO\"" = ] must-fail-with
|
||||
*/
|
||||
|
||||
[ V{ "\"omg\"" "\"lol\"" } ]
|
||||
[ "vocab:c/tests/test4/test4.c" start-preprocess-file drop warnings>> ] unit-test
|
||||
|
||||
|
||||
/*
|
||||
f(2 * (y+1)) + f(2 * (f(2 * (z[0])))) % f(2 * (0)) + t(1);
|
||||
f(2 * (2+(3,4)-0,1)) | f(2 * (~ 5)) & f(2 * (0,1))^m(0,1);
|
||||
int i[] = { 1, 23, 4, 5, };
|
||||
char c[2][6] = { "hello", "" };
|
||||
*/
|
||||
|
|
@ -0,0 +1,193 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: html.parser.state io io.encodings.utf8 io.files
|
||||
io.streams.string kernel combinators accessors io.pathnames
|
||||
fry sequences arrays locals namespaces io.directories
|
||||
assocs math splitting make unicode.categories
|
||||
combinators.short-circuit ;
|
||||
IN: c.preprocessor
|
||||
|
||||
: initial-library-paths ( -- seq )
|
||||
V{ "/usr/include" } clone ;
|
||||
|
||||
: initial-symbol-table ( -- hashtable )
|
||||
H{
|
||||
{ "__APPLE__" "" }
|
||||
{ "__amd64__" "" }
|
||||
{ "__x86_64__" "" }
|
||||
} clone ;
|
||||
|
||||
TUPLE: preprocessor-state library-paths symbol-table
|
||||
include-nesting include-nesting-max processing-disabled?
|
||||
ifdef-nesting warnings errors
|
||||
pragmas
|
||||
include-nexts
|
||||
ifs elifs elses ;
|
||||
|
||||
: <preprocessor-state> ( -- preprocessor-state )
|
||||
preprocessor-state new
|
||||
initial-library-paths >>library-paths
|
||||
initial-symbol-table >>symbol-table
|
||||
0 >>include-nesting
|
||||
200 >>include-nesting-max
|
||||
0 >>ifdef-nesting
|
||||
V{ } clone >>warnings
|
||||
V{ } clone >>errors
|
||||
V{ } clone >>pragmas
|
||||
V{ } clone >>include-nexts
|
||||
V{ } clone >>ifs
|
||||
V{ } clone >>elifs
|
||||
V{ } clone >>elses ;
|
||||
|
||||
DEFER: preprocess-file
|
||||
|
||||
ERROR: unknown-c-preprocessor state-parser name ;
|
||||
|
||||
ERROR: bad-include-line line ;
|
||||
|
||||
ERROR: header-file-missing path ;
|
||||
|
||||
:: read-standard-include ( preprocessor-state path -- )
|
||||
preprocessor-state dup library-paths>>
|
||||
[ path append-path exists? ] find nip
|
||||
[
|
||||
dup [
|
||||
path append-path
|
||||
preprocess-file
|
||||
] with-directory
|
||||
] [
|
||||
! path header-file-missing
|
||||
drop
|
||||
] if* ;
|
||||
|
||||
:: read-local-include ( preprocessor-state path -- )
|
||||
current-directory get path append-path dup :> full-path
|
||||
dup exists? [
|
||||
[ preprocessor-state ] dip preprocess-file
|
||||
] [
|
||||
! full-path header-file-missing
|
||||
drop
|
||||
] if ;
|
||||
|
||||
: handle-include ( preprocessor-state state-parser -- )
|
||||
skip-whitespace advance dup previous {
|
||||
{ CHAR: < [ CHAR: > take-until-object read-standard-include ] }
|
||||
{ CHAR: " [ CHAR: " take-until-object read-local-include ] }
|
||||
[ bad-include-line ]
|
||||
} case ;
|
||||
|
||||
: (readlns) ( -- )
|
||||
readln "\\" ?tail [ , ] dip [ (readlns) ] when ;
|
||||
|
||||
: readlns ( -- string ) [ (readlns) ] { } make concat ;
|
||||
|
||||
: take-define-identifier ( state-parser -- string )
|
||||
skip-whitespace
|
||||
[ current { [ blank? ] [ CHAR: ( = ] } 1|| ] take-until ;
|
||||
|
||||
: handle-define ( preprocessor-state state-parser -- )
|
||||
[ take-define-identifier ]
|
||||
[ skip-whitespace take-rest ] bi
|
||||
"\\" ?tail [ readlns append ] when
|
||||
spin symbol-table>> set-at ;
|
||||
|
||||
: handle-undef ( preprocessor-state state-parser -- )
|
||||
take-token swap symbol-table>> delete-at ;
|
||||
|
||||
: handle-ifdef ( preprocessor-state state-parser -- )
|
||||
[ [ 1 + ] change-ifdef-nesting ] dip
|
||||
take-token over symbol-table>> key?
|
||||
[ drop ] [ t >>processing-disabled? drop ] if ;
|
||||
|
||||
: handle-ifndef ( preprocessor-state state-parser -- )
|
||||
[ [ 1 + ] change-ifdef-nesting ] dip
|
||||
take-token over symbol-table>> key?
|
||||
[ t >>processing-disabled? drop ]
|
||||
[ drop ] if ;
|
||||
|
||||
: handle-endif ( preprocessor-state state-parser -- )
|
||||
drop [ 1 - ] change-ifdef-nesting drop ;
|
||||
|
||||
: handle-if ( preprocessor-state state-parser -- )
|
||||
[ [ 1 + ] change-ifdef-nesting ] dip
|
||||
skip-whitespace take-rest swap ifs>> push ;
|
||||
|
||||
: handle-elif ( preprocessor-state state-parser -- )
|
||||
skip-whitespace take-rest swap elifs>> push ;
|
||||
|
||||
: handle-else ( preprocessor-state state-parser -- )
|
||||
skip-whitespace take-rest swap elses>> push ;
|
||||
|
||||
: handle-pragma ( preprocessor-state state-parser -- )
|
||||
skip-whitespace take-rest swap pragmas>> push ;
|
||||
|
||||
: handle-include-next ( preprocessor-state state-parser -- )
|
||||
skip-whitespace take-rest swap include-nexts>> push ;
|
||||
|
||||
: handle-error ( preprocessor-state state-parser -- )
|
||||
skip-whitespace take-rest swap errors>> push ;
|
||||
! nip take-rest throw ;
|
||||
|
||||
: handle-warning ( preprocessor-state state-parser -- )
|
||||
skip-whitespace
|
||||
take-rest swap warnings>> push ;
|
||||
|
||||
: parse-directive ( preprocessor-state state-parser string -- )
|
||||
{
|
||||
{ "warning" [ handle-warning ] }
|
||||
{ "error" [ handle-error ] }
|
||||
{ "include" [ handle-include ] }
|
||||
{ "define" [ handle-define ] }
|
||||
{ "undef" [ handle-undef ] }
|
||||
{ "ifdef" [ handle-ifdef ] }
|
||||
{ "ifndef" [ handle-ifndef ] }
|
||||
{ "endif" [ handle-endif ] }
|
||||
{ "if" [ handle-if ] }
|
||||
{ "elif" [ handle-elif ] }
|
||||
{ "else" [ handle-else ] }
|
||||
{ "pragma" [ handle-pragma ] }
|
||||
{ "include_next" [ handle-include-next ] }
|
||||
[ unknown-c-preprocessor ]
|
||||
} case ;
|
||||
|
||||
: parse-directive-line ( preprocessor-state state-parser -- )
|
||||
advance dup take-token
|
||||
pick processing-disabled?>> [
|
||||
"endif" = [
|
||||
drop f >>processing-disabled?
|
||||
[ 1 - ] change-ifdef-nesting
|
||||
drop
|
||||
] [ 2drop ] if
|
||||
] [
|
||||
parse-directive
|
||||
] if ;
|
||||
|
||||
: preprocess-line ( preprocessor-state state-parser -- )
|
||||
skip-whitespace dup current CHAR: # =
|
||||
[ parse-directive-line ]
|
||||
[ swap processing-disabled?>> [ drop ] [ write-full nl ] if ] if ;
|
||||
|
||||
: preprocess-lines ( preprocessor-state -- )
|
||||
readln
|
||||
[ <state-parser> [ preprocess-line ] [ drop preprocess-lines ] 2bi ]
|
||||
[ drop ] if* ;
|
||||
|
||||
ERROR: include-nested-too-deeply ;
|
||||
|
||||
: check-nesting ( preprocessor-state -- preprocessor-state )
|
||||
[ 1 + ] change-include-nesting
|
||||
dup [ include-nesting>> ] [ include-nesting-max>> ] bi > [
|
||||
include-nested-too-deeply
|
||||
] when ;
|
||||
|
||||
: preprocess-file ( preprocessor-state path -- )
|
||||
[ check-nesting ] dip
|
||||
[ utf8 [ preprocess-lines ] with-file-reader ]
|
||||
[ drop [ 1 - ] change-include-nesting drop ] 2bi ;
|
||||
|
||||
: start-preprocess-file ( path -- preprocessor-state string )
|
||||
dup parent-directory [
|
||||
[
|
||||
[ <preprocessor-state> dup ] dip preprocess-file
|
||||
] with-string-writer
|
||||
] with-directory ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Tests if the preprocessor bails on an infinite loop caused by mutually recursive #include lines.
|
||||
|
|
@ -0,0 +1 @@
|
|||
#include "lo.h"
|
||||
|
|
@ -0,0 +1 @@
|
|||
#include "hi.h"
|
||||
|
|
@ -0,0 +1 @@
|
|||
#include "hi.h"
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
/*
|
||||
# lol
|
||||
*/
|
||||
|
|
@ -0,0 +1 @@
|
|||
foo.h ftw
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#define FOO_H "foo.h"
|
||||
#include FOO_H
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#if 4 > (5 - 4++)
|
||||
#error "Umm"
|
||||
#endif
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#if 10
|
||||
#error "Umm"
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
#if 4 > (1 + 2)
|
||||
good
|
||||
#endif
|
||||
|
||||
#if 4 > 1 + 2
|
||||
good
|
||||
#endif
|
||||
|
||||
#if (4 > 1) - 1
|
||||
bad
|
||||
#endif
|
||||
|
||||
#if (4 > 1) - 2
|
||||
good
|
||||
#endif
|
||||
|
|
@ -0,0 +1 @@
|
|||
Tests whether #define and #ifdef/#endif work in the positive case.
|
||||
|
|
@ -0,0 +1,17 @@
|
|||
#define YO
|
||||
#ifdef YO
|
||||
yo
|
||||
#endif
|
||||
|
||||
#define YO2
|
||||
#ifndef YO2
|
||||
yo2
|
||||
#endif
|
||||
|
||||
#ifdef YO3
|
||||
yo3
|
||||
#endif
|
||||
|
||||
#ifndef YO4
|
||||
yo4
|
||||
#endif
|
||||
|
|
@ -0,0 +1 @@
|
|||
Tests whether #define and #ifdef/#endif work in the positive case.
|
||||
|
|
@ -0,0 +1 @@
|
|||
#error "BOO"
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
#warning "omg"
|
||||
#warning "lol"
|
||||
|
|
@ -0,0 +1,3 @@
|
|||
#define TABSIZE 100
|
||||
|
||||
int table[TABSIZE];
|
||||
Some files were not shown because too many files have changed in this diff Show More
Loading…
Reference in New Issue