Merge branch 'master' of git://factorcode.org/git/factor
John Benediktsson
commit
853924077d
Binary file not shown.
8
Makefile
8
Makefile
|
|
@ -11,6 +11,7 @@ IMAGE = factor.image
|
|||
BUNDLE = Factor.app
|
||||
LIBPATH = -L/usr/X11R6/lib
|
||||
CFLAGS = -Wall
|
||||
FFI_TEST_CFLAGS = -fPIC
|
||||
|
||||
ifdef DEBUG
|
||||
CFLAGS += -g
|
||||
|
|
@ -140,9 +141,10 @@ wince-arm:
|
|||
|
||||
macosx.app: factor
|
||||
mkdir -p $(BUNDLE)/Contents/MacOS
|
||||
mkdir -p $(BUNDLE)/Contents/Frameworks
|
||||
mv $(EXECUTABLE) $(BUNDLE)/Contents/MacOS/factor
|
||||
ln -s Factor.app/Contents/MacOS/factor ./factor
|
||||
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks
|
||||
cp $(ENGINE) $(BUNDLE)/Contents/Frameworks/$(ENGINE)
|
||||
|
||||
install_name_tool \
|
||||
-change libfactor.dylib \
|
||||
|
|
@ -160,11 +162,11 @@ factor-console: $(DLL_OBJS) $(EXE_OBJS)
|
|||
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
|
||||
|
||||
factor-ffi-test: vm/ffi_test.o
|
||||
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(DLL_EXTENSION) $(TEST_OBJS)
|
||||
$(CC) $(LIBPATH) $(CFLAGS) $(FFI_TEST_CFLAGS) $(SHARED_FLAG) -o libfactor-ffi-test$(SHARED_DLL_EXTENSION) $(TEST_OBJS)
|
||||
|
||||
clean:
|
||||
rm -f vm/*.o
|
||||
rm -f factor*.dll libfactor.{a,so,dylib}
|
||||
rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib}
|
||||
|
||||
vm/resources.o:
|
||||
$(WINDRES) vm/factor.rs vm/resources.o
|
||||
|
|
|
|||
|
|
@ -9,11 +9,11 @@ IN: compiler.tests
|
|||
|
||||
<<
|
||||
: libfactor-ffi-tests-path ( -- string )
|
||||
"resource:" normalize-path
|
||||
"resource:" (normalize-path)
|
||||
{
|
||||
{ [ os winnt? ] [ "libfactor-ffi-test.dll" ] }
|
||||
{ [ os macosx? ] [ "libfactor-ffi-test.dylib" ] }
|
||||
{ [ os unix? ] [ "libfactor-ffi-test.a" ] }
|
||||
{ [ os unix? ] [ "libfactor-ffi-test.so" ] }
|
||||
} cond append-path ;
|
||||
|
||||
"f-cdecl" libfactor-ffi-tests-path "cdecl" add-library
|
||||
|
|
@ -124,8 +124,6 @@ unit-test
|
|||
"int" { "int" "int" "int" "int" } "stdcall" alien-indirect
|
||||
gc ;
|
||||
|
||||
LIBRARY: f-stdcall
|
||||
|
||||
[ f ] [ "f-stdcall" load-library f = ] unit-test
|
||||
[ "stdcall" ] [ "f-stdcall" library abi>> ] unit-test
|
||||
|
||||
|
|
@ -166,7 +164,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
|
|||
|
||||
: ffi_test_31 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result y )
|
||||
"int"
|
||||
"f-stdcall" "ffi_test_31"
|
||||
"f-cdecl" "ffi_test_31"
|
||||
{ "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" "int" }
|
||||
alien-invoke gc 3 ;
|
||||
|
||||
|
|
@ -174,7 +172,7 @@ FUNCTION: void ffi_test_20 double x1, double x2, double x3,
|
|||
|
||||
: ffi_test_31_point_5 ( a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a a -- result )
|
||||
"float"
|
||||
"f-stdcall" "ffi_test_31_point_5"
|
||||
"f-cdecl" "ffi_test_31_point_5"
|
||||
{ "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" "float" }
|
||||
alien-invoke ;
|
||||
|
||||
|
|
|
|||
|
|
@ -659,13 +659,40 @@ M: ppc %callback-value ( ctype -- )
|
|||
|
||||
M: ppc small-enough? ( n -- ? ) -32768 32767 between? ;
|
||||
|
||||
M: ppc return-struct-in-registers? ( c-type -- ? ) drop f ;
|
||||
M: ppc return-struct-in-registers? ( c-type -- ? )
|
||||
c-type return-in-registers?>> ;
|
||||
|
||||
M: ppc %box-small-struct
|
||||
drop "No small structs" throw ;
|
||||
M: ppc %box-small-struct ( c-type -- )
|
||||
#! Box a <= 16-byte struct returned in r3:r4:r5:r6
|
||||
heap-size 7 LI
|
||||
"box_medium_struct" f %alien-invoke ;
|
||||
|
||||
M: ppc %unbox-small-struct
|
||||
drop "No small structs" throw ;
|
||||
: %unbox-struct-1 ( -- )
|
||||
! Alien must be in r3.
|
||||
"alien_offset" f %alien-invoke
|
||||
3 3 0 LWZ ;
|
||||
|
||||
: %unbox-struct-2 ( -- )
|
||||
! Alien must be in r3.
|
||||
"alien_offset" f %alien-invoke
|
||||
4 3 4 LWZ
|
||||
3 3 0 LWZ ;
|
||||
|
||||
: %unbox-struct-4 ( -- )
|
||||
! Alien must be in r3.
|
||||
"alien_offset" f %alien-invoke
|
||||
6 3 12 LWZ
|
||||
5 3 8 LWZ
|
||||
4 3 4 LWZ
|
||||
3 3 0 LWZ ;
|
||||
|
||||
M: ppc %unbox-small-struct ( size -- )
|
||||
#! Alien must be in EAX.
|
||||
heap-size cell align cell /i {
|
||||
{ 1 [ %unbox-struct-1 ] }
|
||||
{ 2 [ %unbox-struct-2 ] }
|
||||
{ 4 [ %unbox-struct-4 ] }
|
||||
} case ;
|
||||
|
||||
USE: vocabs.loader
|
||||
|
||||
|
|
@ -673,3 +700,5 @@ USE: vocabs.loader
|
|||
{ [ os macosx? ] [ "cpu.ppc.macosx" require ] }
|
||||
{ [ os linux? ] [ "cpu.ppc.linux" require ] }
|
||||
} cond
|
||||
|
||||
"complex-double" c-type t >>return-in-registers? drop
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: farkup kernel peg peg.ebnf tools.test namespaces xml
|
||||
urls.encoding assocs xml.traversal xml.data ;
|
||||
urls.encoding assocs xml.traversal xml.data sequences random
|
||||
io continuations math ;
|
||||
IN: farkup.tests
|
||||
|
||||
relative-link-prefix off
|
||||
|
|
@ -180,3 +181,29 @@ link-no-follow? off
|
|||
[ "<p><em>italics<strong>both</strong></em>after<strong></strong></p>" ] [ "_italics*both_after*" convert-farkup ] unit-test
|
||||
[ "<table><tr><td>foo|bar</td></tr></table>" ] [ "|foo\\|bar|" convert-farkup ] unit-test
|
||||
[ "<p></p>" ] [ "\\" convert-farkup ] unit-test
|
||||
|
||||
[ "<p>[abc]</p>" ] [ "[abc]" convert-farkup ] unit-test
|
||||
|
||||
: random-markup ( -- string )
|
||||
10 [
|
||||
2 random 1 = [
|
||||
{
|
||||
"[["
|
||||
"*"
|
||||
"_"
|
||||
"|"
|
||||
"-"
|
||||
"[{"
|
||||
"\n"
|
||||
} random
|
||||
] [
|
||||
"abc"
|
||||
] if
|
||||
] replicate concat ;
|
||||
|
||||
[ t ] [
|
||||
100 [
|
||||
drop random-markup
|
||||
[ convert-farkup drop t ] [ drop print f ] recover
|
||||
] all?
|
||||
] unit-test
|
||||
|
|
|
|||
|
|
@ -75,7 +75,7 @@ DEFER: (parse-paragraph)
|
|||
"|" split1
|
||||
[ "" like dup simple-link-title ] unless*
|
||||
[ "image:" ?head ] dip swap [ image boa ] [ parse-paragraph link boa ] if
|
||||
] dip [ (parse-paragraph) cons ] when* ;
|
||||
] dip [ (parse-paragraph) cons ] [ 1list ] if* ;
|
||||
|
||||
: ?first ( seq -- elt ) 0 swap ?nth ;
|
||||
|
||||
|
|
@ -121,7 +121,7 @@ DEFER: (parse-paragraph)
|
|||
] if
|
||||
] if ;
|
||||
|
||||
: take-until ( state delimiter -- string/f state' )
|
||||
: take-until ( state delimiter -- string state'/f )
|
||||
V{ } clone (take-until) ;
|
||||
|
||||
: count= ( string -- n )
|
||||
|
|
@ -186,10 +186,12 @@ DEFER: (parse-paragraph)
|
|||
|
||||
: parse-code ( state -- state' item )
|
||||
dup 1 look CHAR: [ =
|
||||
[ unclip-slice make-paragraph ] [
|
||||
"{" take-until [ rest ] dip
|
||||
"}]" take-until
|
||||
[ code boa ] dip swap
|
||||
[ take-line make-paragraph ] [
|
||||
dup "{" take-until [
|
||||
[ nip rest ] dip
|
||||
"}]" take-until
|
||||
[ code boa ] dip swap
|
||||
] [ drop take-line make-paragraph ] if*
|
||||
] if ;
|
||||
|
||||
: parse-item ( state -- state' item )
|
||||
|
|
|
|||
|
|
@ -17,7 +17,14 @@ TIP: "You can write documentation for your own code using the " { $link "help" }
|
|||
TIP: "You can write graphical applications using the " { $link "ui" } "." ;
|
||||
|
||||
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." ;
|
||||
|
||||
HELP: TIP:
|
||||
{ $syntax "TIP: content ;" }
|
||||
{ $values { "content" "a markup element" } }
|
||||
{ $description "Defines a new tip of the day." } ;
|
||||
|
||||
ARTICLE: "all-tips-of-the-day" "All tips of the day"
|
||||
{ $tips-of-the-day } ;
|
||||
|
||||
|
|
|
|||
|
|
@ -1,14 +1,28 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: parser arrays namespaces sequences random help.markup kernel io
|
||||
io.styles colors.constants ;
|
||||
USING: parser arrays namespaces sequences random help.markup help.stylesheet
|
||||
kernel io io.styles colors.constants definitions accessors ;
|
||||
IN: help.tips
|
||||
|
||||
SYMBOL: tips
|
||||
|
||||
tips [ V{ } clone ] initialize
|
||||
|
||||
SYNTAX: TIP: parse-definition >array tips get push ;
|
||||
TUPLE: tip < identity-tuple content loc ;
|
||||
|
||||
M: tip forget* tips get delq ;
|
||||
|
||||
M: tip where loc>> ;
|
||||
|
||||
M: tip set-where (>>loc) ;
|
||||
|
||||
: <tip> ( content -- tip ) f tip boa ;
|
||||
|
||||
: add-tip ( tip -- ) tips get push ;
|
||||
|
||||
SYNTAX: TIP:
|
||||
parse-definition >array <tip>
|
||||
[ save-location ] [ add-tip ] bi ;
|
||||
|
||||
: a-tip ( -- tip ) tips get random ;
|
||||
|
||||
|
|
@ -20,13 +34,20 @@ H{
|
|||
{ wrap-margin 500 }
|
||||
} tip-of-the-day-style set-global
|
||||
|
||||
: $tip-title ( tip -- )
|
||||
[
|
||||
heading-style get [
|
||||
[ "Tip of the day" ] dip write-object
|
||||
] with-style
|
||||
] ($block) ;
|
||||
|
||||
: $tip-of-the-day ( element -- )
|
||||
drop
|
||||
[
|
||||
tip-of-the-day-style get
|
||||
[
|
||||
last-element off
|
||||
"Tip of the day" $heading a-tip print-element nl
|
||||
a-tip [ $tip-title ] [ content>> print-element nl ] bi
|
||||
"— " print-element "all-tips-of-the-day" ($link)
|
||||
]
|
||||
with-nesting
|
||||
|
|
@ -35,4 +56,6 @@ H{
|
|||
: tip-of-the-day. ( -- ) { $tip-of-the-day } print-content nl ;
|
||||
|
||||
: $tips-of-the-day ( element -- )
|
||||
drop tips get [ nl nl ] [ print-element ] interleave ;
|
||||
drop tips get [ nl nl ] [ content>> print-element ] interleave ;
|
||||
|
||||
INSTANCE: tip definition
|
||||
|
|
@ -7,8 +7,12 @@ IN: help.topics
|
|||
|
||||
TUPLE: link name ;
|
||||
|
||||
INSTANCE: link definition
|
||||
|
||||
MIXIN: topic
|
||||
|
||||
INSTANCE: link topic
|
||||
|
||||
INSTANCE: word topic
|
||||
|
||||
GENERIC: >link ( obj -- obj )
|
||||
|
|
|
|||
|
|
@ -34,16 +34,18 @@ M: object specializer-declaration class ;
|
|||
[ specializer-declaration ] map '[ _ declare ] pick append
|
||||
] { } map>assoc ;
|
||||
|
||||
: specialize-quot ( quot specializer -- quot' )
|
||||
specializer-cases alist>quot ;
|
||||
|
||||
: method-declaration ( method -- quot )
|
||||
[ "method-generic" word-prop dispatch# object <array> ]
|
||||
[ "method-class" word-prop ]
|
||||
bi prefix ;
|
||||
|
||||
: specialize-method ( quot method -- quot' )
|
||||
method-declaration '[ _ declare ] prepend ;
|
||||
|
||||
: specialize-quot ( quot specializer -- quot' )
|
||||
specializer-cases alist>quot ;
|
||||
[ method-declaration '[ _ declare ] prepend ]
|
||||
[ "method-generic" word-prop "specializer" word-prop ] bi
|
||||
[ specialize-quot ] when* ;
|
||||
|
||||
: standard-method? ( method -- ? )
|
||||
dup method-body? [
|
||||
|
|
@ -52,9 +54,11 @@ M: object specializer-declaration class ;
|
|||
|
||||
: specialized-def ( word -- quot )
|
||||
[ def>> ] keep
|
||||
[ dup standard-method? [ specialize-method ] [ drop ] if ]
|
||||
[ "specializer" word-prop [ specialize-quot ] when* ]
|
||||
bi ;
|
||||
dup generic? [ drop ] [
|
||||
[ dup standard-method? [ specialize-method ] [ drop ] if ]
|
||||
[ "specializer" word-prop [ specialize-quot ] when* ]
|
||||
bi
|
||||
] if ;
|
||||
|
||||
: specialized-length ( specializer -- n )
|
||||
dup [ array? ] all? [ first ] when length ;
|
||||
|
|
|
|||
|
|
@ -1,16 +1,14 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors grouping sequences combinators
|
||||
math specialized-arrays.direct.uint byte-arrays fry
|
||||
specialized-arrays.direct.ushort specialized-arrays.uint
|
||||
specialized-arrays.ushort specialized-arrays.float ;
|
||||
USING: combinators kernel ;
|
||||
IN: images
|
||||
|
||||
SINGLETONS: BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||
SINGLETONS: L BGR RGB BGRA RGBA ABGR ARGB RGBX XRGB BGRX XBGR
|
||||
R16G16B16 R32G32B32 R16G16B16A16 R32G32B32A32 ;
|
||||
|
||||
: bytes-per-pixel ( component-order -- n )
|
||||
{
|
||||
{ L [ 1 ] }
|
||||
{ BGR [ 3 ] }
|
||||
{ RGB [ 3 ] }
|
||||
{ BGRA [ 4 ] }
|
||||
|
|
@ -31,71 +29,4 @@ TUPLE: image dim component-order upside-down? bitmap ;
|
|||
|
||||
: <image> ( -- image ) image new ; inline
|
||||
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
||||
: add-dummy-alpha ( seq -- seq' )
|
||||
3 <groups> [ 255 suffix ] map concat ;
|
||||
|
||||
: normalize-floats ( byte-array -- byte-array )
|
||||
byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
|
||||
|
||||
GENERIC: normalize-component-order* ( image component-order -- image )
|
||||
|
||||
: normalize-component-order ( image -- image )
|
||||
dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
|
||||
|
||||
M: RGBA normalize-component-order* drop ;
|
||||
|
||||
M: R32G32B32A32 normalize-component-order*
|
||||
drop normalize-floats ;
|
||||
|
||||
M: R32G32B32 normalize-component-order*
|
||||
drop normalize-floats add-dummy-alpha ;
|
||||
|
||||
: RGB16>8 ( bitmap -- bitmap' )
|
||||
byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
|
||||
|
||||
M: R16G16B16A16 normalize-component-order*
|
||||
drop RGB16>8 ;
|
||||
|
||||
M: R16G16B16 normalize-component-order*
|
||||
drop RGB16>8 add-dummy-alpha ;
|
||||
|
||||
: BGR>RGB ( bitmap -- pixels )
|
||||
3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
|
||||
|
||||
: BGRA>RGBA ( bitmap -- pixels )
|
||||
4 <sliced-groups>
|
||||
[ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
|
||||
|
||||
M: BGRA normalize-component-order*
|
||||
drop BGRA>RGBA ;
|
||||
|
||||
M: RGB normalize-component-order*
|
||||
drop add-dummy-alpha ;
|
||||
|
||||
M: BGR normalize-component-order*
|
||||
drop BGR>RGB add-dummy-alpha ;
|
||||
|
||||
: ARGB>RGBA ( bitmap -- bitmap' )
|
||||
4 <groups> [ unclip suffix ] map B{ } join ; inline
|
||||
|
||||
M: ARGB normalize-component-order*
|
||||
drop ARGB>RGBA ;
|
||||
|
||||
M: ABGR normalize-component-order*
|
||||
drop ARGB>RGBA BGRA>RGBA ;
|
||||
|
||||
: normalize-scan-line-order ( image -- image )
|
||||
dup upside-down?>> [
|
||||
dup dim>> first 4 * '[
|
||||
_ <groups> reverse concat
|
||||
] change-bitmap
|
||||
f >>upside-down?
|
||||
] when ;
|
||||
|
||||
: normalize-image ( image -- image )
|
||||
[ >byte-array ] change-bitmap
|
||||
normalize-component-order
|
||||
normalize-scan-line-order
|
||||
RGBA >>component-order ;
|
||||
GENERIC: load-image* ( path tuple -- image )
|
||||
|
|
@ -1,7 +1,7 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: constructors kernel splitting unicode.case combinators
|
||||
accessors images.bitmap images.tiff images io.backend
|
||||
accessors images.bitmap images.tiff images images.normalization
|
||||
io.pathnames ;
|
||||
IN: images.loader
|
||||
|
||||
|
|
|
|||
|
|
@ -0,0 +1 @@
|
|||
Doug Coleman
|
||||
|
|
@ -0,0 +1,78 @@
|
|||
! Copyright (C) 2009 Doug Coleman
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: kernel accessors grouping sequences combinators
|
||||
math specialized-arrays.direct.uint byte-arrays fry
|
||||
specialized-arrays.direct.ushort specialized-arrays.uint
|
||||
specialized-arrays.ushort specialized-arrays.float images ;
|
||||
IN: images.normalization
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: add-dummy-alpha ( seq -- seq' )
|
||||
3 <groups> [ 255 suffix ] map concat ;
|
||||
|
||||
: normalize-floats ( byte-array -- byte-array )
|
||||
byte-array>float-array [ 255.0 * >integer ] B{ } map-as ;
|
||||
|
||||
GENERIC: normalize-component-order* ( image component-order -- image )
|
||||
|
||||
: normalize-component-order ( image -- image )
|
||||
dup component-order>> '[ _ normalize-component-order* ] change-bitmap ;
|
||||
|
||||
M: RGBA normalize-component-order* drop ;
|
||||
|
||||
M: R32G32B32A32 normalize-component-order*
|
||||
drop normalize-floats ;
|
||||
|
||||
M: R32G32B32 normalize-component-order*
|
||||
drop normalize-floats add-dummy-alpha ;
|
||||
|
||||
: RGB16>8 ( bitmap -- bitmap' )
|
||||
byte-array>ushort-array [ -8 shift ] B{ } map-as ; inline
|
||||
|
||||
M: R16G16B16A16 normalize-component-order*
|
||||
drop RGB16>8 ;
|
||||
|
||||
M: R16G16B16 normalize-component-order*
|
||||
drop RGB16>8 add-dummy-alpha ;
|
||||
|
||||
: BGR>RGB ( bitmap -- pixels )
|
||||
3 <sliced-groups> [ <reversed> ] map B{ } join ; inline
|
||||
|
||||
: BGRA>RGBA ( bitmap -- pixels )
|
||||
4 <sliced-groups>
|
||||
[ unclip-last-slice [ <reversed> ] dip suffix ] map concat ; inline
|
||||
|
||||
M: BGRA normalize-component-order*
|
||||
drop BGRA>RGBA ;
|
||||
|
||||
M: RGB normalize-component-order*
|
||||
drop add-dummy-alpha ;
|
||||
|
||||
M: BGR normalize-component-order*
|
||||
drop BGR>RGB add-dummy-alpha ;
|
||||
|
||||
: ARGB>RGBA ( bitmap -- bitmap' )
|
||||
4 <groups> [ unclip suffix ] map B{ } join ; inline
|
||||
|
||||
M: ARGB normalize-component-order*
|
||||
drop ARGB>RGBA ;
|
||||
|
||||
M: ABGR normalize-component-order*
|
||||
drop ARGB>RGBA BGRA>RGBA ;
|
||||
|
||||
: normalize-scan-line-order ( image -- image )
|
||||
dup upside-down?>> [
|
||||
dup dim>> first 4 * '[
|
||||
_ <groups> reverse concat
|
||||
] change-bitmap
|
||||
f >>upside-down?
|
||||
] when ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: normalize-image ( image -- image )
|
||||
[ >byte-array ] change-bitmap
|
||||
normalize-component-order
|
||||
normalize-scan-line-order
|
||||
RGBA >>component-order ;
|
||||
|
|
@ -0,0 +1 @@
|
|||
Slava Pestov
|
||||
|
|
@ -0,0 +1,46 @@
|
|||
USING: images accessors kernel tools.test literals math.ranges
|
||||
byte-arrays ;
|
||||
IN: images.tesselation
|
||||
|
||||
! Check an invariant we depend on
|
||||
[ t ] [
|
||||
<image> B{ 1 2 3 } >>bitmap dup clone [ bitmap>> ] bi@ eq?
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{
|
||||
T{ image f { 2 2 } L f B{ 1 2 5 6 } }
|
||||
T{ image f { 2 2 } L f B{ 3 4 7 8 } }
|
||||
}
|
||||
{
|
||||
T{ image f { 2 2 } L f B{ 9 10 13 14 } }
|
||||
T{ image f { 2 2 } L f B{ 11 12 15 16 } }
|
||||
}
|
||||
}
|
||||
] [
|
||||
<image>
|
||||
1 16 [a,b] >byte-array >>bitmap
|
||||
{ 4 4 } >>dim
|
||||
L >>component-order
|
||||
{ 2 2 } tesselate
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{
|
||||
T{ image f { 2 2 } L f B{ 1 2 4 5 } }
|
||||
T{ image f { 1 2 } L f B{ 3 6 } }
|
||||
}
|
||||
{
|
||||
T{ image f { 2 1 } L f B{ 7 8 } }
|
||||
T{ image f { 1 1 } L f B{ 9 } }
|
||||
}
|
||||
}
|
||||
] [
|
||||
<image>
|
||||
1 9 [a,b] >byte-array >>bitmap
|
||||
{ 3 3 } >>dim
|
||||
L >>component-order
|
||||
{ 2 2 } tesselate
|
||||
] unit-test
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: sequences kernel math grouping fry columns locals accessors
|
||||
images math math.vectors arrays ;
|
||||
IN: images.tesselation
|
||||
|
||||
: group-rows ( bitmap bitmap-dim -- rows )
|
||||
first <sliced-groups> ; inline
|
||||
|
||||
: tesselate-rows ( bitmap-rows tess-dim -- bitmaps )
|
||||
second <sliced-groups> ; inline
|
||||
|
||||
: tesselate-columns ( bitmap-rows tess-dim -- bitmaps )
|
||||
first '[ _ <sliced-groups> ] map flip ; inline
|
||||
|
||||
: tesselate-bitmap ( bitmap bitmap-dim tess-dim -- bitmap-grid )
|
||||
[ group-rows ] dip
|
||||
[ tesselate-rows ] keep
|
||||
'[ _ tesselate-columns ] map ;
|
||||
|
||||
: tile-width ( tile-bitmap original-image -- width )
|
||||
[ first length ] [ component-order>> bytes-per-pixel ] bi* /i ;
|
||||
|
||||
: <tile-image> ( tile-bitmap original-image -- tile-image )
|
||||
clone
|
||||
swap
|
||||
[ concat >>bitmap ]
|
||||
[ [ over tile-width ] [ length ] bi 2array >>dim ] bi ;
|
||||
|
||||
:: tesselate ( image tess-dim -- image-grid )
|
||||
image component-order>> bytes-per-pixel :> bpp
|
||||
image dim>> { bpp 1 } v* :> image-dim'
|
||||
tess-dim { bpp 1 } v* :> tess-dim'
|
||||
image bitmap>> image-dim' tess-dim' tesselate-bitmap
|
||||
[ [ image <tile-image> ] map ] map ;
|
||||
|
|
@ -65,9 +65,9 @@ ERROR: file-not-found ;
|
|||
_ [ _ _ find-file [ file-not-found ] unless* ] attempt-all
|
||||
] [
|
||||
drop f
|
||||
] recover ;
|
||||
] recover ; inline
|
||||
|
||||
: find-all-in-directories ( directories bfs? quot: ( obj -- ? ) -- paths/f )
|
||||
'[ _ _ find-all-files ] map concat ;
|
||||
'[ _ _ find-all-files ] map concat ; inline
|
||||
|
||||
os windows? [ "io.directories.search.windows" require ] when
|
||||
|
|
|
|||
|
|
@ -1,5 +1,5 @@
|
|||
USING: tools.test io.streams.byte-array io.encodings.binary
|
||||
io.encodings.utf8 io kernel arrays strings ;
|
||||
io.encodings.utf8 io kernel arrays strings namespaces ;
|
||||
|
||||
[ B{ 1 2 3 } ] [ binary [ { 1 2 3 } write ] with-byte-writer ] unit-test
|
||||
[ B{ 1 2 3 } ] [ { 1 2 3 } binary [ 3 read ] with-byte-reader ] unit-test
|
||||
|
|
@ -7,3 +7,23 @@ io.encodings.utf8 io kernel arrays strings ;
|
|||
[ B{ BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 BIN: 11101111 BIN: 10000000 BIN: 10111111 BIN: 11011111 BIN: 10000000 CHAR: x } ]
|
||||
[ { BIN: 101111111000000111111 BIN: 1111000000111111 BIN: 11111000000 CHAR: x } utf8 [ write ] with-byte-writer ] unit-test
|
||||
[ { BIN: 101111111000000111111 } t ] [ { BIN: 11110101 BIN: 10111111 BIN: 10000000 BIN: 10111111 } utf8 <byte-reader> contents dup >array swap string? ] unit-test
|
||||
|
||||
[ B{ 121 120 } 0 ] [
|
||||
B{ 0 121 120 0 0 0 0 0 0 } binary
|
||||
[ 1 read drop "\0" read-until ] with-byte-reader
|
||||
] unit-test
|
||||
|
||||
[ 1 1 4 11 f ] [
|
||||
B{ 1 2 3 4 5 6 7 8 9 10 11 12 } binary
|
||||
[
|
||||
read1
|
||||
0 seek-absolute input-stream get stream-seek
|
||||
read1
|
||||
2 seek-relative input-stream get stream-seek
|
||||
read1
|
||||
-2 seek-end input-stream get stream-seek
|
||||
read1
|
||||
0 seek-end input-stream get stream-seek
|
||||
read1
|
||||
] with-byte-reader
|
||||
] unit-test
|
||||
|
|
@ -28,7 +28,7 @@ M: byte-reader stream-seek ( n seek-type stream -- )
|
|||
swap {
|
||||
{ seek-absolute [ (>>i) ] }
|
||||
{ seek-relative [ [ + ] change-i drop ] }
|
||||
{ seek-end [ dup underlying>> length >>i [ + ] change-i drop ] }
|
||||
{ seek-end [ [ underlying>> length + ] keep (>>i) ] }
|
||||
[ bad-seek-type ]
|
||||
} case ;
|
||||
|
||||
|
|
|
|||
|
|
@ -37,7 +37,7 @@ IN: math.bitwise
|
|||
|
||||
! flags
|
||||
MACRO: flags ( values -- )
|
||||
[ 0 ] [ [ dup word? [ execute ] when bitor ] curry compose ] reduce ;
|
||||
[ 0 ] [ [ ?execute bitor ] curry compose ] reduce ;
|
||||
|
||||
! bitfield
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -7,7 +7,11 @@ IN: math.blas.ffi
|
|||
{ [ 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? ] [ "libblas.so" gfortran-abi add-fortran-library ] }
|
||||
{
|
||||
[ os [ freebsd? ] [ linux? cpu x86.32? and ] bi or ]
|
||||
[ "libblas.so" gfortran-abi add-fortran-library ]
|
||||
}
|
||||
{ [ os [ freebsd? ] [ linux? ] bi or ] [ "libblas.so" gfortran-abi add-fortran-library ] }
|
||||
[ "libblas.so" f2c-abi add-fortran-library ]
|
||||
} cond
|
||||
>>
|
||||
|
|
|
|||
|
|
@ -5,12 +5,13 @@ IN: models
|
|||
HELP: model
|
||||
{ $class-description "A mutable cell holding a single value. When the value is changed, a sequence of connected objects are notified. Models have the following slots:"
|
||||
{ $list
|
||||
{ { $snippet "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
|
||||
{ { $snippet "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
|
||||
{ { $snippet "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
|
||||
{ { $snippet "ref" } " - a reference count tracking the number of models which depend on this one." }
|
||||
{ { $slot "value" } " - the value of the model. Use " { $link set-model } " to change the value." }
|
||||
{ { $slot "connections" } " - a sequence of objects implementing the " { $link model-changed } " generic word, to be notified when the model's value changes." }
|
||||
{ { $slot "dependencies" } " - a sequence of models which should have this model added to their sequence of connections when activated." }
|
||||
{ { $slot "ref" } " - a reference count tracking the number of models which depend on this one." }
|
||||
{ { $slot "locked?" } " - a slot set by " { $link with-locked-model } " to ensure that the model doesn't get changed recursively" }
|
||||
}
|
||||
"Other classes may delegate to " { $link model } "."
|
||||
"Other classes may inherit from " { $link model } "."
|
||||
} ;
|
||||
|
||||
HELP: <model>
|
||||
|
|
|
|||
|
|
@ -23,11 +23,11 @@ HELP: gl-line
|
|||
{ $description "Draws a line between two points." } ;
|
||||
|
||||
HELP: gl-fill-rect
|
||||
{ $values { "dim" "a pair of integers" } }
|
||||
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
|
||||
{ $description "Draws a filled rectangle with the top-left corner at the origin and the given dimensions." } ;
|
||||
|
||||
HELP: gl-rect
|
||||
{ $values { "dim" "a pair of integers" } }
|
||||
{ $values { "loc" "a pair of integers" } { "dim" "a pair of integers" } }
|
||||
{ $description "Draws the outline of a rectangle with the top-left corner at the origin and the given dimensions." } ;
|
||||
|
||||
HELP: gen-gl-buffer
|
||||
|
|
|
|||
|
|
@ -3,8 +3,8 @@
|
|||
! Portions copyright (C) 2008 Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: alien alien.c-types continuations kernel libc math macros
|
||||
namespaces math.vectors math.parser opengl.gl opengl.glu
|
||||
combinators arrays sequences splitting words byte-arrays assocs
|
||||
namespaces math.vectors math.parser opengl.gl opengl.glu combinators
|
||||
combinators.smart arrays sequences splitting words byte-arrays assocs
|
||||
colors colors.constants accessors generalizations locals fry
|
||||
specialized-arrays.float specialized-arrays.uint ;
|
||||
IN: opengl
|
||||
|
|
@ -28,7 +28,7 @@ IN: opengl
|
|||
over glEnableClientState dip glDisableClientState ; inline
|
||||
|
||||
: words>values ( word/value-seq -- value-seq )
|
||||
[ dup word? [ execute ] when ] map ;
|
||||
[ ?execute ] map ;
|
||||
|
||||
: (all-enabled) ( seq quot -- )
|
||||
over [ glEnable ] each dip [ glDisable ] each ; inline
|
||||
|
|
@ -67,42 +67,46 @@ MACRO: all-enabled-client-state ( seq quot -- )
|
|||
: gl-line ( a b -- )
|
||||
line-vertices GL_LINES 0 2 glDrawArrays ;
|
||||
|
||||
: (rect-vertices) ( dim -- vertices )
|
||||
:: (rect-vertices) ( loc dim -- vertices )
|
||||
#! We use GL_LINE_STRIP with a duplicated first vertex
|
||||
#! instead of GL_LINE_LOOP to work around a bug in Apple's
|
||||
#! X3100 driver.
|
||||
{
|
||||
[ drop 0.5 0.5 ]
|
||||
[ first 0.3 - 0.5 ]
|
||||
[ [ first 0.3 - ] [ second 0.3 - ] bi ]
|
||||
[ second 0.3 - 0.5 swap ]
|
||||
[ drop 0.5 0.5 ]
|
||||
} cleave 10 float-array{ } nsequence ;
|
||||
loc first2 :> y :> x
|
||||
dim first2 :> h :> w
|
||||
[
|
||||
x 0.5 + y 0.5 +
|
||||
x w + 0.3 - y 0.5 +
|
||||
x w + 0.3 - y h + 0.3 -
|
||||
x y h + 0.3 -
|
||||
x 0.5 + y 0.5 +
|
||||
] float-array{ } output>sequence ;
|
||||
|
||||
: rect-vertices ( dim -- )
|
||||
: rect-vertices ( loc dim -- )
|
||||
(rect-vertices) gl-vertex-pointer ;
|
||||
|
||||
: (gl-rect) ( -- )
|
||||
GL_LINE_STRIP 0 5 glDrawArrays ;
|
||||
|
||||
: gl-rect ( dim -- )
|
||||
: gl-rect ( loc dim -- )
|
||||
rect-vertices (gl-rect) ;
|
||||
|
||||
: (fill-rect-vertices) ( dim -- vertices )
|
||||
{
|
||||
[ drop 0 0 ]
|
||||
[ first 0 ]
|
||||
[ first2 ]
|
||||
[ second 0 swap ]
|
||||
} cleave 8 float-array{ } nsequence ;
|
||||
:: (fill-rect-vertices) ( loc dim -- vertices )
|
||||
loc first2 :> y :> x
|
||||
dim first2 :> h :> w
|
||||
[
|
||||
x y
|
||||
x w + y
|
||||
x w + y h +
|
||||
x y h +
|
||||
] float-array{ } output>sequence ;
|
||||
|
||||
: fill-rect-vertices ( dim -- )
|
||||
: fill-rect-vertices ( loc dim -- )
|
||||
(fill-rect-vertices) gl-vertex-pointer ;
|
||||
|
||||
: (gl-fill-rect) ( -- )
|
||||
GL_QUADS 0 4 glDrawArrays ;
|
||||
|
||||
: gl-fill-rect ( dim -- )
|
||||
: gl-fill-rect ( loc dim -- )
|
||||
fill-rect-vertices (gl-fill-rect) ;
|
||||
|
||||
: do-attribs ( bits quot -- )
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test opengl.textures opengl.textures.private
|
||||
images kernel namespaces ;
|
||||
opengl.textures.private images kernel namespaces accessors
|
||||
sequences ;
|
||||
IN: opengl.textures.tests
|
||||
|
||||
[ ] [
|
||||
|
|
@ -52,4 +53,17 @@ IN: opengl.textures.tests
|
|||
{ component-order R32G32B32 }
|
||||
{ bitmap B{ } }
|
||||
} power-of-2-image
|
||||
] unit-test
|
||||
|
||||
[
|
||||
{
|
||||
{ { 0 0 } { 10 0 } }
|
||||
{ { 0 20 } { 10 20 } }
|
||||
}
|
||||
] [
|
||||
{
|
||||
{ { 10 20 } { 30 20 } }
|
||||
{ { 10 30 } { 30 300 } }
|
||||
}
|
||||
[ [ image new swap >>dim ] map ] map image-locs
|
||||
] unit-test
|
||||
|
|
@ -1,16 +1,15 @@
|
|||
! Copyright (C) 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors assocs cache colors.constants destructors fry kernel
|
||||
opengl opengl.gl combinators images grouping specialized-arrays.float
|
||||
locals sequences math math.vectors generalizations ;
|
||||
opengl opengl.gl combinators images images.tesselation grouping
|
||||
specialized-arrays.float locals sequences math math.vectors
|
||||
math.matrices generalizations fry columns ;
|
||||
IN: opengl.textures
|
||||
|
||||
: gen-texture ( -- id ) [ glGenTextures ] (gen-gl-object) ;
|
||||
|
||||
: delete-texture ( id -- ) [ glDeleteTextures ] (delete-gl-object) ;
|
||||
|
||||
TUPLE: texture loc dim texture-coords texture display-list disposed ;
|
||||
|
||||
GENERIC: component-order>format ( component-order -- format type )
|
||||
|
||||
M: RGB component-order>format drop GL_RGB GL_UNSIGNED_BYTE ;
|
||||
|
|
@ -19,8 +18,14 @@ 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 ;
|
||||
|
||||
GENERIC: draw-texture ( texture -- )
|
||||
|
||||
GENERIC: draw-scaled-texture ( dim texture -- )
|
||||
|
||||
<PRIVATE
|
||||
|
||||
TUPLE: single-texture loc dim texture-coords texture display-list disposed ;
|
||||
|
||||
: repeat-last ( seq n -- seq' )
|
||||
over peek pad-tail concat ;
|
||||
|
||||
|
|
@ -69,20 +74,27 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
|
|||
GL_TEXTURE_2D GL_TEXTURE_WRAP_S GL_REPEAT glTexParameteri
|
||||
GL_TEXTURE_2D GL_TEXTURE_WRAP_T GL_REPEAT glTexParameteri ;
|
||||
|
||||
: draw-textured-rect ( dim texture -- )
|
||||
: with-texturing ( quot -- )
|
||||
GL_TEXTURE_2D [
|
||||
GL_TEXTURE_BIT [
|
||||
GL_TEXTURE_COORD_ARRAY [
|
||||
COLOR: white gl-color
|
||||
dup loc>> [
|
||||
[ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
|
||||
[ init-texture texture-coords>> gl-texture-coord-pointer ] bi
|
||||
fill-rect-vertices (gl-fill-rect)
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] with-translation
|
||||
call
|
||||
] do-enabled-client-state
|
||||
] do-attribs
|
||||
] do-enabled ;
|
||||
] do-enabled ; inline
|
||||
|
||||
: (draw-textured-rect) ( dim texture -- )
|
||||
[ loc>> ]
|
||||
[ [ GL_TEXTURE_2D ] dip texture>> glBindTexture ]
|
||||
[ init-texture texture-coords>> gl-texture-coord-pointer ] tri
|
||||
swap gl-fill-rect ;
|
||||
|
||||
: draw-textured-rect ( dim texture -- )
|
||||
[
|
||||
(draw-textured-rect)
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] with-texturing ;
|
||||
|
||||
: texture-coords ( dim -- coords )
|
||||
[ dup next-power-of-2 /f ] map
|
||||
|
|
@ -92,10 +104,8 @@ M: BGRA component-order>format drop GL_BGRA_EXT GL_UNSIGNED_BYTE ;
|
|||
: make-texture-display-list ( texture -- dlist )
|
||||
GL_COMPILE [ [ dim>> ] keep draw-textured-rect ] make-dlist ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <texture> ( image loc -- texture )
|
||||
texture new swap >>loc
|
||||
: <single-texture> ( image loc -- texture )
|
||||
single-texture new swap >>loc
|
||||
swap
|
||||
[ dim>> >>dim ] keep
|
||||
[ dim>> product 0 = ] keep '[
|
||||
|
|
@ -105,12 +115,59 @@ PRIVATE>
|
|||
dup make-texture-display-list >>display-list
|
||||
] unless ;
|
||||
|
||||
M: texture dispose*
|
||||
M: single-texture dispose*
|
||||
[ texture>> [ delete-texture ] when* ]
|
||||
[ display-list>> [ delete-dlist ] when* ] bi ;
|
||||
|
||||
: draw-texture ( texture -- )
|
||||
display-list>> [ glCallList ] when* ;
|
||||
M: single-texture draw-texture display-list>> [ glCallList ] when* ;
|
||||
|
||||
: draw-scaled-texture ( dim texture -- )
|
||||
dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
|
||||
M: single-texture draw-scaled-texture
|
||||
dup texture>> [ draw-textured-rect ] [ 2drop ] if ;
|
||||
|
||||
TUPLE: multi-texture grid display-list loc disposed ;
|
||||
|
||||
: image-locs ( image-grid -- loc-grid )
|
||||
[ first [ dim>> first ] map ] [ 0 <column> [ dim>> second ] map ] bi
|
||||
[ 0 [ + ] accumulate nip ] bi@
|
||||
cross-zip flip ;
|
||||
|
||||
: <texture-grid> ( image-grid loc -- grid )
|
||||
[ dup image-locs ] dip
|
||||
'[ [ _ v+ <single-texture> |dispose ] 2map ] 2map ;
|
||||
|
||||
: draw-textured-grid ( grid -- )
|
||||
[ [ [ dim>> ] keep (draw-textured-rect) ] each ] each ;
|
||||
|
||||
: make-textured-grid-display-list ( grid -- dlist )
|
||||
GL_COMPILE [
|
||||
[
|
||||
[
|
||||
[
|
||||
[ dim>> ] keep (draw-textured-rect)
|
||||
] each
|
||||
] each
|
||||
GL_TEXTURE_2D 0 glBindTexture
|
||||
] with-texturing
|
||||
] make-dlist ;
|
||||
|
||||
: <multi-texture> ( image-grid loc -- multi-texture )
|
||||
[
|
||||
[
|
||||
<texture-grid> dup
|
||||
make-textured-grid-display-list
|
||||
] keep
|
||||
f multi-texture boa
|
||||
] with-destructors ;
|
||||
|
||||
M: multi-texture draw-texture display-list>> [ glCallList ] when* ;
|
||||
|
||||
M: multi-texture dispose* grid>> [ [ dispose ] each ] each ;
|
||||
|
||||
CONSTANT: max-texture-size { 256 256 }
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: <texture> ( image loc -- texture )
|
||||
over dim>> max-texture-size [ <= ] 2all?
|
||||
[ <single-texture> ]
|
||||
[ [ max-texture-size tesselate ] dip <multi-texture> ] if ;
|
||||
|
|
@ -84,21 +84,24 @@ C: <box> box
|
|||
{ } assoc-like [ first integer? ] partition
|
||||
[ [ literals>cases ] keep ] dip non-literals>dispatch ;
|
||||
|
||||
:: step ( last-match index str quot final? direction -- last-index/f )
|
||||
: advance ( index backwards? -- index+/-1 )
|
||||
-1 1 ? + >fixnum ; inline
|
||||
|
||||
: check ( index string backwards? -- in-bounds? )
|
||||
[ drop -1 eq? not ] [ length < ] if ; inline
|
||||
|
||||
:: step ( last-match index str quot final? backwards? -- last-index/f )
|
||||
final? index last-match ?
|
||||
index str bounds-check? [
|
||||
index direction + str
|
||||
index str backwards? check [
|
||||
index backwards? advance str
|
||||
index str nth-unsafe
|
||||
quot call
|
||||
] when ; inline
|
||||
|
||||
: direction ( -- n )
|
||||
backwards? get -1 1 ? ;
|
||||
|
||||
: transitions>quot ( transitions final-state? -- quot )
|
||||
dup shortest? get and [ 2drop [ drop nip ] ] [
|
||||
[ split-literals swap case>quot ] dip direction
|
||||
'[ { array-capacity string } declare _ _ _ step ]
|
||||
[ split-literals swap case>quot ] dip backwards? get
|
||||
'[ { fixnum string } declare _ _ _ step ]
|
||||
] if ;
|
||||
|
||||
: word>quot ( word dfa -- quot )
|
||||
|
|
@ -122,10 +125,13 @@ C: <box> box
|
|||
: dfa>main-word ( dfa -- word )
|
||||
states>words [ states>code ] keep start-state>> ;
|
||||
|
||||
: word-template ( quot -- quot' )
|
||||
'[ drop [ f ] 2dip over array-capacity? _ [ 2drop ] if ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: dfa>word ( dfa -- quot )
|
||||
dfa>main-word execution-quot '[ drop [ f ] 2dip @ ]
|
||||
dfa>main-word execution-quot word-template
|
||||
(( start-index string regexp -- i/f )) define-temp ;
|
||||
|
||||
: dfa>shortest-word ( dfa -- word )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax kernel math ;
|
||||
USING: help.markup help.syntax kernel math strings ;
|
||||
IN: roman
|
||||
|
||||
HELP: >roman
|
||||
|
|
@ -39,7 +39,7 @@ HELP: roman>
|
|||
{ >roman >ROMAN roman> } related-words
|
||||
|
||||
HELP: roman+
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
|
||||
{ $values { "string" string } { "string" string } { "string" string } }
|
||||
{ $description "Adds two Roman numerals." }
|
||||
{ $examples
|
||||
{ $example "USING: io roman ;"
|
||||
|
|
@ -49,7 +49,7 @@ HELP: roman+
|
|||
} ;
|
||||
|
||||
HELP: roman-
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
|
||||
{ $values { "string" string } { "string" string } { "string" string } }
|
||||
{ $description "Subtracts two Roman numerals." }
|
||||
{ $examples
|
||||
{ $example "USING: io roman ;"
|
||||
|
|
@ -61,7 +61,7 @@ HELP: roman-
|
|||
{ roman+ roman- } related-words
|
||||
|
||||
HELP: roman*
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
|
||||
{ $values { "string" string } { "string" string } { "string" string } }
|
||||
{ $description "Multiplies two Roman numerals." }
|
||||
{ $examples
|
||||
{ $example "USING: io roman ;"
|
||||
|
|
@ -71,7 +71,7 @@ HELP: roman*
|
|||
} ;
|
||||
|
||||
HELP: roman/i
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } }
|
||||
{ $values { "string" string } { "string" string } { "string" string } }
|
||||
{ $description "Computes the integer division of two Roman numerals." }
|
||||
{ $examples
|
||||
{ $example "USING: io roman ;"
|
||||
|
|
@ -81,7 +81,7 @@ HELP: roman/i
|
|||
} ;
|
||||
|
||||
HELP: roman/mod
|
||||
{ $values { "str1" "a string" } { "str2" "a string" } { "str3" "a string" } { "str4" "a string" } }
|
||||
{ $values { "string" string } { "string" string } { "string" string } { "string" string } }
|
||||
{ $description "Computes the quotient and remainder of two Roman numerals." }
|
||||
{ $examples
|
||||
{ $example "USING: kernel io roman ;"
|
||||
|
|
|
|||
|
|
@ -38,3 +38,9 @@ USING: arrays kernel math roman roman.private sequences tools.test ;
|
|||
[ "iii" "iii" roman- ] must-fail
|
||||
|
||||
[ 30 ] [ ROMAN: xxx ] unit-test
|
||||
|
||||
[ roman+ ] must-infer
|
||||
[ roman- ] must-infer
|
||||
[ roman* ] must-infer
|
||||
[ roman/i ] must-infer
|
||||
[ roman/mod ] must-infer
|
||||
|
|
|
|||
|
|
@ -1,29 +1,33 @@
|
|||
! Copyright (C) 2007 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays assocs kernel math math.order math.vectors
|
||||
namespaces make quotations sequences splitting.monotonic
|
||||
sequences.private strings unicode.case lexer parser
|
||||
grouping ;
|
||||
USING: accessors arrays assocs fry generalizations grouping
|
||||
kernel lexer macros make math math.order math.vectors
|
||||
namespaces parser quotations sequences sequences.private
|
||||
splitting.monotonic stack-checker strings unicode.case
|
||||
words effects ;
|
||||
IN: roman
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: roman-digits ( -- seq )
|
||||
{ "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" } ;
|
||||
CONSTANT: roman-digits
|
||||
{ "m" "cm" "d" "cd" "c" "xc" "l" "xl" "x" "ix" "v" "iv" "i" }
|
||||
|
||||
: roman-values ( -- seq )
|
||||
{ 1000 900 500 400 100 90 50 40 10 9 5 4 1 } ;
|
||||
CONSTANT: roman-values
|
||||
{ 1000 900 500 400 100 90 50 40 10 9 5 4 1 }
|
||||
|
||||
ERROR: roman-range-error n ;
|
||||
|
||||
: roman-range-check ( n -- )
|
||||
dup 1 3999 between? [ drop ] [ roman-range-error ] if ;
|
||||
|
||||
: roman-digit-index ( ch -- n )
|
||||
1string roman-digits index ; inline
|
||||
|
||||
: roman<= ( ch1 ch2 -- ? )
|
||||
[ 1string roman-digits index ] bi@ >= ;
|
||||
[ roman-digit-index ] bi@ >= ;
|
||||
|
||||
: roman>n ( ch -- n )
|
||||
1string roman-digits index roman-values nth ;
|
||||
roman-digit-index roman-values nth ;
|
||||
|
||||
: (>roman) ( n -- )
|
||||
roman-values roman-digits [
|
||||
|
|
@ -31,47 +35,39 @@ ERROR: roman-range-error n ;
|
|||
] 2each drop ;
|
||||
|
||||
: (roman>) ( seq -- n )
|
||||
[ [ roman>n ] map ] [ all-eq? ] bi [
|
||||
sum
|
||||
] [
|
||||
first2 swap -
|
||||
] if ;
|
||||
[ [ roman>n ] map ] [ all-eq? ] bi
|
||||
[ sum ] [ first2 swap - ] if ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: >roman ( n -- str )
|
||||
dup roman-range-check
|
||||
[ (>roman) ] "" make ;
|
||||
dup roman-range-check [ (>roman) ] "" make ;
|
||||
|
||||
: >ROMAN ( n -- str ) >roman >upper ;
|
||||
|
||||
: roman> ( str -- n )
|
||||
>lower [ roman<= ] monotonic-split
|
||||
[ (roman>) ] sigma ;
|
||||
>lower [ roman<= ] monotonic-split [ (roman>) ] sigma ;
|
||||
|
||||
<PRIVATE
|
||||
|
||||
: 2roman> ( str1 str2 -- m n )
|
||||
[ roman> ] bi@ ;
|
||||
|
||||
: binary-roman-op ( str1 str2 quot -- str3 )
|
||||
[ 2roman> ] dip call >roman ; inline
|
||||
MACRO: binary-roman-op ( quot -- quot' )
|
||||
[ infer in>> ] [ ] [ infer out>> ] tri
|
||||
'[ [ roman> ] _ napply @ [ >roman ] _ napply ] ;
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: roman+ ( str1 str2 -- str3 )
|
||||
[ + ] binary-roman-op ;
|
||||
<<
|
||||
SYNTAX: ROMAN-OP:
|
||||
scan-word [ name>> "roman" prepend create-in ] keep
|
||||
1quotation '[ _ binary-roman-op ]
|
||||
dup infer [ in>> ] [ out>> ] bi
|
||||
[ "string" <repetition> ] bi@ <effect> define-declared ;
|
||||
>>
|
||||
|
||||
: roman- ( str1 str2 -- str3 )
|
||||
[ - ] binary-roman-op ;
|
||||
|
||||
: roman* ( str1 str2 -- str3 )
|
||||
[ * ] binary-roman-op ;
|
||||
|
||||
: roman/i ( str1 str2 -- str3 )
|
||||
[ /i ] binary-roman-op ;
|
||||
|
||||
: roman/mod ( str1 str2 -- str3 str4 )
|
||||
[ /mod ] binary-roman-op [ >roman ] dip ;
|
||||
ROMAN-OP: +
|
||||
ROMAN-OP: -
|
||||
ROMAN-OP: *
|
||||
ROMAN-OP: /i
|
||||
ROMAN-OP: /mod
|
||||
|
||||
SYNTAX: ROMAN: scan roman> parsed ;
|
||||
|
|
|
|||
|
|
@ -1,5 +1,9 @@
|
|||
IN: specialized-vectors.tests
|
||||
USING: specialized-vectors.double tools.test kernel sequences ;
|
||||
USING: specialized-arrays.float
|
||||
specialized-vectors.float
|
||||
specialized-vectors.double
|
||||
tools.test kernel sequences ;
|
||||
|
||||
[ 3 ] [ double-vector{ 1 2 } 3 over push length ] unit-test
|
||||
|
||||
[ t ] [ 10 float-array{ } new-resizable float-vector? ] unit-test
|
||||
|
|
@ -154,6 +154,15 @@ CONSTANT: bit-member-max 256
|
|||
dup sequence? [ memq-quot ] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
! Index search
|
||||
\ index [
|
||||
dup sequence? [
|
||||
dup length 4 >= [
|
||||
dup length zip >hashtable '[ _ at ]
|
||||
] [ drop f ] if
|
||||
] [ drop f ] if
|
||||
] 1 define-transform
|
||||
|
||||
! Shuffling
|
||||
: nths-quot ( indices -- quot )
|
||||
[ [ '[ _ swap nth ] ] map ] [ length ] bi
|
||||
|
|
|
|||
|
|
@ -26,7 +26,7 @@ HELP: scaffold-undocumented
|
|||
HELP: scaffold-vocab
|
||||
{ $values
|
||||
{ "vocab-root" "a vocabulary root string" } { "string" string } }
|
||||
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file, a tests file, and an authors.txt file." } ;
|
||||
{ $description "Creates a directory in the given root for a new vocabulary and adds a main .factor file and an authors.txt file." } ;
|
||||
|
||||
HELP: scaffold-emacs
|
||||
{ $description "Touches the .emacs file in your home directory and provides a clickable link to open it in an editor." } ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,21 @@
|
|||
! Copyright (C) 2009 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: tools.test tools.scaffold unicode.case kernel
|
||||
multiline tools.scaffold.private io.streams.string ;
|
||||
IN: tools.scaffold.tests
|
||||
|
||||
: undocumented-word ( obj1 obj2 -- obj3 obj4 )
|
||||
[ >lower ] [ >upper ] bi* ;
|
||||
|
||||
[
|
||||
<" HELP: undocumented-word
|
||||
{ $values
|
||||
{ "obj1" object } { "obj2" object }
|
||||
{ "obj3" object } { "obj4" object }
|
||||
}
|
||||
{ $description "" } ;
|
||||
">
|
||||
]
|
||||
[
|
||||
[ \ undocumented-word (help.) ] with-string-writer
|
||||
] unit-test
|
||||
|
|
@ -134,7 +134,7 @@ ERROR: no-vocab vocab ;
|
|||
vocabulary>> using get [ conjoin ] [ drop ] if* ;
|
||||
|
||||
: ($values.) ( array -- )
|
||||
[
|
||||
[ bl ] [
|
||||
"{ " write
|
||||
dup array? [ first ] when
|
||||
dup lookup-type [
|
||||
|
|
@ -145,7 +145,7 @@ ERROR: no-vocab vocab ;
|
|||
null add-using
|
||||
] if
|
||||
" }" write
|
||||
] each ;
|
||||
] interleave ;
|
||||
|
||||
: 4bl ( -- )
|
||||
" " write ; inline
|
||||
|
|
|
|||
|
|
@ -58,7 +58,7 @@ M: metrics-paint draw-boundary
|
|||
COLOR: red gl-color
|
||||
[ dim>> ] [ >label< line-metrics ] bi
|
||||
[ [ first ] [ ascent>> ] bi* [ nip 0 swap 2array ] [ 2array ] 2bi gl-line ]
|
||||
[ drop gl-rect ]
|
||||
[ drop { 0 0 } swap gl-rect ]
|
||||
2bi ;
|
||||
|
||||
: <metrics-gadget> ( text font -- gadget )
|
||||
|
|
|
|||
|
|
@ -172,11 +172,10 @@ TUPLE: selected-line start end first? last? ;
|
|||
|
||||
:: draw-selection ( line pair editor -- )
|
||||
pair [ editor font>> line offset>x ] map :> pair
|
||||
pair first 0 2array [
|
||||
editor selection-color>> gl-color
|
||||
pair second pair first - round 1 max
|
||||
editor line-height 2array gl-fill-rect
|
||||
] with-translation ;
|
||||
editor selection-color>> gl-color
|
||||
pair first 0 2array
|
||||
pair second pair first - round 1 max editor line-height 2array
|
||||
gl-fill-rect ;
|
||||
|
||||
: draw-unselected-line ( line editor -- )
|
||||
font>> swap draw-text ;
|
||||
|
|
|
|||
|
|
@ -3,9 +3,6 @@ namespaces math.rectangles accessors ui.gadgets.grids.private
|
|||
ui.gadgets.debug sequences ;
|
||||
IN: ui.gadgets.grids.tests
|
||||
|
||||
[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
|
||||
[ { 1 2 } { "a" "b" } cross-zip ] unit-test
|
||||
|
||||
[ { 0 0 } ] [ { } <grid> pref-dim ] unit-test
|
||||
|
||||
: 100x100 ( -- gadget ) <gadget> { 100 100 } >>dim ;
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! Copyright (C) 2006, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.order namespaces make sequences words io
|
||||
USING: arrays kernel math math.order math.matrices namespaces make sequences words io
|
||||
math.vectors ui.gadgets ui.baseline-alignment columns accessors strings.tables
|
||||
math.rectangles fry ;
|
||||
IN: ui.gadgets.grids
|
||||
|
|
@ -33,9 +33,6 @@ PRIVATE>
|
|||
|
||||
<PRIVATE
|
||||
|
||||
: cross-zip ( seq1 seq2 -- seq1xseq2 )
|
||||
[ [ 2array ] with map ] curry map ;
|
||||
|
||||
TUPLE: cell pref-dim baseline cap-height ;
|
||||
|
||||
: <cell> ( gadget -- cell )
|
||||
|
|
@ -116,7 +113,7 @@ M: grid layout* [ grid>> ] [ <grid-layout> ] bi grid-layout ;
|
|||
|
||||
M: grid children-on ( rect gadget -- seq )
|
||||
dup children>> empty? [ 2drop f ] [
|
||||
{ 0 1 } swap grid>>
|
||||
[ { 0 1 } ] dip grid>>
|
||||
[ 0 <column> fast-children-on ] keep
|
||||
<slice> concat
|
||||
] if ;
|
||||
|
|
|
|||
|
|
@ -79,9 +79,7 @@ GENERIC: draw-selection ( loc obj -- )
|
|||
|
||||
M: gadget draw-selection ( loc gadget -- )
|
||||
swap offset-rect [
|
||||
dup loc>> [
|
||||
dim>> gl-fill-rect
|
||||
] with-translation
|
||||
rect-bounds gl-fill-rect
|
||||
] if-fits ;
|
||||
|
||||
M: node draw-selection ( loc node -- )
|
||||
|
|
|
|||
|
|
@ -121,16 +121,15 @@ M: table layout*
|
|||
[ [ line-height ] dip * 0 swap 2array ]
|
||||
[ drop [ dim>> first ] [ line-height ] bi 2array ] 2bi <rect> ;
|
||||
|
||||
: highlight-row ( table row color quot -- )
|
||||
[ [ row-rect rect-bounds ] dip gl-color ] dip
|
||||
'[ _ @ ] with-translation ; inline
|
||||
: row-bounds ( table row -- loc dim )
|
||||
row-rect rect-bounds ; inline
|
||||
|
||||
: draw-selected-row ( table -- )
|
||||
{
|
||||
{ [ dup selected-index>> not ] [ drop ] }
|
||||
[
|
||||
[ ] [ selected-index>> ] [ selection-color>> ] tri
|
||||
[ gl-fill-rect ] highlight-row
|
||||
[ ] [ selected-index>> ] [ selection-color>> gl-color ] tri
|
||||
row-bounds gl-fill-rect
|
||||
]
|
||||
} cond ;
|
||||
|
||||
|
|
@ -139,14 +138,15 @@ M: table layout*
|
|||
{ [ dup focused?>> not ] [ drop ] }
|
||||
{ [ dup selected-index>> not ] [ drop ] }
|
||||
[
|
||||
[ ] [ selected-index>> ] [ focus-border-color>> ] tri
|
||||
[ gl-rect ] highlight-row
|
||||
[ ] [ selected-index>> ] [ focus-border-color>> gl-color ] tri
|
||||
row-bounds gl-rect
|
||||
]
|
||||
} cond ;
|
||||
|
||||
: draw-moused-row ( table -- )
|
||||
dup mouse-index>> dup [
|
||||
over mouse-color>> [ gl-rect ] highlight-row
|
||||
over mouse-color>> gl-color
|
||||
row-bounds gl-rect
|
||||
] [ 2drop ] if ;
|
||||
|
||||
: column-line-offsets ( table -- xs )
|
||||
|
|
@ -279,7 +279,7 @@ PRIVATE>
|
|||
|
||||
: row-action ( table -- )
|
||||
dup selected-row
|
||||
[ swap [ action>> call ] [ dup hook>> call ] bi ]
|
||||
[ swap [ action>> call( value -- ) ] [ dup hook>> call( table -- ) ] bi ]
|
||||
[ 2drop ]
|
||||
if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -9,8 +9,8 @@ TUPLE: solid < caching-pen color interior-vertices boundary-vertices ;
|
|||
|
||||
M: solid recompute-pen
|
||||
swap dim>>
|
||||
[ (fill-rect-vertices) >>interior-vertices ]
|
||||
[ (rect-vertices) >>boundary-vertices ]
|
||||
[ [ { 0 0 } ] dip (fill-rect-vertices) >>interior-vertices ]
|
||||
[ [ { 0 0 } ] dip (rect-vertices) >>boundary-vertices ]
|
||||
bi drop ;
|
||||
|
||||
<PRIVATE
|
||||
|
|
|
|||
|
|
@ -38,7 +38,7 @@ SYMBOL: viewport-translation
|
|||
! white gl-clear is broken w.r.t window resizing
|
||||
! Linux/PPC Radeon 9200
|
||||
COLOR: white gl-color
|
||||
clip get dim>> gl-fill-rect ;
|
||||
{ 0 0 } clip get dim>> gl-fill-rect ;
|
||||
|
||||
GENERIC: draw-gadget* ( gadget -- )
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@ USING: help.markup help.syntax ui.commands ;
|
|||
IN: ui.tools.browser
|
||||
|
||||
ARTICLE: "ui-browser" "UI browser"
|
||||
"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or articlelink presentation is clicked. It can also be opened using words:"
|
||||
"The browser is used to display Factor code, documentation, and vocabularies. The browser is opened when a word or article link presentation is clicked. It can also be opened using words:"
|
||||
{ $subsection com-browse }
|
||||
{ $subsection browser-window }
|
||||
{ $command-map browser-gadget "toolbar" }
|
||||
|
|
|
|||
|
|
@ -263,8 +263,9 @@ M: listener-operation invoke-command ( target command -- )
|
|||
|
||||
: listener-run-files ( seq -- )
|
||||
[
|
||||
[ \ listener-run-files ] dip
|
||||
'[ _ [ run-file ] each ] call-listener
|
||||
'[ _ [ run-file ] each ]
|
||||
\ listener-run-files
|
||||
call-listener
|
||||
] unless-empty ;
|
||||
|
||||
: com-end ( listener -- )
|
||||
|
|
|
|||
|
|
@ -81,8 +81,6 @@ IN: ui.tools.operations
|
|||
{ +listener+ t }
|
||||
} define-operation
|
||||
|
||||
UNION: definition word method-spec link vocab vocab-link ;
|
||||
|
||||
[ definition? ] \ edit H{
|
||||
{ +keyboard+ T{ key-down f { C+ } "e" } }
|
||||
{ +listener+ t }
|
||||
|
|
|
|||
|
|
@ -60,7 +60,7 @@ SYMBOL: table
|
|||
: finish-table ( -- table )
|
||||
table get [ [ 1 = ] map ] map ;
|
||||
|
||||
: eval-seq ( seq -- seq ) [ dup word? [ execute ] when ] map ;
|
||||
: eval-seq ( seq -- seq ) [ ?execute ] map ;
|
||||
|
||||
: (set-table) ( class1 class2 val -- )
|
||||
[ table get nth ] dip '[ _ or ] change-nth ;
|
||||
|
|
|
|||
|
|
@ -18,4 +18,12 @@ kernel io.streams.string xml.writer ;
|
|||
<" int x = "hi";
|
||||
/* a comment */ "> <string-reader> htmlize-stream
|
||||
write-xml
|
||||
] unit-test
|
||||
|
||||
[ "<span class=\"MARKUP\">: foo</span> <span class=\"MARKUP\">;</span>" ] [
|
||||
{ ": foo ;" } "factor" htmlize-lines xml>string
|
||||
] unit-test
|
||||
|
||||
[ ":foo" ] [
|
||||
{ ":foo" } "factor" htmlize-lines xml>string
|
||||
] unit-test
|
||||
|
|
@ -84,7 +84,7 @@ M: string-matcher text-matches?
|
|||
] keep string>> length and ;
|
||||
|
||||
M: regexp text-matches?
|
||||
[ >string ] dip re-contains? ;
|
||||
[ >string ] dip first-match dup [ to>> ] when ;
|
||||
|
||||
: rule-start-matches? ( rule -- match-count/f )
|
||||
dup start>> tuck swap can-match-here? [
|
||||
|
|
|
|||
|
|
@ -3,6 +3,8 @@
|
|||
USING: kernel sequences namespaces assocs graphs math math.order ;
|
||||
IN: definitions
|
||||
|
||||
MIXIN: definition
|
||||
|
||||
ERROR: no-compilation-unit definition ;
|
||||
|
||||
SYMBOLS: inlined-dependency flushed-dependency called-dependency ;
|
||||
|
|
|
|||
|
|
@ -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: accessors words kernel sequences namespaces make assocs
|
||||
hashtables definitions kernel.private classes classes.private
|
||||
|
|
@ -27,6 +27,8 @@ M: generic definition drop f ;
|
|||
PREDICATE: method-spec < pair
|
||||
first2 generic? swap class? and ;
|
||||
|
||||
INSTANCE: method-spec definition
|
||||
|
||||
: order ( generic -- seq )
|
||||
"methods" word-prop keys sort-classes ;
|
||||
|
||||
|
|
|
|||
|
|
@ -15,11 +15,10 @@ SLOT: i
|
|||
[ 1+ ] change-i drop ; inline
|
||||
|
||||
: sequence-read1 ( stream -- elt/f )
|
||||
[ >sequence-stream< ?nth ]
|
||||
[ next ] bi ; inline
|
||||
[ >sequence-stream< ?nth ] [ next ] bi ; inline
|
||||
|
||||
: add-length ( n stream -- i+n )
|
||||
[ i>> + ] [ underlying>> length ] bi min ; inline
|
||||
[ i>> + ] [ underlying>> length ] bi min ; inline
|
||||
|
||||
: (sequence-read) ( n stream -- seq/f )
|
||||
[ add-length ] keep
|
||||
|
|
@ -32,8 +31,8 @@ SLOT: i
|
|||
[ (sequence-read) ] [ 2drop f ] if ; inline
|
||||
|
||||
: find-sep ( seps stream -- sep/f n )
|
||||
swap [ >sequence-stream< ] dip
|
||||
[ memq? ] curry find-from swap ; inline
|
||||
swap [ >sequence-stream< swap tail-slice ] dip
|
||||
[ memq? ] curry find swap ; inline
|
||||
|
||||
: sequence-read-until ( separators stream -- seq sep/f )
|
||||
[ find-sep ] keep
|
||||
|
|
|
|||
|
|
@ -23,6 +23,10 @@ GENERIC: call ( callable -- )
|
|||
|
||||
GENERIC: execute ( word -- )
|
||||
|
||||
GENERIC: ?execute ( word -- value )
|
||||
|
||||
M: object ?execute ;
|
||||
|
||||
DEFER: if
|
||||
|
||||
: ? ( ? true false -- true/false )
|
||||
|
|
|
|||
|
|
@ -556,18 +556,18 @@ HELP: BIN:
|
|||
{ $examples { $example "USE: prettyprint" "BIN: 100 ." "4" } } ;
|
||||
|
||||
HELP: GENERIC:
|
||||
{ $syntax "GENERIC: word" "GENERIC: word ( stack -- effect )" }
|
||||
{ $syntax "GENERIC: word ( stack -- effect )" }
|
||||
{ $values { "word" "a new word to define" } }
|
||||
{ $description "Defines a new generic word in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." } ;
|
||||
|
||||
HELP: GENERIC#
|
||||
{ $syntax "GENERIC# word n" "GENERIC# word n ( stack -- effect )" }
|
||||
{ $syntax "GENERIC# word n ( stack -- effect )" }
|
||||
{ $values { "word" "a new word to define" } { "n" "the stack position to dispatch on" } }
|
||||
{ $description "Defines a new generic word which dispatches on the " { $snippet "n" } "th most element from the top of the stack in the current vocabulary. Initially, it contains no methods, and thus will throw a " { $link no-method } " error when called." }
|
||||
{ $notes
|
||||
"The following two definitions are equivalent:"
|
||||
{ $code "GENERIC: foo" }
|
||||
{ $code "GENERIC# foo 0" }
|
||||
{ $code "GENERIC: foo ( obj -- )" }
|
||||
{ $code "GENERIC# foo 0 ( obj -- )" }
|
||||
} ;
|
||||
|
||||
HELP: MATH:
|
||||
|
|
@ -576,7 +576,7 @@ HELP: MATH:
|
|||
{ $description "Defines a new generic word which uses the " { $link math-combination } " method combination." } ;
|
||||
|
||||
HELP: HOOK:
|
||||
{ $syntax "HOOK: word variable" "HOOK: word variable ( stack -- effect ) " }
|
||||
{ $syntax "HOOK: word variable ( stack -- effect ) " }
|
||||
{ $values { "word" "a new word to define" } { "variable" word } }
|
||||
{ $description "Defines a new hook word in the current vocabulary. Hook words are generic words which dispatch on the value of a variable, so methods are defined with " { $link POSTPONE: M: } ". Hook words differ from other generic words in that the dispatch value is removed from the stack before the chosen method is called." }
|
||||
{ $examples
|
||||
|
|
|
|||
|
|
@ -138,7 +138,7 @@ IN: bootstrap.syntax
|
|||
] define-core-syntax
|
||||
|
||||
"CONSTANT:" [
|
||||
CREATE scan-object define-constant
|
||||
CREATE-WORD scan-object define-constant
|
||||
] define-core-syntax
|
||||
|
||||
":" [
|
||||
|
|
|
|||
|
|
@ -108,4 +108,6 @@ SYMBOL: load-vocab-hook ! ( name -- vocab )
|
|||
: load-vocab ( name -- vocab ) load-vocab-hook get call( name -- vocab ) ;
|
||||
|
||||
PREDICATE: runnable-vocab < vocab
|
||||
vocab-main >boolean ;
|
||||
vocab-main >boolean ;
|
||||
|
||||
INSTANCE: vocab-spec definition
|
||||
|
|
@ -0,0 +1,6 @@
|
|||
USING: math eval tools.test effects ;
|
||||
IN: words.alias.tests
|
||||
|
||||
ALIAS: foo +
|
||||
[ ] [ "IN: words.alias.tests CONSTANT: foo 5" eval ] unit-test
|
||||
[ (( -- value )) ] [ \ foo stack-effect ] unit-test
|
||||
|
|
@ -12,6 +12,8 @@ IN: words
|
|||
|
||||
M: word execute (execute) ;
|
||||
|
||||
M: word ?execute execute( -- value ) ;
|
||||
|
||||
M: word <=>
|
||||
[ [ name>> ] [ vocabulary>> ] bi 2array ] compare ;
|
||||
|
||||
|
|
@ -260,3 +262,5 @@ M: word hashcode*
|
|||
M: word literalize <wrapper> ;
|
||||
|
||||
: xref-words ( -- ) all-words [ xref ] each ;
|
||||
|
||||
INSTANCE: word definition
|
||||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2008 Doug Coleman, Joe Groff.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays byte-arrays kernel math namespaces
|
||||
opengl.gl sequences math.vectors ui images images.viewer
|
||||
models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
|
||||
opengl.gl sequences math.vectors ui images images.normalization
|
||||
images.viewer models ui.gadgets.worlds ui.gadgets fry alien.syntax ;
|
||||
IN: cap
|
||||
|
||||
: screenshot-array ( world -- byte-array )
|
||||
|
|
|
|||
|
|
@ -1,8 +1,12 @@
|
|||
IN: game-input.tests
|
||||
USING: game-input tools.test kernel system threads ;
|
||||
USING: ui game-input tools.test kernel system threads
|
||||
combinators.short-circuit calendar ;
|
||||
|
||||
os windows? os macosx? or [
|
||||
{
|
||||
[ os windows? ui-running? and ]
|
||||
[ os macosx? ]
|
||||
} 0|| [
|
||||
[ ] [ open-game-input ] unit-test
|
||||
[ ] [ yield ] unit-test
|
||||
[ ] [ 1 seconds sleep ] unit-test
|
||||
[ ] [ close-game-input ] unit-test
|
||||
] when
|
||||
|
|
@ -1,23 +1,113 @@
|
|||
! Copyright (C) 2008 Tim Wawrzynczak
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: help.markup help.syntax sequences kernel accessors ;
|
||||
USING: help.markup help.syntax sequences kernel accessors
|
||||
id3.private strings ;
|
||||
IN: id3
|
||||
|
||||
HELP: file-id3-tags
|
||||
HELP: mp3>id3
|
||||
{ $values
|
||||
{ "path" "a path string" }
|
||||
{ "id3v2-info/f" "a tuple storing ID3v2 metadata or f" } }
|
||||
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Currently, the parser supports the following tags: "
|
||||
$nl { $link title>> }
|
||||
$nl { $link artist>> }
|
||||
$nl { $link album>> }
|
||||
$nl { $link year>> }
|
||||
$nl { $link genre>> }
|
||||
$nl { $link comment>> } } ;
|
||||
{ $description "Return a tuple containing the ID3 information parsed out of the MP3 file, or " { $link f } " if no metadata is present. Words to access the ID3v1 information are here:"
|
||||
{ $list
|
||||
{ $link title }
|
||||
{ $link artist }
|
||||
{ $link album }
|
||||
{ $link year }
|
||||
{ $link genre }
|
||||
{ $link comment }
|
||||
}
|
||||
"For other fields, use the " { $link find-id3-frame } " word."
|
||||
} ;
|
||||
|
||||
HELP: album
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "album/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the album, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: artist
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "artist/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the artist, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: comment
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "comment/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the comment, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: genre
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "genre/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the genre, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: title
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "title/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the title, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: year
|
||||
{ $values
|
||||
{ "id3" id3v2-info }
|
||||
{ "year/f" "string or f" }
|
||||
}
|
||||
{ $description "Returns the year, or " { $link f } " if this field is missing, from a parsed id3 tag." } ;
|
||||
|
||||
HELP: find-id3-frame
|
||||
{ $values
|
||||
{ "id3" id3v2-info } { "name" string }
|
||||
{ "obj/f" "object or f" }
|
||||
}
|
||||
{ $description "Returns the " { $slot "data" } " slot of the ID3 frame with the given name, or " { $link f } "." } ;
|
||||
|
||||
HELP: mp3-paths>id3s
|
||||
{ $values
|
||||
{ "seq" sequence }
|
||||
{ "seq'" sequence }
|
||||
}
|
||||
{ $description "From a sequence of pathnames, parses each ID3 header and returns a sequence of key/value pairs of pathnames and ID3 objects." } ;
|
||||
|
||||
HELP: find-mp3s
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Returns a sequence of MP3 pathnames from a directory and all of its subdirectories." } ;
|
||||
|
||||
HELP: parse-mp3-directory
|
||||
{ $values
|
||||
{ "path" "a pathname string" }
|
||||
{ "seq" sequence }
|
||||
}
|
||||
{ $description "Returns a sequence of key/value pairs where the key is the path of an MP3 and the value is the parsed ID3 header or " { $link f } " recursively for each MP3 file in the directory and all subdirectories." } ;
|
||||
|
||||
ARTICLE: "id3" "ID3 tags"
|
||||
"The " { $vocab-link "id3" } " vocabulary contains words for parsing " { $emphasis "ID3" } " tags, which are textual fields storing an MP3's title, artist, and other metadata." $nl
|
||||
"Parsing ID3 tags from an MP3 file:"
|
||||
{ $subsection file-id3-tags } ;
|
||||
"Parsing ID3 tags for a directory of MP3s, recursively:"
|
||||
{ $subsection parse-mp3-directory }
|
||||
"Finding MP3 files recursively:"
|
||||
{ $subsection find-mp3s }
|
||||
"Parsing a sequence of MP3 pathnames:"
|
||||
{ $subsection mp3-paths>id3s }
|
||||
"Parsing an MP3 file's ID3 tags:"
|
||||
{ $subsection mp3>id3 }
|
||||
"ID3v1 frame tag accessors:"
|
||||
{ $subsection album }
|
||||
{ $subsection artist }
|
||||
{ $subsection comment }
|
||||
{ $subsection genre }
|
||||
{ $subsection title }
|
||||
{ $subsection year }
|
||||
"Access any frame tag:"
|
||||
{ $subsection find-id3-frame } ;
|
||||
|
||||
ABOUT: "id3"
|
||||
|
|
|
|||
|
|
@ -5,12 +5,12 @@ IN: id3.tests
|
|||
|
||||
: id3-params ( id3 -- title artist album year comment genre )
|
||||
{
|
||||
[ id3-title ]
|
||||
[ id3-artist ]
|
||||
[ id3-album ]
|
||||
[ id3-year ]
|
||||
[ id3-comment ]
|
||||
[ id3-genre ]
|
||||
[ title ]
|
||||
[ artist ]
|
||||
[ album ]
|
||||
[ year ]
|
||||
[ comment ]
|
||||
[ genre ]
|
||||
} cleave ;
|
||||
|
||||
[
|
||||
|
|
@ -20,7 +20,7 @@ IN: id3.tests
|
|||
"2009"
|
||||
"COMMENT"
|
||||
"Bluegrass"
|
||||
] [ "vocab:id3/tests/blah.mp3" file-id3-tags id3-params ] unit-test
|
||||
] [ "vocab:id3/tests/blah.mp3" mp3>id3 id3-params ] unit-test
|
||||
|
||||
[
|
||||
"Anthem of the Trinity"
|
||||
|
|
@ -29,7 +29,7 @@ IN: id3.tests
|
|||
f
|
||||
f
|
||||
"Classical"
|
||||
] [ "vocab:id3/tests/blah2.mp3" file-id3-tags id3-params ] unit-test
|
||||
] [ "vocab:id3/tests/blah2.mp3" mp3>id3 id3-params ] unit-test
|
||||
|
||||
[
|
||||
"Stormy Weather"
|
||||
|
|
@ -38,5 +38,5 @@ IN: id3.tests
|
|||
f
|
||||
"eng, AG# 08E1C12E"
|
||||
"Big Band"
|
||||
] [ "vocab:id3/tests/blah3.mp3" file-id3-tags id3-params ] unit-test
|
||||
] [ "vocab:id3/tests/blah3.mp3" mp3>id3 id3-params ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -48,15 +48,14 @@ TUPLE: id3v2-info header frames ;
|
|||
|
||||
TUPLE: id3v1-info title artist album year comment genre ;
|
||||
|
||||
: <id3v1-info> ( -- object ) id3v1-info new ;
|
||||
: <id3v1-info> ( -- object ) id3v1-info new ; inline
|
||||
|
||||
: <id3v2-info> ( header frames -- object )
|
||||
[ [ frame-id>> ] keep ] H{ } map>assoc
|
||||
id3v2-info boa ;
|
||||
[ [ frame-id>> ] keep ] H{ } map>assoc id3v2-info boa ;
|
||||
|
||||
: <header> ( -- object ) header new ;
|
||||
: <header> ( -- object ) header new ; inline
|
||||
|
||||
: <frame> ( -- object ) frame new ;
|
||||
: <frame> ( -- object ) frame new ; inline
|
||||
|
||||
: id3v2? ( mmap -- ? ) "ID3" head? ; inline
|
||||
|
||||
|
|
@ -66,7 +65,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
: id3v1-frame ( string key -- frame )
|
||||
<frame>
|
||||
swap >>frame-id
|
||||
swap >>data ;
|
||||
swap >>data ; inline
|
||||
|
||||
: id3v1>id3v2 ( id3v1 -- id3v2 )
|
||||
[
|
||||
|
|
@ -78,7 +77,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
[ comment>> "COMM" id3v1-frame ]
|
||||
[ genre>> "TCON" id3v1-frame ]
|
||||
} cleave
|
||||
] output>array f swap <id3v2-info> ;
|
||||
] output>array f swap <id3v2-info> ; inline
|
||||
|
||||
: >28bitword ( seq -- int )
|
||||
0 [ [ 7 shift ] dip bitor ] reduce ; inline
|
||||
|
|
@ -104,11 +103,11 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
[ [ 4 8 ] dip subseq >28bitword >>size ]
|
||||
[ [ 8 10 ] dip subseq >byte-array >>flags ]
|
||||
[ read-frame-data decode-text >>data ]
|
||||
} cleave ;
|
||||
} cleave ; inline
|
||||
|
||||
: read-frame ( mmap -- frame/f )
|
||||
dup 4 head-slice valid-frame-id?
|
||||
[ (read-frame) ] [ drop f ] if ;
|
||||
[ (read-frame) ] [ drop f ] if ; inline
|
||||
|
||||
: remove-frame ( mmap frame -- mmap )
|
||||
size>> 10 + tail-slice ; inline
|
||||
|
|
@ -116,10 +115,8 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
: read-frames ( mmap -- frames )
|
||||
[ dup read-frame dup ]
|
||||
[ [ remove-frame ] keep ]
|
||||
produce 2nip ;
|
||||
produce 2nip ; inline
|
||||
|
||||
! header stuff
|
||||
|
||||
: read-v2-header ( seq -- id3header )
|
||||
[ <header> ] dip
|
||||
{
|
||||
|
|
@ -133,8 +130,6 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
[ read-v2-header ]
|
||||
[ read-frames ] bi* <id3v2-info> ; inline
|
||||
|
||||
! v1 information
|
||||
|
||||
: skip-to-v1-data ( seq -- seq ) 125 tail-slice* ; inline
|
||||
|
||||
: (read-v1-tag-data) ( seq -- mp3-file )
|
||||
|
|
@ -159,28 +154,7 @@ TUPLE: id3v1-info title artist album year comment genre ;
|
|||
drop
|
||||
] if ; inline
|
||||
|
||||
PRIVATE>
|
||||
|
||||
: frame-named ( id3 name quot -- obj )
|
||||
[ swap frames>> at* ] dip
|
||||
[ data>> ] prepose [ drop f ] if ; inline
|
||||
|
||||
: id3-title ( id3 -- title/f ) "TIT2" [ ] frame-named ; inline
|
||||
|
||||
: id3-artist ( id3 -- artist/f ) "TPE1" [ ] frame-named ; inline
|
||||
|
||||
: id3-album ( id3 -- album/f ) "TALB" [ ] frame-named ; inline
|
||||
|
||||
: id3-year ( id3 -- year/f ) "TYER" [ ] frame-named ; inline
|
||||
|
||||
: id3-comment ( id3 -- comment/f ) "COMM" [ ] frame-named ; inline
|
||||
|
||||
: id3-genre ( id3 -- genre/f )
|
||||
"TCON" [ parse-genre ] frame-named ; inline
|
||||
|
||||
: id3-frame ( id3 key -- value/f ) [ ] frame-named ; inline
|
||||
|
||||
: (file-id3-tags) ( path -- id3v2-info/f )
|
||||
: (mp3>id3) ( path -- id3v2-info/f )
|
||||
[
|
||||
{
|
||||
{ [ dup id3v2? ] [ read-v2-tag-data ] }
|
||||
|
|
@ -189,9 +163,36 @@ PRIVATE>
|
|||
} cond
|
||||
] with-mapped-uchar-file ;
|
||||
|
||||
: file-id3-tags ( path -- id3v2-info/f )
|
||||
dup file-info size>> 0 <= [ drop f ] [ (file-id3-tags) ] if ;
|
||||
: (find-id3-frame) ( id3 name quot: ( obj -- obj' ) -- obj' )
|
||||
[ swap frames>> at* ] dip
|
||||
[ data>> ] prepose [ drop f ] if ; inline
|
||||
|
||||
: parse-id3s ( path -- seq )
|
||||
[ >lower ".mp3" tail? ] find-all-files
|
||||
[ dup file-id3-tags ] { } map>assoc ;
|
||||
PRIVATE>
|
||||
|
||||
: mp3>id3 ( path -- id3v2-info/f )
|
||||
dup file-info size>> 0 <= [ drop f ] [ (mp3>id3) ] if ; inline
|
||||
|
||||
: find-id3-frame ( id3 name -- obj/f )
|
||||
[ ] (find-id3-frame) ; inline
|
||||
|
||||
: title ( id3 -- title/f ) "TIT2" find-id3-frame ; inline
|
||||
|
||||
: artist ( id3 -- artist/f ) "TPE1" find-id3-frame ; inline
|
||||
|
||||
: album ( id3 -- album/f ) "TALB" find-id3-frame ; inline
|
||||
|
||||
: year ( id3 -- year/f ) "TYER" find-id3-frame ; inline
|
||||
|
||||
: comment ( id3 -- comment/f ) "COMM" find-id3-frame ; inline
|
||||
|
||||
: genre ( id3 -- genre/f )
|
||||
"TCON" [ parse-genre ] (find-id3-frame) ; inline
|
||||
|
||||
: find-mp3s ( path -- seq )
|
||||
[ >lower ".mp3" tail? ] find-all-files ; inline
|
||||
|
||||
: mp3-paths>id3s ( seq -- seq' )
|
||||
[ dup mp3>id3 ] { } map>assoc ; inline
|
||||
|
||||
: parse-mp3-directory ( path -- seq )
|
||||
find-mp3s mp3-paths>id3s ;
|
||||
|
|
|
|||
|
|
@ -104,3 +104,6 @@ USING: math.matrices math.vectors tools.test math ;
|
|||
[ { 0 1 0 } ] [ { 0 0 1 } { 1 0 0 } cross ] unit-test
|
||||
|
||||
[ { 1 0 0 } ] [ { 1 1 0 } { 1 0 0 } proj ] unit-test
|
||||
|
||||
[ { { { 1 "a" } { 1 "b" } } { { 2 "a" } { 2 "b" } } } ]
|
||||
[ { 1 2 } { "a" "b" } cross-zip ] unit-test
|
||||
|
|
@ -1,4 +1,4 @@
|
|||
! Copyright (C) 2005, 2008 Slava Pestov.
|
||||
! Copyright (C) 2005, 2009 Slava Pestov.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: arrays kernel math math.order math.vectors sequences ;
|
||||
IN: math.matrices
|
||||
|
|
@ -57,3 +57,6 @@ PRIVATE>
|
|||
|
||||
: norm-gram-schmidt ( seq -- orthonormal )
|
||||
gram-schmidt [ normalize ] map ;
|
||||
|
||||
: cross-zip ( seq1 seq2 -- seq1xseq2 )
|
||||
[ [ 2array ] with map ] curry map ;
|
||||
|
|
@ -8,7 +8,7 @@ IN: tetris.gl
|
|||
#! OpenGL rendering for tetris
|
||||
|
||||
: draw-block ( block -- )
|
||||
[ { 1 1 } gl-fill-rect ] with-translation ;
|
||||
{ 1 1 } gl-fill-rect ;
|
||||
|
||||
: draw-piece-blocks ( piece -- )
|
||||
piece-blocks [ draw-block ] each ;
|
||||
|
|
|
|||
|
|
@ -57,9 +57,7 @@ M: list draw-gadget*
|
|||
origin get [
|
||||
dup color>> gl-color
|
||||
selected-rect [
|
||||
dup loc>> [
|
||||
dim>> gl-fill-rect
|
||||
] with-translation
|
||||
rect-bounds gl-fill-rect
|
||||
] when*
|
||||
] with-translation ;
|
||||
|
||||
|
|
|
|||
|
|
@ -20,7 +20,7 @@
|
|||
</t:a>
|
||||
</h2>
|
||||
|
||||
<t:farkup t:name="parsed" t:parsed="true" />
|
||||
<t:farkup t:name="content" />
|
||||
</t:bind>
|
||||
</div>
|
||||
</td>
|
||||
|
|
@ -58,7 +58,7 @@
|
|||
<tr>
|
||||
<td colspan="2" class="footer">
|
||||
<t:bind t:name="footer">
|
||||
<t:farkup t:name="parsed" t:parsed="true" />
|
||||
<t:farkup t:name="content" />
|
||||
</t:bind>
|
||||
</td>
|
||||
</tr>
|
||||
|
|
|
|||
|
|
@ -1,4 +1,3 @@
|
|||
include vm/Config.linux
|
||||
include vm/Config.x86.64
|
||||
LIBPATH = -L/usr/X11R6/lib64 -L/usr/X11R6/lib
|
||||
FFI_TEST_CFLAGS = -fPIC
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@ CFLAGS += -fPIC
|
|||
PLAF_DLL_OBJS += vm/os-macosx.o vm/mach_signal.o
|
||||
|
||||
DLL_EXTENSION = .dylib
|
||||
SHARED_DLL_EXTENSION = .dylib
|
||||
|
||||
SHARED_FLAG = -dynamiclib
|
||||
|
||||
|
|
|
|||
|
|
@ -5,7 +5,7 @@ endif
|
|||
EXE_SUFFIX =
|
||||
DLL_PREFIX = lib
|
||||
DLL_EXTENSION = .a
|
||||
# DLL_EXTENSION = .so
|
||||
SHARED_DLL_EXTENSION = .so
|
||||
SHARED_FLAG = -shared
|
||||
|
||||
PLAF_DLL_OBJS = vm/os-unix.o
|
||||
|
|
|
|||
|
|
@ -5,5 +5,6 @@ SHARED_FLAG = -shared
|
|||
EXE_EXTENSION=.exe
|
||||
CONSOLE_EXTENSION=.com
|
||||
DLL_EXTENSION=.dll
|
||||
SHARED_DLL_EXTENSION=.dll
|
||||
LINKER = $(CC) -shared -mno-cygwin -o
|
||||
LINK_WITH_ENGINE = -l$(DLL_PREFIX)factor$(DLL_SUFFIX)
|
||||
|
|
|
|||
13
vm/alien.c
13
vm/alien.c
|
|
@ -160,7 +160,7 @@ void box_value_struct(void *src, CELL size)
|
|||
dpush(tag_object(array));
|
||||
}
|
||||
|
||||
/* On OS X, structs <= 8 bytes are returned in registers. */
|
||||
/* On some x86 OSes, structs <= 8 bytes are returned in registers. */
|
||||
void box_small_struct(CELL x, CELL y, CELL size)
|
||||
{
|
||||
CELL data[2];
|
||||
|
|
@ -169,6 +169,17 @@ void box_small_struct(CELL x, CELL y, CELL size)
|
|||
box_value_struct(data,size);
|
||||
}
|
||||
|
||||
/* On OS X/PPC, complex numbers are returned in registers. */
|
||||
void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size)
|
||||
{
|
||||
CELL data[4];
|
||||
data[0] = x1;
|
||||
data[1] = x2;
|
||||
data[2] = x3;
|
||||
data[3] = x4;
|
||||
box_value_struct(data,size);
|
||||
}
|
||||
|
||||
/* open a native library and push a handle */
|
||||
void primitive_dlopen(void)
|
||||
{
|
||||
|
|
|
|||
|
|
@ -40,6 +40,7 @@ void primitive_set_alien_cell(void);
|
|||
DLLEXPORT void to_value_struct(CELL src, void *dest, CELL size);
|
||||
DLLEXPORT void box_value_struct(void *src, CELL size);
|
||||
DLLEXPORT void box_small_struct(CELL x, CELL y, CELL size);
|
||||
void box_medium_struct(CELL x1, CELL x2, CELL x3, CELL x4, CELL size);
|
||||
|
||||
DEFINE_UNTAG(F_DLL,DLL_TYPE,dll)
|
||||
|
||||
|
|
|
|||
|
|
@ -195,8 +195,6 @@ void mark_code_block(F_CODE_BLOCK *compiled)
|
|||
|
||||
copy_handle(&compiled->literals);
|
||||
copy_handle(&compiled->relocation);
|
||||
|
||||
flush_icache_for(compiled);
|
||||
}
|
||||
|
||||
void mark_stack_frame_step(F_STACK_FRAME *frame)
|
||||
|
|
|
|||
Loading…
Reference in New Issue