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

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

db4
Rex Ford 2008-08-05 16:17:24 -05:00
parent 2b2a91db0a 085a9b9ff4
commit b0151f8202
41 changed files with 743 additions and 262 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

58
basis/disjoint-sets/disjoint-sets-docs.factor Normal file
View File

@ -0,0 +1,58 @@
IN: disjoint-sets
USING: help.markup help.syntax kernel assocs math ;
HELP: <disjoint-set>
{ $values { "disjoint-set" disjoint-set } }
{ $description "Creates a new disjoint set data structure with no elements." } ;
HELP: add-atom
{ $values { "a" object } { "disjoint-set" disjoint-set } }
{ $description "Adds a new element to the disjoint set, initially only equivalent to itself." } ;
HELP: equiv-set-size
{ $values { "a" object } { "disjoint-set" disjoint-set } { "n" integer } }
{ $description "Outputs the number of elements in the equivalence class of " { $snippet "a" } "." } ;
HELP: equiv?
{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } { "?" "a boolean" } }
{ $description "Tests if two elements belong to the same equivalence class." } ;
HELP: equate
{ $values { "a" object } { "b" object } { "disjoint-set" disjoint-set } }
{ $description "Merges the equivalence classes of two elements, which must previously have been added with " { $link add-atom } "." } ;
HELP: assoc>disjoint-set
{ $values { "assoc" assoc } { "disjoint-set" disjoint-set } }
{ $description "Given an assoc representation of a graph where the keys are vertices and key/value pairs are edges, creates a disjoint set whose elements are the keys of assoc, and two keys are equvalent if they belong to the same connected component of the graph." }
{ $examples
{ $example
"USING: disjoint-sets kernel prettyprint ;"
"H{ { 1 1 } { 2 1 } { 3 4 } { 4 4 } { 5 3 } } assoc>disjoint-set"
"1 2 pick equiv? ."
"4 5 pick equiv? ."
"1 5 pick equiv? ."
"drop"
"t\nt\nf\n"
}
} ;
ARTICLE: "disjoint-sets" "Disjoint sets"
"The " { $emphasis "disjoint set" } " data structure, also known as " { $emphasis "union-find" } " (after the two main operations which it supports) represents a set of elements partitioned into disjoint equivalence classes, or alternatively, an equivalence relation on a set."
$nl
"The two main supported operations are equating two elements, which joins their equivalence classes, and checking if two elements belong to the same equivalence class. Both operations have the time complexity of the inverse Ackermann function, which for all intents and purposes is constant time."
$nl
"The class of disjoint sets:"
{ $subsection disjoint-set }
"Creating new disjoint sets:"
{ $subsection <disjoint-set> }
{ $subsection assoc>disjoint-set }
"Queries:"
{ $subsection equiv? }
{ $subsection equiv-set-size }
"Adding elements:"
{ $subsection add-atom }
"Equating elements:"
{ $subsection equate }
"Additionally, disjoint sets implement the " { $link clone } " generic word." ;
ABOUT: "disjoint-sets"

13
basis/disjoint-sets/disjoint-sets.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Eric Mertens.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays hints kernel locals math hashtables
assocs ;
assocs fry ;
IN: disjoint-sets
@ -36,8 +36,6 @@ TUPLE: disjoint-set
: representative? ( a disjoint-set -- ? )
dupd parent = ; inline
PRIVATE>
GENERIC: representative ( a disjoint-set -- p )
M: disjoint-set representative
@ -45,8 +43,6 @@ M: disjoint-set representative
[ [ parent ] keep representative dup ] 2keep set-parent
] if ;
<PRIVATE
: representatives ( a b disjoint-set -- r r )
[ representative ] curry bi@ ; inline
@ -90,3 +86,10 @@ M:: disjoint-set equate ( a b disjoint-set -- )
M: disjoint-set clone
[ parents>> ] [ ranks>> ] [ counts>> ] tri [ clone ] tri@
disjoint-set boa ;
: assoc>disjoint-set ( assoc -- disjoint-set )
<disjoint-set>
[ '[ drop , add-atom ] assoc-each ]
[ '[ , equate ] assoc-each ]
[ nip ]
2tri ;

2
basis/windows/com/com-tests.factor
View File

@ -45,7 +45,7 @@ C: <test-implementation> test-implementation
} }
{ "IUnrelated" {
[ swap x>> + ] ! IUnrelated::xPlus
[ spin x>> * + ] ! IUnrealted::xMulAdd
[ spin x>> * + ] ! IUnrelated::xMulAdd
} }
} <com-wrapper>
dup +test-wrapper+ set [

53
basis/windows/com/wrapper/wrapper.factor
View File

@ -1,11 +1,11 @@
USING: alien alien.c-types windows.com.syntax
USING: alien alien.c-types windows.com.syntax init
windows.com.syntax.private windows.com continuations kernel
namespaces windows.ole32 libc vocabs assocs accessors arrays
sequences quotations combinators math words compiler.units
destructors fry math.parser generalizations ;
destructors fry math.parser generalizations sets ;
IN: windows.com.wrapper
TUPLE: com-wrapper vtbls disposed ;
TUPLE: com-wrapper callbacks vtbls disposed ;
<PRIVATE
@ -14,6 +14,11 @@ SYMBOL: +wrapped-objects+
[ H{ } +wrapped-objects+ set-global ]
unless
SYMBOL: +live-wrappers+
+live-wrappers+ get-global
[ V{ } +live-wrappers+ set-global ]
unless
SYMBOL: +vtbl-counter+
+vtbl-counter+ get-global
[ 0 +vtbl-counter+ set-global ]
@ -82,13 +87,12 @@ unless
[ '[ , [ swap 2array ] curry map ] ] bi bi*
swap append ;
: compile-alien-callback ( word return parameters abi quot -- alien )
: compile-alien-callback ( word return parameters abi quot -- word )
'[ , , , , alien-callback ]
[ [ (( -- alien )) define-declared ] pick slip ]
with-compilation-unit
execute ;
with-compilation-unit ;
: (byte-array-to-malloced-buffer) ( byte-array -- alien )
: byte-array>malloc ( byte-array -- alien )
[ byte-length malloc ] [ over byte-array>memory ] bi ;
: (callback-word) ( function-name interface-name counter -- word )
@ -99,7 +103,7 @@ unless
[ dup empty? [ 2drop [ ] ] [ swap 1- '[ , , ndip ] ] if ]
dip compose ;
: (make-vtbl) ( interface-name quots iunknown-methods n -- vtbl )
: (make-interface-callbacks) ( interface-name quots iunknown-methods n -- words )
(thunk) (thunked-quots)
swap [ find-com-interface-definition family-tree-functions ]
keep (next-vtbl-counter) '[
@ -114,12 +118,12 @@ unless
first2 (finish-thunk)
] bi*
"stdcall" swap compile-alien-callback
] 2map >c-void*-array
(byte-array-to-malloced-buffer) ;
] 2map ;
: (make-vtbls) ( implementations -- vtbls )
: (make-callbacks) ( implementations -- sequence )
dup [ first ] map (make-iunknown-methods)
[ >r >r first2 r> r> swap (make-vtbl) ] curry map-index ;
[ >r >r first2 r> r> swap (make-interface-callbacks) ]
curry map-index ;
: (malloc-wrapped-object) ( wrapper -- wrapped-object )
vtbls>> length "void*" heap-size *
@ -127,13 +131,34 @@ unless
over <displaced-alien>
1 0 rot set-ulong-nth ;
: (callbacks>vtbl) ( callbacks -- vtbl )
[ execute ] map >c-void*-array byte-array>malloc ;
: (callbacks>vtbls) ( callbacks -- vtbls )
[ (callbacks>vtbl) ] map ;
: (allocate-wrapper) ( wrapper -- )
dup callbacks>> (callbacks>vtbls) >>vtbls
f >>disposed drop ;
: (init-hook) ( -- )
+live-wrappers+ get-global [ (allocate-wrapper) ] each
H{ } +wrapped-objects+ set-global ;
[ (init-hook) ] "windows.com.wrapper" add-init-hook
PRIVATE>
: allocate-wrapper ( wrapper -- )
[ (allocate-wrapper) ]
[ +live-wrappers+ get adjoin ] bi ;
: <com-wrapper> ( implementations -- wrapper )
(make-vtbls) f com-wrapper boa ;
(make-callbacks) f f com-wrapper boa
dup allocate-wrapper ;
M: com-wrapper dispose*
vtbls>> [ free ] each ;
[ [ free ] each f ] change-vtbls
+live-wrappers+ get-global delete ;
: com-wrap ( object wrapper -- wrapped-object )
[ vtbls>> ] [ (malloc-wrapped-object) ] bi

18
extra/bunny/cel-shaded/cel-shaded.factor
View File

@ -1,6 +1,6 @@
USING: arrays bunny.model continuations destructors kernel
multiline opengl opengl.shaders opengl.capabilities opengl.gl
sequences sequences.lib accessors ;
sequences sequences.lib accessors combinators ;
IN: bunny.cel-shaded
STRING: vertex-shader-source
@ -78,13 +78,15 @@ TUPLE: bunny-cel-shaded program ;
] [ f ] if ;
: (draw-cel-shaded-bunny) ( geom program -- )
{
{ "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
{ "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
{ "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
{ "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
{ "shininess" [ 100.0 glUniform1f ] }
} [ bunny-geom ] with-gl-program ;
[
{
[ "light_direction" glGetUniformLocation 1.0 -1.0 1.0 glUniform3f ]
[ "color" glGetUniformLocation 0.6 0.5 0.5 1.0 glUniform4f ]
[ "ambient" glGetUniformLocation 0.2 0.2 0.2 0.2 glUniform4f ]
[ "diffuse" glGetUniformLocation 0.8 0.8 0.8 0.8 glUniform4f ]
[ "shininess" glGetUniformLocation 100.0 glUniform1f ]
} cleave bunny-geom
] with-gl-program ;
M: bunny-cel-shaded draw-bunny
program>> (draw-cel-shaded-bunny) ;

15
extra/bunny/outlined/outlined.factor
View File

@ -220,13 +220,14 @@ TUPLE: bunny-outlined
[ normal-texture>> GL_TEXTURE_2D GL_TEXTURE1 bind-texture-unit ]
[ depth-texture>> GL_TEXTURE_2D GL_TEXTURE2 bind-texture-unit ]
[
pass2-program>> {
{ "colormap" [ 0 glUniform1i ] }
{ "normalmap" [ 1 glUniform1i ] }
{ "depthmap" [ 2 glUniform1i ] }
{ "line_color" [ 0.1 0.0 0.1 1.0 glUniform4f ] }
} [ { -1.0 -1.0 } { 1.0 1.0 } rect-vertices ]
with-gl-program
pass2-program>> [
{
[ "colormap" glGetUniformLocation 0 glUniform1i ]
[ "normalmap" glGetUniformLocation 1 glUniform1i ]
[ "depthmap" glGetUniformLocation 2 glUniform1i ]
[ "line_color" glGetUniformLocation 0.1 0.0 0.1 1.0 glUniform4f ]
} cleave { -1.0 -1.0 } { 1.0 1.0 } rect-vertices
] with-gl-program
]
} cleave ;

67
extra/cfdg/cfdg.factor
View File

@ -4,7 +4,8 @@ USING: kernel alien.c-types combinators namespaces arrays
math math.functions math.vectors math.trig
opengl.gl opengl.glu opengl ui ui.gadgets.slate
vars colors self self.slots
random-weighted colors.hsv cfdg.gl accessors ;
random-weighted colors.hsv cfdg.gl accessors
ui.gadgets.handler ui.gestures assocs ui.gadgets ;
IN: cfdg
@ -130,7 +131,7 @@ VAR: threshold
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: recursive ( quot -- ) iterate? swap when ;
: recursive ( quot -- ) iterate? swap when ; inline
: multi ( seq -- ) random-weighted* call ;
@ -155,6 +156,28 @@ VAR: start-shape
: set-initial-color ( -- ) T{ hsva f 0 0 0 1 } clone >self ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: dlist
! : build-model-dlist ( -- )
! 1 glGenLists dlist set
! dlist get GL_COMPILE_AND_EXECUTE glNewList
! start-shape> call
! glEndList ;
: build-model-dlist ( -- )
1 glGenLists dlist set
dlist get GL_COMPILE_AND_EXECUTE glNewList
set-initial-color
self> set-color
start-shape> call
glEndList ;
: display ( -- )
GL_PROJECTION glMatrixMode
@ -172,15 +195,43 @@ VAR: start-shape
init-modelview-matrix-stack
init-color-stack
set-initial-color
dlist get not
[ build-model-dlist ]
[ dlist get glCallList ]
if ;
self> set-color
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
start-shape> call ;
: delete-dlist ( -- ) dlist get [ dlist get 1 glDeleteLists dlist off ] when ;
: cfdg-window* ( -- )
[ display ] closed-quot <slate>
{ 500 500 } over set-slate-pdim
C[ display ] <slate>
{ 500 500 } >>pdim
C[ delete-dlist ] >>ungraft
dup "CFDG" open-window ;
: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
: cfdg-window ( -- ) [ cfdg-window* ] with-ui ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SYMBOL: the-slate
: rebuild ( -- ) delete-dlist the-slate get relayout-1 ;
: <cfdg-gadget> ( -- slate )
C[ display ] <slate>
dup the-slate set
{ 500 500 } >>pdim
C[ dlist get [ dlist get 1 glDeleteLists ] when ] >>ungraft
<handler>
H{ } clone
T{ key-down f f "ENTER" } C[ drop rebuild ] swap pick set-at
T{ button-down } C[ drop rebuild ] swap pick set-at
>>table ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
USE: fry
: cfdg-window. ( quot -- )
'[ [ @ <cfdg-gadget> "CFDG" open-window ] with-scope ] with-ui ;

13
extra/cfdg/models/aqua-star/aqua-star.factor
View File

@ -25,11 +25,12 @@ iterate? [
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run ( -- )
[ -1 b ] >background
{ -60 140 -120 140 } viewport set
0.1 threshold set
[ anemone-begin ] start-shape set
cfdg-window ;
: init ( -- )
[ -1 b ] >background
{ -60 140 -120 140 } >viewport
0.1 >threshold
[ anemone-begin ] >start-shape ;
: run ( -- ) [ init ] cfdg-window. ;
MAIN: run

13
extra/cfdg/models/chiaroscuro/chiaroscuro.factor
View File

@ -29,11 +29,12 @@ DEFER: white
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run ( -- )
[ -0.5 b ] >background
{ -3 6 -2 6 } viewport set
0.01 threshold set
[ chiaroscuro ] start-shape set
cfdg-window ;
: init ( -- )
[ -0.5 b ] >background
{ -3 6 -2 6 } >viewport
0.01 >threshold
[ chiaroscuro ] >start-shape ;
: run ( -- ) [ init ] cfdg-window. ;
MAIN: run

13
extra/cfdg/models/flower6/flower6.factor
View File

@ -18,12 +18,13 @@ iterate? [
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run ( -- )
[ ] >background
{ -1 2 -1 2 } viewport set
0.01 threshold set
[ flower6 ] start-shape set
cfdg-window ;
: init ( -- )
[ ] >background
{ -1 2 -1 2 } >viewport
0.01 >threshold
[ flower6 ] >start-shape ;
: run ( -- ) [ init ] cfdg-window. ;
MAIN: run

13
extra/cfdg/models/game1-turn6/game1-turn6.factor
View File

@ -37,11 +37,12 @@ DEFER: start
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run ( -- )
[ 66 hue 0.4 sat 0.5 b ] >background
{ -5 10 -5 10 } viewport set
0.001 >threshold
[ start ] >start-shape
cfdg-window ;
: init ( -- )
[ 66 hue 0.4 sat 0.5 b ] >background
{ -5 10 -5 10 } >viewport
0.001 >threshold
[ start ] >start-shape ;
: run ( -- ) [ init ] cfdg-window. ;
MAIN: run

13
extra/cfdg/models/lesson/lesson.factor
View File

@ -96,12 +96,13 @@ iterate? [
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run ( -- )
[ ] >background
{ -5 25 -15 25 } viewport set
0.03 threshold set
[ toc ] start-shape set
cfdg-window ;
: init ( -- )
[ ] >background
{ -5 25 -15 25 } >viewport
0.03 >threshold
[ toc ] >start-shape ;
: run ( -- ) [ init ] cfdg-window. ;
MAIN: run

7
extra/cfdg/models/rules08/rules08.factor
View File

@ -51,12 +51,13 @@ DEFER: line
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run ( -- )
: init ( -- )
[ -1 b ] >background
{ -20 40 -20 40 } viewport set
[ centre ] >start-shape
0.0001 >threshold
cfdg-window ;
0.0001 >threshold ;
: run ( -- ) [ init ] cfdg-window. ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

16
extra/cfdg/models/sierpinski/sierpinski.factor
View File

@ -26,14 +26,12 @@ iterate? [
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run ( -- )
[ ] >background
{ -4 8 -4 8 } viewport set
0.01 >threshold
[ top ] >start-shape
cfdg-window ;
MAIN: run
: init ( -- )
[ ] >background
{ -4 8 -4 8 } >viewport
0.01 >threshold
[ top ] >start-shape ;
: run ( -- ) [ init ] cfdg-window. ;
MAIN: run

13
extra/cfdg/models/snowflake/snowflake.factor
View File

@ -25,12 +25,13 @@ spike
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: run ( -- )
[ ] >background
{ -40 80 -40 80 } viewport set
0.1 threshold set
[ snowflake ] start-shape set
cfdg-window ;
: init ( -- )
[ ] >background
{ -40 80 -40 80 } >viewport
0.1 >threshold
[ snowflake ] >start-shape ;
: run ( -- ) [ init ] cfdg-window. ;
MAIN: run

42
extra/cfdg/models/spirales/spirales.factor Normal file
View File

@ -0,0 +1,42 @@
USING: namespaces sequences math random-weighted cfdg ;
IN: cfdg.models.spirales
DEFER: line
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: block ( -- )
[
[ circle ] do
[ 0.3 s 60 flip line ] do
]
recursive ;
: a1 ( -- )
[
[ 0.95 s 2 x 12 r 0.5 b 10 hue 1.5 sat a1 ] do
[ block ] do
]
recursive ;
: line ( -- )
-0.3 a
[ 0 rotate a1 ] do
[ 120 rotate a1 ] do
[ 240 rotate a1 ] do ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
: init ( -- )
[ -1 b ] >background
{ -20 40 -20 40 } viewport set
[ line ] >start-shape
0.03 >threshold ;
: run ( -- ) [ init ] cfdg-window. ;
! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
MAIN: run

1
extra/cfdg/models/spirales/tags.txt Normal file
View File

@ -0,0 +1 @@
demos

21
extra/game-input/backend/backend.factor
View File

@ -1,8 +1,19 @@
USING: kernel system combinators parser ;
USING: multiline system parser combinators ;
IN: game-input.backend
<< {
{ [ os macosx? ] [ "game-input.backend.iokit" use+ ] }
{ [ os windows? ] [ "game-input.backend.dinput" use+ ] }
STRING: set-backend-for-macosx
USING: namespaces game-input.backend.iokit game-input ;
iokit-game-input-backend game-input-backend set-global
;
STRING: set-backend-for-windows
USING: namespaces game-input.backend.dinput game-input ;
dinput-game-input-backend game-input-backend set-global
;
{
{ [ os macosx? ] [ set-backend-for-macosx eval ] }
{ [ os windows? ] [ set-backend-for-windows eval ] }
{ [ t ] [ ] }
} cond >>
} cond

9
extra/game-input/backend/dinput/dinput.factor
View File

@ -206,6 +206,13 @@ M: dinput-game-input-backend (close-game-input)
close-device-change-window
delete-dinput ;
M: dinput-game-input-backend (reset-game-input)
{
+dinput+ +keyboard-device+ +keyboard-state+
+controller-devices+ +controller-guids+
+device-change-window+ +device-change-handle+
} [ f swap set-global ] each ;
M: dinput-game-input-backend get-controllers
+controller-devices+ get
[ drop controller boa ] { } assoc>map ;
@ -278,5 +285,3 @@ M: dinput-game-input-backend read-keyboard
+keyboard-device+ get
[ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
[ ] [ f ] with-acquisition ;
dinput-game-input-backend game-input-backend set-global

6
extra/game-input/backend/iokit/iokit.factor
View File

@ -231,6 +231,10 @@ M: iokit-game-input-backend (open-game-input)
]
} cleave ;
M: iokit-game-input-backend (reset-game-input)
{ +hid-manager+ +keyboard-state+ +controller-states+ }
[ f swap set-global ] each ;
M: iokit-game-input-backend (close-game-input)
+hid-manager+ get-global [
+hid-manager+ global [
@ -271,5 +275,3 @@ M: iokit-game-input-backend read-keyboard ( -- keyboard-state )
M: iokit-game-input-backend calibrate-controller ( controller -- )
drop ;
iokit-game-input-backend game-input-backend set-global

14
extra/game-input/game-input.factor
View File

@ -1,26 +1,34 @@
USING: arrays accessors continuations kernel symbols
combinators.lib sequences namespaces init ;
combinators.lib sequences namespaces init vocabs ;
IN: game-input
SYMBOLS: game-input-backend game-input-opened ;
HOOK: (open-game-input) game-input-backend ( -- )
HOOK: (close-game-input) game-input-backend ( -- )
HOOK: (reset-game-input) game-input-backend ( -- )
: game-input-opened? ( -- ? )
game-input-opened get ;
<PRIVATE
M: f (reset-game-input) ;
: reset-game-input ( -- )
game-input-opened off ;
game-input-opened off
(reset-game-input) ;
: load-game-input-backend ( -- )
game-input-backend get
[ "game-input.backend" load-vocab drop ] unless ;
[ reset-game-input ] "game-input" add-init-hook
PRIVATE>
: open-game-input ( -- )
load-game-input-backend
game-input-opened? [
(open-game-input)
game-input-opened on

10
extra/html/streams/streams-tests.factor
View File

@ -1,6 +1,8 @@
USING: html.streams html.streams.private
io io.streams.string io.styles kernel
namespaces tools.test xml.writer sbufs sequences inspector ;
io io.streams.string io.styles kernel
namespaces tools.test xml.writer sbufs sequences inspector colors ;
IN: html.streams.tests
: make-html-string
@ -52,7 +54,7 @@ M: funky browser-link-href
[
[
"car"
H{ { foreground { 1 0 1 1 } } }
H{ { foreground T{ rgba f 1 0 1 1 } } }
format
] make-html-string
] unit-test
@ -60,7 +62,7 @@ M: funky browser-link-href
[ "<div style='background-color: #ff00ff; white-space: pre; font-family: monospace; '>cdr</div>" ]
[
[
H{ { page-color { 1 0 1 1 } } }
H{ { page-color T{ rgba f 1 0 1 1 } } }
[ "cdr" write ] with-nesting
] make-html-string
] unit-test

16
extra/html/streams/streams.factor
View File

@ -1,9 +1,11 @@
! Copyright (C) 2004, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: generic assocs help http io io.styles io.files continuations
io.streams.string kernel math math.order math.parser namespaces
quotations assocs sequences strings words html.elements
xml.entities sbufs continuations destructors accessors ;
USING: combinators generic assocs help http io io.styles io.files
continuations io.streams.string kernel math math.order math.parser
namespaces quotations assocs sequences strings words html.elements
xml.entities sbufs continuations destructors accessors arrays ;
IN: html.streams
GENERIC: browser-link-href ( presented -- href )
@ -47,9 +49,9 @@ TUPLE: html-sub-stream < html-stream style parent ;
] [ call ] if*
] [ call ] if* ; inline
: hex-color, ( triplet -- )
3 head-slice
[ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] each ;
: hex-color, ( color -- )
[ red>> ] [ green>> ] [ blue>> ] tri
[ 255 * >fixnum >hex 2 CHAR: 0 pad-left % ] tri@ ;
: fg-css, ( color -- )
"color: #" % hex-color, "; " % ;

17
extra/irc/client/client-tests.factor
View File

@ -160,7 +160,7 @@ IN: irc.client.tests
} cleave
] unit-test
! Namelist notification
! Namelist change notification
{ T{ participant-changed f f f } } [
{ ":ircserver.net 353 factorbot @ #factortest :@factorbot "
":ircserver.net 366 factorbot #factortest :End of /NAMES list." } make-client
@ -172,4 +172,19 @@ IN: irc.client.tests
[ listeners>> [ "#factortest" ] dip at [ read-message drop ] [ read-message ] bi ]
[ terminate-irc ]
} cleave
] unit-test
{ T{ participant-changed f "somedude" +part+ } } [
{ ":somedude!n=user@isp.net QUIT" } make-client
{ [ "factorbot" set-nick ]
[ listeners>>
[ "#factortest" [ <irc-channel-listener>
H{ { "somedude" +normal+ } } clone >>participants ] keep
] dip set-at ]
[ connect-irc ]
[ drop 0.1 seconds sleep ]
[ listeners>> [ "#factortest" ] dip at
[ read-message drop ] [ read-message drop ] [ read-message ] tri ]
[ terminate-irc ]
} cleave
] unit-test

27
extra/irc/client/client.factor
View File

@ -88,10 +88,11 @@ SYMBOL: current-irc-client
: irc-stream> ( -- stream ) irc> stream>> ;
: irc-write ( s -- ) irc-stream> stream-write ;
: irc-print ( s -- ) irc-stream> [ stream-print ] keep stream-flush ;
: irc-send ( irc-message -- ) irc> out-messages>> mailbox-put ;
: listener> ( name -- listener/f ) irc> listeners>> at ;
: maybe-mailbox-get ( mailbox quot: ( irc-message -- ) -- )
[ dup mailbox-empty? [ drop yield ] ] dip '[ mailbox-get @ ] if ; inline
[ dup mailbox-empty? [ drop 0.1 sleep ] ] dip '[ mailbox-get @ ] if ; inline
GENERIC: to-listener ( message obj -- )
@ -147,24 +148,6 @@ DEFER: me?
"JOIN " irc-write
[ [ " :" ] dip 3append ] when* irc-print ;
: /PART ( channel text -- )
[ "PART " irc-write irc-write ] dip
" :" irc-write irc-print ;
: /KICK ( channel who -- )
[ "KICK " irc-write irc-write ] dip
" " irc-write irc-print ;
: /PRIVMSG ( nick line -- )
[ "PRIVMSG " irc-write irc-write ] dip
" :" irc-write irc-print ;
: /ACTION ( nick line -- )
[ 1 , "ACTION " % % 1 , ] "" make /PRIVMSG ;
: /QUIT ( text -- )
"QUIT :" irc-write irc-print ;
: /PONG ( text -- )
"PONG " irc-write irc-print ;
@ -240,10 +223,14 @@ M: kick handle-incoming-irc ( kick -- )
M: quit handle-incoming-irc ( quit -- )
[ dup prefix>> parse-name listeners-with-participant
[ to-listener ] with each ]
[ prefix>> parse-name remove-participant-from-all ]
[ handle-participant-change ]
[ prefix>> parse-name remove-participant-from-all ]
tri ;
! FIXME: implement this
! M: mode handle-incoming-irc ( mode -- ) call-next-method ;
! M: nick handle-incoming-irc ( nick -- ) call-next-method ;
: >nick/mode ( string -- nick mode )
dup first "+@" member? [ unclip ] [ 0 ] if participant-mode ;

64
extra/irc/ui/ui.factor
View File

@ -2,13 +2,14 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel threads combinators concurrency.mailboxes
sequences strings hashtables splitting fry assocs hashtables
sequences strings hashtables splitting fry assocs hashtables colors
sorting qualified unicode.collation math.order
ui ui.gadgets ui.gadgets.panes ui.gadgets.editors
ui.gadgets.scrollers ui.commands ui.gadgets.frames ui.gestures
ui.gadgets.tabs ui.gadgets.grids ui.gadgets.packs ui.gadgets.labels
io io.styles namespaces calendar calendar.format models continuations
irc.client irc.client.private irc.messages irc.messages.private
irc.ui.commandparser irc.ui.load qualified ;
irc.ui.commandparser irc.ui.load ;
RENAME: join sequences => sjoin
@ -24,14 +25,8 @@ TUPLE: irc-tab < frame listener client userlist ;
: write-color ( str color -- )
foreground associate format ;
: red { 0.5 0 0 1 } ;
: green { 0 0.5 0 1 } ;
: blue { 0 0 1 1 } ;
: black { 0 0 0 1 } ;
: colors H{ { +operator+ { 0 0.5 0 1 } }
{ +voice+ { 0 0 1 1 } }
{ +normal+ { 0 0 0 1 } } } ;
: dark-red T{ rgba f 0.5 0.0 0.0 1 } ;
: dark-green T{ rgba f 0.0 0.5 0.0 1 } ;
: dot-or-parens ( string -- string )
dup empty? [ drop "." ]
@ -65,21 +60,29 @@ M: own-message write-irc
message>> write ;
M: join write-irc
"* " green write-color
"* " dark-green write-color
prefix>> parse-name write
" has entered the channel." green write-color ;
" has entered the channel." dark-green write-color ;
M: part write-irc
"* " red write-color
"* " dark-red write-color
[ prefix>> parse-name write ] keep
" has left the channel" red write-color
trailing>> dot-or-parens red write-color ;
" has left the channel" dark-red write-color
trailing>> dot-or-parens dark-red write-color ;
M: quit write-irc
"* " red write-color
"* " dark-red write-color
[ prefix>> parse-name write ] keep
" has left IRC" red write-color
trailing>> dot-or-parens red write-color ;
" has left IRC" dark-red write-color
trailing>> dot-or-parens dark-red write-color ;
M: kick write-irc
"* " dark-red write-color
[ prefix>> parse-name write ] keep
" has kicked " dark-red write-color
[ who>> write ] keep
" from the channel" dark-red write-color
trailing>> dot-or-parens dark-red write-color ;
: full-mode ( message -- mode )
parameters>> rest " " sjoin ;
@ -92,18 +95,24 @@ M: mode write-irc
" to " blue write-color
channel>> write ;
M: nick write-irc
"* " blue write-color
[ prefix>> parse-name write ] keep
" is now known as " blue write-color
trailing>> write ;
M: unhandled write-irc
"UNHANDLED: " write
line>> blue write-color ;
M: irc-end write-irc
drop "* You have left IRC" red write-color ;
drop "* You have left IRC" dark-red write-color ;
M: irc-disconnected write-irc
drop "* Disconnected" red write-color ;
drop "* Disconnected" dark-red write-color ;
M: irc-connected write-irc
drop "* Connected" green write-color ;
drop "* Connected" dark-green write-color ;
M: irc-listener-end write-irc
drop ;
@ -124,15 +133,18 @@ M: irc-message write-irc
GENERIC: handle-inbox ( tab message -- )
: filter-participants ( pack alist val color -- pack )
'[ , = [ <label> , >>color add-gadget ] [ drop ] if ] assoc-each ;
: value-labels ( assoc val -- seq )
'[ nip , = ] assoc-filter keys sort-strings [ <label> ] map ;
: add-gadget-color ( pack seq color -- pack )
'[ , >>color add-gadget ] each ;
: update-participants ( tab -- )
[ userlist>> [ clear-gadget ] keep ]
[ listener>> participants>> ] bi
[ +operator+ green filter-participants ]
[ +voice+ blue filter-participants ]
[ +normal+ black filter-participants ] tri drop ;
[ +operator+ value-labels dark-green add-gadget-color ]
[ +voice+ value-labels blue add-gadget-color ]
[ +normal+ value-labels black add-gadget-color ] tri drop ;
M: participant-changed handle-inbox
drop update-participants ;

2
extra/joystick-demo/joystick-demo.factor
View File

@ -1,6 +1,6 @@
USING: ui ui.gadgets sequences kernel arrays math colors
ui.render math.vectors accessors fry ui.gadgets.packs game-input
game-input.backend ui.gadgets.labels ui.gadgets.borders alarms
ui.gadgets.labels ui.gadgets.borders alarms
calendar locals combinators.lib strings ui.gadgets.buttons
combinators math.parser assocs threads ;
IN: joystick-demo

2
extra/key-caps/key-caps.factor
View File

@ -1,4 +1,4 @@
USING: game-input game-input.backend game-input.scancodes
USING: game-input game-input.scancodes
kernel ui.gadgets ui.gadgets.buttons sequences accessors
words arrays assocs math calendar fry alarms ui
ui.gadgets.borders ui.gestures ;

15
extra/opengl/shaders/shaders-docs.factor
View File

@ -95,18 +95,7 @@ HELP: delete-gl-program
{ $description "Deletes the program object, invalidating it and releasing any resources allocated for it by the OpenGL implementation. Any attached " { $link gl-shader } "s are also deleted.\n\nIf the shader objects should be preserved, they should each be detached using " { $link detach-gl-program-shader } ". The program object can then be destroyed alone using " { $link delete-gl-program-only } "." } ;
HELP: with-gl-program
{ $values { "program" "A " { $link gl-program } " object" } { "uniforms" "An " { $link assoc } " between uniform parameter names and quotations with effect " { $snippet "( uniform-location -- )" } } { "quot" "A quotation" } }
{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". The fixed-function pipeline is restored at the end of " { $snippet "quot" } ". Before calling " { $snippet "quot" } ", calls " { $link glGetUniformLocation } " on each key of " { $snippet "uniforms" } " to get the address of the uniform parameter, which is then placed on top of the stack as the associated quotation is called.\n\nExample:" }
{ $code <"
! From bunny.cel-shaded
: (draw-cel-shaded-bunny) ( geom program -- )
{
{ "light_direction" [ 1.0 -1.0 1.0 glUniform3f ] }
{ "color" [ 0.6 0.5 0.5 1.0 glUniform4f ] }
{ "ambient" [ 0.2 0.2 0.2 0.2 glUniform4f ] }
{ "diffuse" [ 0.8 0.8 0.8 0.8 glUniform4f ] }
{ "shininess" [ 100.0 glUniform1f ] }
} [ bunny-geom ] with-gl-program ;
"> } ;
{ $values { "program" "A " { $link gl-program } " object" } { "quot" "A quotation with stack effect " { $snippet "( program -- )" } } }
{ $description "Enables " { $snippet "program" } " for all OpenGL calls made in the dynamic extent of " { $snippet "quot" } ". " { $snippet "program" } " is left on the top of the stack when " { $snippet "quot" } " is called. The fixed-function pipeline is restored at the end of " { $snippet "quot" } "." } ;
ABOUT: "gl-utilities"

20
extra/opengl/shaders/shaders.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel opengl.gl alien.c-types continuations namespaces
assocs alien alien.strings libc opengl math sequences combinators
combinators.lib macros arrays io.encodings.ascii ;
combinators.lib macros arrays io.encodings.ascii fry ;
IN: opengl.shaders
: with-gl-shader-source-ptr ( string quot -- )
@ -107,22 +107,8 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
2dup detach-gl-program-shader delete-gl-shader
] each delete-gl-program-only ;
: (with-gl-program) ( program quot -- )
swap glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
: (with-gl-program-uniforms) ( uniforms -- quot )
[ [ swap , \ glGetUniformLocation , % ] [ ] make ]
{ } assoc>map ;
: (make-with-gl-program) ( uniforms quot -- q )
[
\ dup ,
[ swap (with-gl-program-uniforms) , \ cleave , % ]
[ ] make ,
\ (with-gl-program) ,
] [ ] make ;
MACRO: with-gl-program ( uniforms quot -- )
(make-with-gl-program) ;
: with-gl-program ( program quot -- )
over glUseProgram [ 0 glUseProgram ] [ ] cleanup ; inline
PREDICATE: gl-program < integer (gl-program?) ;

16
extra/spheres/spheres.factor
View File

@ -194,10 +194,9 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
: sphere-scene ( gadget -- )
GL_DEPTH_BUFFER_BIT GL_COLOR_BUFFER_BIT bitor glClear
[
solid-sphere-program>> dup {
{ "light_position" [ 0.0 0.0 100.0 glUniform3f ] }
} [
solid-sphere-program>> [
{
[ "light_position" glGetUniformLocation 0.0 0.0 100.0 glUniform3f ]
[ { 7.0 0.0 0.0 } 1.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
[ { -7.0 0.0 0.0 } 1.0 { 0.0 1.0 0.0 1.0 } (draw-sphere) ]
[ { 0.0 0.0 7.0 } 1.0 { 0.0 0.0 1.0 1.0 } (draw-sphere) ]
@ -207,7 +206,8 @@ M: spheres-gadget pref-dim* ( gadget -- dim )
} cleave
] with-gl-program
] [
plane-program>> { } [
plane-program>> [
drop
GL_QUADS [
-1000.0 -30.0 1000.0 glVertex3f
-1000.0 -30.0 -1000.0 glVertex3f
@ -269,10 +269,10 @@ M: spheres-gadget draw-gadget* ( gadget -- )
[ sphere-scene ]
[ reflection-texture>> GL_TEXTURE_CUBE_MAP GL_TEXTURE0 bind-texture-unit ]
[
texture-sphere-program>> dup {
{ "surface_texture" [ 0 glUniform1i ] }
} [
{ 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere)
texture-sphere-program>> [
[ "surface_texture" glGetUniformLocation 0 glUniform1i ]
[ { 0.0 0.0 0.0 } 4.0 { 1.0 0.0 0.0 1.0 } (draw-sphere) ]
bi
] with-gl-program
]
} cleave ;

8
unfinished/compiler/tree/copy-equiv/copy-equiv.factor
View File

@ -8,7 +8,8 @@ compiler.tree.combinators ;
IN: compiler.tree.copy-equiv
! Two values are copy-equivalent if they are always identical
! at run-time ("DS" relation).
! at run-time ("DS" relation). This is just a weak form of
! value numbering.
! Mapping from values to their canonical leader
SYMBOL: copies
@ -25,7 +26,8 @@ SYMBOL: copies
] if
] ;
: resolve-copy ( copy -- val ) copies get compress-path ;
: resolve-copy ( copy -- val )
copies get compress-path [ "Unknown value" throw ] unless* ;
: is-copy-of ( val copy -- ) copies get set-at ;
@ -55,7 +57,7 @@ M: #return-recursive compute-copy-equiv*
#! An output is a copy of every input if all inputs are
#! copies of the same original value.
[
swap [ resolve-copy ] map sift
swap sift [ resolve-copy ] map
dup [ all-equal? ] [ empty? not ] bi and
[ first swap is-copy-of ] [ 2drop ] if
] 2each ;

6
unfinished/compiler/tree/dataflow-analysis/dataflow-analysis.factor
View File

@ -8,11 +8,9 @@ IN: compiler.tree.dataflow-analysis
! Dataflow analysis
SYMBOL: work-list
: look-at-value ( values -- )
work-list get push-front ;
: look-at-value ( values -- ) work-list get push-front ;
: look-at-values ( values -- )
work-list get '[ , push-front ] each ;
: look-at-values ( values -- ) work-list get push-all-front ;
: look-at-inputs ( node -- ) in-d>> look-at-values ;

82
unfinished/compiler/tree/escape-analysis/allocations/allocations.factor
View File

@ -1,28 +1,84 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs namespaces sequences kernel math
stack-checker.state compiler.tree.copy-equiv ;
USING: accessors assocs namespaces sequences kernel math
combinators sets disjoint-sets fry stack-checker.state
compiler.tree.copy-equiv ;
IN: compiler.tree.escape-analysis.allocations
SYMBOL: escaping
! A map from values to one of the following:
! - f -- initial status, assigned to values we have not seen yet;
! may potentially become an allocation later
! - a sequence of values -- potentially unboxed tuple allocations
! - t -- not allocated in this procedure, can never be unboxed
! A map from values to sequences of values or 'escaping'
SYMBOL: allocations
: allocation ( value -- allocation )
resolve-copy allocations get at ;
TUPLE: slot-access slot# value ;
: record-allocation ( allocation value -- )
allocations get set-at ;
C: <slot-access> slot-access
: (allocation) ( value -- value' allocations )
resolve-copy allocations get ; inline
: allocation ( value -- allocation )
(allocation) at dup slot-access? [
[ slot#>> ] [ value>> allocation ] bi nth
allocation
] when ;
: record-allocation ( allocation value -- ) (allocation) set-at ;
: unknown-allocation ( value -- ) t swap record-allocation ;
: record-allocations ( allocations values -- )
[ record-allocation ] 2each ;
: record-slot-access ( out slot# in -- )
over zero? [ 3drop ] [ allocation ?nth swap is-copy-of ] if ;
: unknown-allocations ( values -- )
[ unknown-allocation ] each ;
! A map from values to sequences of values
SYMBOL: slot-merging
! We track escaping values with a disjoint set.
SYMBOL: escaping-values
SYMBOL: +escaping+
: <escaping-values> ( -- disjoint-set )
<disjoint-set> +escaping+ over add-atom ;
: init-escaping-values ( -- )
copies get assoc>disjoint-set +escaping+ over add-atom
escaping-values set ;
: <slot-value> ( -- value )
<value>
[ introduce-value ]
[ escaping-values get add-atom ]
[ ]
tri ;
: record-slot-access ( out slot# in -- )
over zero? [ 3drop ] [
<slot-access> swap record-allocation
] if ;
: merge-values ( in-values out-value -- )
escaping-values get '[ , , equate ] each ;
: merge-slots ( values -- value )
<value> [ introduce-value ] [ slot-merging get set-at ] [ ] tri ;
<slot-value> [ merge-values ] keep ;
: add-escaping-values ( values -- )
escaping-values get
'[ +escaping+ , equate ] each ;
: escaping-value? ( value -- ? )
+escaping+ escaping-values get equiv? ;
SYMBOL: escaping-allocations
: compute-escaping-allocations ( -- )
allocations get
[ drop escaping-value? ] assoc-filter
escaping-allocations set ;
: escaping-allocation? ( value -- ? )
escaping-allocations get key? ;

26
unfinished/compiler/tree/escape-analysis/branches/branches.factor
View File

@ -1,30 +1,34 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces sequences
USING: accessors kernel namespaces sequences sets fry
stack-checker.branches
compiler.tree
compiler.tree.propagation.branches
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.branches
SYMBOL: children-escape-data
M: #branch escape-analysis*
live-children sift [ (escape-analysis) ] each ;
: (merge-allocations) ( values -- allocation )
[
[ allocation ] map dup [ ] all? [
dup [ length ] map all-equal? [
flip
[ (merge-allocations) ] [ [ merge-slots ] map ] bi
[ record-allocations ] keep
] [ drop f ] if
] [ drop f ] if
dup [ allocation ] map sift dup empty? [ 2drop f ] [
dup [ t eq? not ] all? [
dup [ length ] map all-equal? [
nip flip
[ (merge-allocations) ] [ [ merge-slots ] map ] bi
[ record-allocations ] keep
] [ drop add-escaping-values t ] if
] [ drop add-escaping-values t ] if
] if
] map ;
: merge-allocations ( in-values out-values -- )
[ (merge-allocations) ] dip record-allocations ;
[ [ sift ] map ] dip
[ [ merge-values ] 2each ]
[ [ (merge-allocations) ] dip record-allocations ]
2bi ;
M: #phi escape-analysis*
[ [ phi-in-d>> ] [ out-d>> ] bi merge-allocations ]

189
unfinished/compiler/tree/escape-analysis/escape-analysis-tests.factor Normal file
View File

@ -0,0 +1,189 @@
IN: compiler.tree.escape-analysis.tests
USING: compiler.tree.escape-analysis
compiler.tree.escape-analysis.allocations compiler.tree.builder
compiler.tree.normalization compiler.tree.copy-equiv
compiler.tree.propagation compiler.tree.cleanup
compiler.tree.combinators compiler.tree sequences math
kernel tools.test accessors slots.private quotations.private
prettyprint classes.tuple.private classes classes.tuple ;
\ escape-analysis must-infer
GENERIC: count-unboxed-allocations* ( m node -- n )
: (count-unboxed-allocations) ( m node -- n )
out-d>> first escaping-allocation? [ 1+ ] unless ;
M: #call count-unboxed-allocations*
dup word>> \ <tuple-boa> =
[ (count-unboxed-allocations) ] [ drop ] if ;
M: #push count-unboxed-allocations*
dup literal>> class immutable-tuple-class?
[ (count-unboxed-allocations) ] [ drop ] if ;
M: node count-unboxed-allocations* drop ;
: count-unboxed-allocations ( quot -- sizes )
build-tree
normalize
compute-copy-equiv
propagate
cleanup
compute-copy-equiv
escape-analysis
0 swap [ count-unboxed-allocations* ] each-node ;
[ 0 ] [ [ [ + ] curry ] count-unboxed-allocations ] unit-test
[ 1 ] [ [ [ + ] curry drop ] count-unboxed-allocations ] unit-test
[ 1 ] [ [ [ + ] curry 3 slot ] count-unboxed-allocations ] unit-test
[ 1 ] [ [ [ + ] curry 3 slot drop ] count-unboxed-allocations ] unit-test
[ 1 ] [ [ [ + ] curry uncurry ] count-unboxed-allocations ] unit-test
[ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
[ 1 ] [ [ [ + ] curry call ] count-unboxed-allocations ] unit-test
[ 0 ] [ [ [ [ + ] curry ] [ drop [ ] ] if ] count-unboxed-allocations ] unit-test
[ 2 ] [
[ [ [ + ] curry ] [ [ * ] curry ] if uncurry ] count-unboxed-allocations
] unit-test
[ 0 ] [
[ [ [ + ] curry ] [ [ * ] curry ] if ] count-unboxed-allocations
] unit-test
[ 3 ] [
[ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if uncurry ] count-unboxed-allocations
] unit-test
[ 2 ] [
[ [ [ + ] curry 4 ] [ dup [ [ * ] curry ] [ [ / ] curry ] if uncurry ] if ] count-unboxed-allocations
] unit-test
[ 0 ] [
[ [ [ + ] curry ] [ dup [ [ * ] curry ] [ [ / ] curry ] if ] if ] count-unboxed-allocations
] unit-test
TUPLE: cons { car read-only } { cdr read-only } ;
[ 0 ] [
[
dup 0 = [
2 cons boa
] [
dup 1 = [
3 cons boa
] when
] if car>>
] count-unboxed-allocations
] unit-test
[ 3 ] [
[
dup 0 = [
2 cons boa
] [
dup 1 = [
3 cons boa
] [
4 cons boa
] if
] if car>>
] count-unboxed-allocations
] unit-test
[ 0 ] [
[
dup 0 = [
dup 1 = [
3 cons boa
] [
4 cons boa
] if
] unless car>>
] count-unboxed-allocations
] unit-test
[ 2 ] [
[
dup 0 = [
2 cons boa
] [
dup 1 = [
3 cons boa
] [
4 cons boa
] if car>>
] if
] count-unboxed-allocations
] unit-test
[ 0 ] [
[
dup 0 = [
2 cons boa
] [
dup 1 = [
3 cons boa dup .
] [
4 cons boa
] if
] if drop
] count-unboxed-allocations
] unit-test
[ 2 ] [
[
[ dup cons boa ] [ drop 1 2 cons boa ] if car>>
] count-unboxed-allocations
] unit-test
[ 2 ] [
[
3dup
[ cons boa ] [ cons boa 3 cons boa ] if
[ car>> ] [ cdr>> ] bi
] count-unboxed-allocations
] unit-test
[ 2 ] [
[
3dup [ cons boa ] [ cons boa . 1 2 cons boa ] if
[ car>> ] [ cdr>> ] bi
] count-unboxed-allocations
] unit-test
[ 1 ] [
[ [ 3 cons boa ] [ "A" throw ] if car>> ]
count-unboxed-allocations
] unit-test
[ 0 ] [
[ 10 [ drop ] each-integer ] count-unboxed-allocations
] unit-test
[ 2 ] [
[
1 2 cons boa 10 [ 2drop 1 2 cons boa ] each-integer car>>
] count-unboxed-allocations
] unit-test
[ 0 ] [
[
1 2 cons boa 10 [ drop 2 cons boa ] each-integer car>>
] count-unboxed-allocations
] unit-test
: infinite-cons-loop ( a -- b ) 2 cons boa infinite-cons-loop ; inline recursive
[ 0 ] [
[
1 2 cons boa infinite-cons-loop
] count-unboxed-allocations
] unit-test

13
unfinished/compiler/tree/escape-analysis/escape-analysis.factor
View File

@ -1,18 +1,19 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces search-dequeues
USING: kernel namespaces search-dequeues assocs fry sequences
disjoint-sets
compiler.tree
compiler.tree.def-use
compiler.tree.copy-equiv
compiler.tree.escape-analysis.allocations
compiler.tree.escape-analysis.recursive
compiler.tree.escape-analysis.branches
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.simple
compiler.tree.escape-analysis.work-list ;
compiler.tree.escape-analysis.simple ;
IN: compiler.tree.escape-analysis
: escape-analysis ( node -- node )
H{ } clone slot-merging set
init-escaping-values
H{ } clone allocations set
<hashed-dlist> work-list set
dup (escape-analysis) ;
dup (escape-analysis)
compute-escaping-allocations ;

25
unfinished/compiler/tree/escape-analysis/recursive/recursive.factor
View File

@ -10,12 +10,16 @@ compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.recursive
: congruent? ( alloc1 alloc2 -- ? )
2dup [ length ] bi@ = [
[ [ allocation ] bi@ congruent? ] 2all?
] [ 2drop f ] if ;
{
{ [ 2dup [ f eq? ] either? ] [ eq? ] }
{ [ 2dup [ t eq? ] either? ] [ eq? ] }
{ [ 2dup [ length ] bi@ = not ] [ 2drop f ] }
[ [ [ allocation ] bi@ congruent? ] 2all? ]
} cond ;
: check-fixed-point ( node alloc1 alloc2 -- node )
congruent? [ dup label>> f >>fixed-point drop ] unless ; inline
[ congruent? ] 2all?
[ dup label>> f >>fixed-point drop ] unless ; inline
: node-input-allocations ( node -- allocations )
in-d>> [ allocation ] map ;
@ -27,13 +31,18 @@ IN: compiler.tree.escape-analysis.recursive
[ label>> calls>> [ in-d>> ] map ] [ in-d>> ] bi suffix ;
: analyze-recursive-phi ( #enter-recursive -- )
[ ] [ recursive-stacks flip (merge-allocations) ] [ out-d>> ] tri
[ [ allocation ] map check-fixed-point drop ] 2keep
record-allocations ;
[ ] [ recursive-stacks flip ] [ out-d>> ] tri
[ [ merge-values ] 2each ]
[
[ (merge-allocations) ] dip
[ [ allocation ] map check-fixed-point drop ]
[ record-allocations ]
2bi
] 2bi ;
M: #recursive escape-analysis* ( #recursive -- )
[
copies [ clone ] change
! copies [ clone ] change
child>>
[ first analyze-recursive-phi ]

36
unfinished/compiler/tree/escape-analysis/simple/simple.factor
View File

@ -2,33 +2,57 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences classes.tuple
classes.tuple.private math math.private slots.private
combinators dequeues search-dequeues namespaces fry
combinators dequeues search-dequeues namespaces fry classes
stack-checker.state
compiler.tree
compiler.tree.propagation.info
compiler.tree.escape-analysis.nodes
compiler.tree.escape-analysis.work-list
compiler.tree.escape-analysis.allocations ;
IN: compiler.tree.escape-analysis.simple
M: #introduce escape-analysis*
value>> unknown-allocation ;
: record-literal-allocation ( value object -- )
dup class immutable-tuple-class? [
tuple-slots rest-slice
[ <slot-value> [ swap record-literal-allocation ] keep ] map
swap record-allocation
] [
drop unknown-allocation
] if ;
M: #push escape-analysis*
#! Delegation.
[ out-d>> first ] [ literal>> ] bi record-literal-allocation ;
: record-tuple-allocation ( #call -- )
#! Delegation.
dup dup in-d>> peek node-value-info literal>>
class>> all-slots rest-slice [ read-only>> ] all? [
class>> immutable-tuple-class? [
[ in-d>> but-last ] [ out-d>> first ] bi
record-allocation
] [ drop ] if ;
] [ out-d>> unknown-allocations ] if ;
: record-slot-call ( #call -- )
[ out-d>> first ]
[ dup in-d>> second node-value-info literal>> ]
[ in-d>> first ] tri
over fixnum? [ [ 3 - ] dip record-slot-access ] [ 3drop ] if ;
over fixnum? [
[ 3 - ] dip record-slot-access
] [
2drop unknown-allocation
] if ;
M: #call escape-analysis*
dup word>> {
{ \ <tuple-boa> [ record-tuple-allocation ] }
{ \ slot [ record-slot-call ] }
[ drop in-d>> add-escaping-values ]
[
drop
[ in-d>> add-escaping-values ]
[ out-d>> unknown-allocations ] bi
]
} case ;
M: #return escape-analysis*

9
unfinished/compiler/tree/escape-analysis/work-list/work-list.factor
View File

@ -1,9 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: dequeues namespaces sequences fry ;
IN: compiler.tree.escape-analysis.work-list
SYMBOL: work-list
: add-escaping-values ( values -- )
work-list get '[ , push-front ] each ;

2
unfinished/compiler/tree/propagation/branches/branches.factor
View File

@ -59,7 +59,7 @@ SYMBOL: infer-children-data
: compute-phi-input-infos ( phi-in -- phi-info )
infer-children-data get
'[ , [ [ value-info ] bind ] 2map ] map ;
'[ , [ [ [ value-info ] [ null-info ] if* ] bind ] 2map ] map ;
: annotate-phi-inputs ( #phi -- )
dup phi-in-d>> compute-phi-input-infos >>phi-info-d