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

Merge branch 'master' of git://github.com/erikcharlebois/factor

release
Slava Pestov 2010-01-31 18:29:15 +13:00
parent c5c94ef1f9 0770b940b0
commit d762c8bfb3
22 changed files with 3024 additions and 1940 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

176
Nmakefile
View File

@ -1,88 +1,88 @@
!IF DEFINED(DEBUG) !IF DEFINED(DEBUG)
LINK_FLAGS = /nologo /DEBUG shell32.lib LINK_FLAGS = /nologo /DEBUG shell32.lib
CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG CL_FLAGS = /nologo /Zi /O2 /W3 /DFACTOR_DEBUG
!ELSE !ELSE
LINK_FLAGS = /nologo shell32.lib LINK_FLAGS = /nologo shell32.lib
CL_FLAGS = /nologo /O2 /W3 CL_FLAGS = /nologo /O2 /W3
!ENDIF !ENDIF
EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res EXE_OBJS = factor.dll.lib vm\main-windows-nt.obj vm\factor.res
DLL_OBJS = vm\os-windows-nt.obj \ DLL_OBJS = vm\os-windows-nt.obj \
vm\os-windows.obj \ vm\os-windows.obj \
vm\aging_collector.obj \ vm\aging_collector.obj \
vm\alien.obj \ vm\alien.obj \
vm\arrays.obj \ vm\arrays.obj \
vm\bignum.obj \ vm\bignum.obj \
vm\booleans.obj \ vm\booleans.obj \
vm\byte_arrays.obj \ vm\byte_arrays.obj \
vm\callbacks.obj \ vm\callbacks.obj \
vm\callstack.obj \ vm\callstack.obj \
vm\code_blocks.obj \ vm\code_blocks.obj \
vm\code_heap.obj \ vm\code_heap.obj \
vm\compaction.obj \ vm\compaction.obj \
vm\contexts.obj \ vm\contexts.obj \
vm\data_heap.obj \ vm\data_heap.obj \
vm\data_heap_checker.obj \ vm\data_heap_checker.obj \
vm\debug.obj \ vm\debug.obj \
vm\dispatch.obj \ vm\dispatch.obj \
vm\entry_points.obj \ vm\entry_points.obj \
vm\errors.obj \ vm\errors.obj \
vm\factor.obj \ vm\factor.obj \
vm\free_list.obj \ vm\free_list.obj \
vm\full_collector.obj \ vm\full_collector.obj \
vm\gc.obj \ vm\gc.obj \
vm\image.obj \ vm\image.obj \
vm\inline_cache.obj \ vm\inline_cache.obj \
vm\instruction_operands.obj \ vm\instruction_operands.obj \
vm\io.obj \ vm\io.obj \
vm\jit.obj \ vm\jit.obj \
vm\math.obj \ vm\math.obj \
vm\nursery_collector.obj \ vm\nursery_collector.obj \
vm\object_start_map.obj \ vm\object_start_map.obj \
vm\objects.obj \ vm\objects.obj \
vm\primitives.obj \ vm\primitives.obj \
vm\profiler.obj \ vm\profiler.obj \
vm\quotations.obj \ vm\quotations.obj \
vm\run.obj \ vm\run.obj \
vm\strings.obj \ vm\strings.obj \
vm\to_tenured_collector.obj \ vm\to_tenured_collector.obj \
vm\tuples.obj \ vm\tuples.obj \
vm\utilities.obj \ vm\utilities.obj \
vm\vm.obj \ vm\vm.obj \
vm\words.obj vm\words.obj
.cpp.obj: .cpp.obj:
cl /EHsc $(CL_FLAGS) /Fo$@ /c $< cl /EHsc $(CL_FLAGS) /Fo$@ /c $<
.c.obj: .c.obj:
cl $(CL_FLAGS) /Fo$@ /c $< cl $(CL_FLAGS) /Fo$@ /c $<
.rs.res: .rs.res:
rc $< rc $<
all: factor.com factor.exe all: factor.com factor.exe
libfactor-ffi-test.dll: vm/ffi_test.obj libfactor-ffi-test.dll: vm/ffi_test.obj
link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj link $(LINK_FLAGS) /out:libfactor-ffi-test.dll /dll vm/ffi_test.obj
factor.dll.lib: $(DLL_OBJS) factor.dll.lib: $(DLL_OBJS)
link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS) link $(LINK_FLAGS) /implib:factor.dll.lib /out:factor.dll /dll $(DLL_OBJS)
factor.com: $(EXE_OBJS) factor.com: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS) link $(LINK_FLAGS) /out:factor.com /SUBSYSTEM:console $(EXE_OBJS)
factor.exe: $(EXE_OBJS) factor.exe: $(EXE_OBJS)
link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS) link $(LINK_FLAGS) /out:factor.exe /SUBSYSTEM:windows $(EXE_OBJS)
clean: clean:
del vm\*.obj del vm\*.obj
del factor.lib del factor.lib
del factor.com del factor.com
del factor.exe del factor.exe
del factor.dll del factor.dll
del factor.dll.lib del factor.dll.lib
.PHONY: all clean .PHONY: all clean
.SUFFIXES: .rs .SUFFIXES: .rs

93
basis/collada/collada-docs.factor Normal file
View File

@ -0,0 +1,93 @@
! Copyright (C) 2010 Erik Charlebois
! See http://factorcode.org/license.txt for BSD license.
USING: help.markup help.crossref help.stylesheet help.topics help.syntax
definitions io prettyprint summary arrays math sequences vocabs strings
see xml.data hashtables ;
IN: collada
ABOUT: "collada"
ARTICLE: "collada" "Conversion of COLLADA assets"
"The " { $vocab-link "collada" } " vocabulary implements words for converting COLLADA assets to data suitable for use with OpenGL. See the COLLADA documentation at " { $url "http://collada.org" } "." ;
HELP: model
{ $class-description "Tuple of a packed attribute buffer, index buffer and vertex format suitable for a single OpenGL draw call." } ;
HELP: source
{ $class-description "Tuple of a vertex attribute semantic, offset in triangle index buffer and float data for a single vertex attribute." } ;
HELP: up-axis
{ $description "Dynamically-scoped variable with the up axis of the tags being read." } ;
HELP: unit-ratio
{ $description "Scaling ratio for the coordinates of the tags being read." } ;
HELP: missing-attr
{ $description "An error thrown when an attribute is missing from a tag." } ;
HELP: missing-child
{ $description "An error thrown when a child is missing from a tag." } ;
HELP: string>numbers ( string -- number-seq )
{ $values { "string" string } { "number-seq" sequence } }
{ $description "Splits a string on whitespace and converts the elements to a number sequence" } ;
HELP: x-up { $class-description "Right-handed 3D coordinate system where X is up." } ;
HELP: y-up { $class-description "Right-handed 3D coordinate system where Y is up." } ;
HELP: z-up { $class-description "Right-handed 3D coordinate system where Z is up." } ;
HELP: >y-up-axis!
{ $values { "sequence" sequence } { "from-axis" rh-up } { "sequence" sequence } }
{ $description "Destructively swizzles the first three elements of the input sequence to a right-handed 3D coordinate system where Y is up and returns the modified sequence." } ;
HELP: source>seq
{ $values { "source-tag" tag } { "up-axis" rh-up } { "scale" number } { "sequence" sequence } }
{ $description "Convert the " { $emphasis "float_array" } " in a " { $emphasis "source tag" } " to a sequence of number sequences according to the element stride. The values are scaled according to " { $emphasis "scale" } " and swizzled from " { $emphasis "up-axis" } " so that the Y coordinate points up." } ;
HELP: source>pair
{ $values { "source-tag" tag } { "pair" pair } }
{ $description "Convert the source tag to an id and number sequence pair." } ;
HELP: mesh>sources
{ $values { "mesh-tag" tag } { "hashtable" pair } }
{ $description "Convert the mesh tag's source elements to a hashtable from id to number sequence." } ;
HELP: mesh>vertices
{ $values { "mesh-tag" tag } { "pair" pair } }
{ $description "Convert the mesh tag's vertices element to a pair for further lookup in " { $link collect-sources } ". " } ;
HELP: collect-sources
{ $values { "sources" hashtable } { "vertices" pair } { "inputs" tag sequence } { "soures" sequence } }
{ $description "Look up the sources for these " { $emphasis "input" } " elements and return a sequence of " { $link source } " tuples." } ;
HELP: group-indices
{ $values { "index-stride" number } { "triangle-count" number } { indices "sequence" } { "grouped-indices" sequence } }
{ $description "Groups the index sequence by triangle and then groups each triangle's indices by vertex." } ;
HELP: triangles>numbers
{ $values { "triangles-tag" tag } { "number-seq" sequence } }
{ $description "Converts the triangle data in a triangles tag from string form to a sequence of numbers." } ;
HELP: largest-offset+1
{ $values { "source-seq" sequence } { "largest-offset+1" number } }
{ $description "Finds the largest offset in the sequence of " { $link source } " tuples and adds 1, which is the index stride for " { $link group-indices } "." } ;
HELP: <model>
{ $values { "attribute-buffer" sequence } { "index-buffer" sequence } { "sources" sequence } { "model" model } }
{ $description "Converts the inputs to a form suitable for use with " { $vocab-link "gpu" } " and constructs a " { $link model } "." } ;
HELP: soa>aos
{ $values { "triangles-indices" sequence } { "sources" sequence } { "attribute-buffer" sequence } { "index-buffer" sequence } }
{ $description "Swizzles the input sources from a structure of arrays form to an array of structures form and generates a new index buffer." } ;
HELP: triangles>model
{ $values { "sources" sequence } { "vertices" pair } { "triangles-tag" tag } { "model" model } }
{ $description "Creates a " { $link model } " tuple from the given triangles tag, source set and vertices pair." } ;
HELP: mesh>triangles
{ $values { "souces" sequence } { "vertices" pair } { "mesh-tag" tag } { "models" sequence } }
{ $description "Creates a sequence of models from the triangles in the mesh tag." } ;
HELP: mesh>models
{ $values { "mesh-tag" tag } { "models" sequence } }
{ $description "Converts a triangle mesh to a set of models suitable for rendering with OpenGL." } ;

182
basis/collada/collada.factor Normal file
View File

@ -0,0 +1,182 @@
! Copyright (C) 2010 Erik Charlebois
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs grouping hashtables kernel
locals math math.parser sequences sequences.deep
specialized-arrays.instances.alien.c-types.float
specialized-arrays.instances.alien.c-types.uint splitting xml
xml.data xml.traversal math.order
namespaces combinators images gpu.shaders io ;
IN: collada
TUPLE: model attribute-buffer index-buffer vertex-format ;
TUPLE: source semantic offset data ;
SYMBOLS: up-axis unit-ratio ;
ERROR: missing-attr tag attr ;
ERROR: missing-child tag child-name ;
: string>numbers ( string -- number-seq )
" \t\n" split [ string>number ] map ;
: x/ ( tag child-name -- child-tag )
[ tag-named ]
[ rot dup [ drop missing-child ] unless 2nip ]
2bi ; inline
: x@ ( tag attr-name -- attr-value )
[ attr ]
[ rot dup [ drop missing-attr ] unless 2nip ]
2bi ; inline
: xt ( tag -- content ) children>string ;
: x* ( tag child-name quot -- seq )
[ tags-named ] dip map ; inline
SINGLETONS: x-up y-up z-up ;
UNION: rh-up x-up y-up z-up ;
GENERIC: >y-up-axis! ( seq from-axis -- seq )
M: x-up >y-up-axis!
drop dup
[
[ 0 swap nth ]
[ 1 swap nth neg ]
[ 2 swap nth ] tri
swap -rot
] [
[ 2 swap set-nth ]
[ 1 swap set-nth ]
[ 0 swap set-nth ] tri
] bi ;
M: y-up >y-up-axis! drop ;
M: z-up >y-up-axis!
drop dup
[
[ 0 swap nth ]
[ 1 swap nth neg ]
[ 2 swap nth ] tri
swap
] [
[ 2 swap set-nth ]
[ 1 swap set-nth ]
[ 0 swap set-nth ] tri
] bi ;
: source>seq ( source-tag up-axis scale -- sequence )
rot
[ "float_array" x/ xt string>numbers [ * ] with map ]
[ nip "technique_common" x/ "accessor" x/ "stride" x@ string>number ] 2bi
<groups>
[ swap >y-up-axis! ] with map ;
: source>pair ( source-tag -- pair )
[ "id" x@ ]
[ up-axis get unit-ratio get source>seq ] bi 2array ;
: mesh>sources ( mesh-tag -- hashtable )
"source" [ source>pair ] x* >hashtable ;
: mesh>vertices ( mesh-tag -- pair )
"vertices" x/
[ "id" x@ ]
[ "input"
[
[ "semantic" x@ ]
[ "source" x@ ] bi 2array
] x*
] bi 2array ;
:: collect-sources ( sources vertices inputs -- sources )
inputs
[| input |
input "source" x@ rest vertices first =
[
vertices second [| vertex |
vertex first
input "offset" x@ string>number
vertex second rest sources at source boa
] map
]
[
input [ "semantic" x@ ]
[ "offset" x@ string>number ]
[ "source" x@ rest sources at ] tri source boa
] if
] map flatten ;
: group-indices ( index-stride triangle-count indices -- grouped-indices )
dup length rot / <groups> swap [ <groups> ] curry map ;
: triangles>numbers ( triangles-tag -- number-seq )
"p" x/ children>string " \t\n" split [ string>number ] map ;
: largest-offset+1 ( source-seq -- largest-offset+1 )
[ offset>> ] [ max ] map-reduce 1 + ;
: <model> ( attribute-buffer index-buffer sources -- model )
[ flatten >float-array ]
[ flatten >uint-array ]
[
[
{
[ semantic>> ]
[ drop float-components ]
[ data>> first length ]
[ drop f ]
} cleave vertex-attribute boa
] map
] tri* model boa ;
:: soa>aos ( triangles-indices sources -- attribute-buffer index-buffer )
V{ } clone :> attribute-buffer
V{ } clone :> index-buffer
H{ } clone :> inverse-attribute-buffer
triangles-indices [
[
[| triangle-index triangle-offset |
triangle-index triangle-offset sources
[| index offset source |
source offset>> offset = [
index source data>> nth
] [ f ] if
] with with map sift flatten :> attributes
attributes inverse-attribute-buffer at [
index-buffer push
] [
attribute-buffer length
[ attributes inverse-attribute-buffer set-at ]
[ index-buffer push ] bi
attributes attribute-buffer push
] if*
] each-index
] each
] each
attribute-buffer index-buffer ;
: triangles>model ( sources vertices triangles-tag -- model )
[ "input" tags-named collect-sources ] keep swap
[
largest-offset+1 swap
[ "count" x@ string>number ] [ triangles>numbers ] bi
group-indices
]
[
[ soa>aos ] keep <model>
] bi ;
: mesh>triangles ( sources vertices mesh-tag -- models )
"triangles" tags-named [ triangles>model ] with with map ;
: mesh>models ( mesh-tag -- models )
[
{ { up-axis z-up } { unit-ratio 0.5 } } [
mesh>sources
] bind
]
[ mesh>vertices ]
[ mesh>triangles ] tri ;

195
basis/collada/viewer/viewer.factor Normal file
View File

@ -0,0 +1,195 @@
! Copyright (C) 2010 Erik Charlebois
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types arrays classes.struct combinators
combinators.short-circuit game.loop game.worlds gpu gpu.buffers
gpu.util.wasd gpu.framebuffers gpu.render gpu.shaders gpu.state
gpu.textures gpu.util grouping http.client images images.loader
io io.encodings.ascii io.files io.files.temp kernel locals math
math.matrices math.vectors.simd math.parser math.vectors
method-chains namespaces sequences splitting threads ui ui.gadgets
ui.gadgets.worlds ui.pixel-formats specialized-arrays
specialized-vectors literals collada fry xml xml.traversal sequences.deep
opengl.gl
prettyprint ;
FROM: alien.c-types => float ;
SPECIALIZED-ARRAY: float
SPECIALIZED-VECTOR: uint
IN: collada.viewer
GLSL-SHADER: collada-vertex-shader vertex-shader
uniform mat4 mv_matrix, p_matrix;
uniform vec3 light_position;
attribute vec3 POSITION;
attribute vec3 NORMAL;
void main()
{
vec4 position = mv_matrix * vec4(POSITION, 1.0);
gl_Position = p_matrix * position;
}
;
GLSL-SHADER: collada-fragment-shader fragment-shader
void main()
{
gl_FragColor = vec4(1, 1, 0, 1);
}
;
GLSL-PROGRAM: collada-program
collada-vertex-shader collada-fragment-shader ;
GLSL-SHADER: debug-vertex-shader vertex-shader
uniform mat4 mv_matrix, p_matrix;
uniform vec3 light_position;
attribute vec3 POSITION;
attribute vec3 COLOR;
varying vec4 color;
void main()
{
gl_Position = p_matrix * mv_matrix * vec4(POSITION, 1.0);
color = vec4(COLOR, 1);
}
;
GLSL-SHADER: debug-fragment-shader fragment-shader
varying vec4 color;
void main()
{
gl_FragColor = color;
}
;
GLSL-PROGRAM: debug-program debug-vertex-shader debug-fragment-shader ;
UNIFORM-TUPLE: collada-uniforms < mvp-uniforms
{ "light-position" vec3-uniform f } ;
TUPLE: collada-state
models
vertex-arrays
index-vectors ;
TUPLE: collada-world < wasd-world
{ collada collada-state } ;
VERTEX-FORMAT: collada-vertex
{ "POSITION" float-components 3 f }
{ "NORMAL" float-components 3 f } ;
VERTEX-FORMAT: debug-vertex
{ "POSITION" float-components 3 f }
{ "COLOR" float-components 3 f } ;
: <collada-buffers> ( models -- buffers )
! drop
! float-array{ -0.5 0 0 1 0 0 0 1 0 0 1 0 0.5 0 0 0 0 1 }
! uint-array{ 0 1 2 }
! f model boa 1array
[
[ attribute-buffer>> underlying>> static-upload draw-usage vertex-buffer byte-array>buffer ]
[ index-buffer>> underlying>> static-upload draw-usage index-buffer byte-array>buffer ]
[ index-buffer>> length ] tri 3array
] map ;
: fill-collada-state ( collada-state -- )
dup models>> <collada-buffers>
[
[
first collada-program <program-instance> collada-vertex buffer>vertex-array
] map >>vertex-arrays drop
]
[
[
[ second ] [ third ] bi
'[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
] map >>index-vectors drop
] 2bi ;
: <collada-state> ( -- collada-state )
collada-state new
#! "C:/Users/erikc/Downloads/mech.dae"
"/Users/erikc/Documents/mech.dae"
file>xml "mesh" deep-tags-named [ mesh>models ] map flatten >>models ;
M: collada-world begin-game-world
init-gpu
{ 0.0 0.0 2.0 } 0 0 set-wasd-view
<collada-state> [ fill-collada-state drop ] [ >>collada drop ] 2bi ;
: <collada-uniforms> ( world -- uniforms )
[ wasd-mv-matrix ] [ wasd-p-matrix ] bi
{ -10000.0 10000.0 10000.0 } ! light position
collada-uniforms boa ;
: draw-line ( world from to color -- )
[ 3 head ] tri@ dup -rot append -rot append swap append >float-array
underlying>> stream-upload draw-usage vertex-buffer byte-array>buffer
debug-program <program-instance> debug-vertex buffer>vertex-array
{ 0 1 } >uint-array stream-upload draw-usage index-buffer byte-array>buffer
2 '[ _ 0 <buffer-ptr> _ uint-indexes <index-elements> ] call
rot <collada-uniforms>
{
{ "primitive-mode" [ 3drop lines-mode ] }
{ "uniforms" [ nip nip ] }
{ "vertex-array" [ drop drop ] }
{ "indexes" [ drop nip ] }
} 3<render-set> render ;
: draw-lines ( world lines -- )
3 <groups> [ first3 draw-line ] with each ; inline
: draw-axes ( world -- )
{ { 0 0 0 } { 1 0 0 } { 1 0 0 }
{ 0 0 0 } { 0 1 0 } { 0 1 0 }
{ 0 0 0 } { 0 0 1 } { 0 0 1 } } draw-lines ;
: draw-collada ( world -- )
GL_COLOR_BUFFER_BIT glClear
[
triangle-lines dup t <triangle-state> set-gpu-state
[ collada>> vertex-arrays>> ]
[ collada>> index-vectors>> ]
[ <collada-uniforms> ]
tri
[
{
{ "primitive-mode" [ 3drop triangles-mode ] }
{ "uniforms" [ nip nip ] }
{ "vertex-array" [ drop drop ] }
{ "indexes" [ drop nip ] }
} 3<render-set> render
] curry 2each
]
[
draw-axes
]
bi ;
M: collada-world draw-world*
draw-collada ;
M: collada-world wasd-movement-speed drop 1/16. ;
M: collada-world wasd-near-plane drop 1/32. ;
M: collada-world wasd-far-plane drop 1024.0 ;
GAME: collada-game {
{ world-class collada-world }
{ title "Collada Viewer" }
{ pixel-format-attributes {
windowed
double-buffered
} }
{ grab-input? t }
{ use-game-input? t }
{ pref-dim { 1024 768 } }
{ tick-interval-micros $[ 60 fps ] }
} ;

118
basis/concurrency/combinators/combinators.factor
View File

@ -1,59 +1,59 @@
! Copyright (C) 2008 Slava Pestov. ! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: concurrency.futures concurrency.count-downs sequences USING: concurrency.futures concurrency.count-downs sequences
kernel macros fry combinators generalizations ; kernel macros fry combinators generalizations ;
IN: concurrency.combinators IN: concurrency.combinators
<PRIVATE <PRIVATE
: (parallel-each) ( n quot -- ) : (parallel-each) ( n quot -- )
[ <count-down> ] dip keep await ; inline [ <count-down> ] dip keep await ; inline
PRIVATE> PRIVATE>
: parallel-each ( seq quot -- ) : parallel-each ( seq quot -- )
over length [ over length [
'[ _ curry _ spawn-stage ] each '[ _ curry _ spawn-stage ] each
] (parallel-each) ; inline ] (parallel-each) ; inline
: 2parallel-each ( seq1 seq2 quot -- ) : 2parallel-each ( seq1 seq2 quot -- )
2over min-length [ 2over min-length [
'[ _ 2curry _ spawn-stage ] 2each '[ _ 2curry _ spawn-stage ] 2each
] (parallel-each) ; inline ] (parallel-each) ; inline
: parallel-filter ( seq quot -- newseq ) : parallel-filter ( seq quot -- newseq )
over [ selector [ parallel-each ] dip ] dip like ; inline over [ selector [ parallel-each ] dip ] dip like ; inline
<PRIVATE <PRIVATE
: [future] ( quot -- quot' ) '[ _ curry future ] ; inline : [future] ( quot -- quot' ) '[ _ curry future ] ; inline
: future-values ( futures -- futures ) : future-values ( futures -- futures )
[ ?future ] map! ; inline [ ?future ] map! ; inline
PRIVATE> PRIVATE>
: parallel-map ( seq quot -- newseq ) : parallel-map ( seq quot -- newseq )
[future] map future-values ; inline [future] map future-values ; inline
: 2parallel-map ( seq1 seq2 quot -- newseq ) : 2parallel-map ( seq1 seq2 quot -- newseq )
'[ _ 2curry future ] 2map future-values ; '[ _ 2curry future ] 2map future-values ;
<PRIVATE <PRIVATE
: (parallel-spread) ( n -- spread-array ) : (parallel-spread) ( n -- spread-array )
[ ?future ] <repetition> ; inline [ ?future ] <repetition> ; inline
: (parallel-cleave) ( quots -- quot-array spread-array ) : (parallel-cleave) ( quots -- quot-array spread-array )
[ [future] ] map dup length (parallel-spread) ; inline [ [future] ] map dup length (parallel-spread) ; inline
PRIVATE> PRIVATE>
MACRO: parallel-cleave ( quots -- ) MACRO: parallel-cleave ( quots -- )
(parallel-cleave) '[ _ cleave _ spread ] ; (parallel-cleave) '[ _ cleave _ spread ] ;
MACRO: parallel-spread ( quots -- ) MACRO: parallel-spread ( quots -- )
(parallel-cleave) '[ _ spread _ spread ] ; (parallel-cleave) '[ _ spread _ spread ] ;
MACRO: parallel-napply ( quot n -- ) MACRO: parallel-napply ( quot n -- )
[ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ; [ [future] ] dip dup (parallel-spread) '[ _ _ napply _ spread ] ;

3
basis/game/input/input.factor
View File

@ -18,6 +18,7 @@ HOOK: instance-id game-input-backend ( controller -- id )
HOOK: read-controller game-input-backend ( controller -- controller-state ) HOOK: read-controller game-input-backend ( controller -- controller-state )
HOOK: calibrate-controller game-input-backend ( controller -- ) HOOK: calibrate-controller game-input-backend ( controller -- )
HOOK: vibrate-controller game-input-backend ( controller motor1 motor2 -- )
HOOK: read-keyboard game-input-backend ( -- keyboard-state ) HOOK: read-keyboard game-input-backend ( -- keyboard-state )
@ -90,7 +91,7 @@ M: mouse-state clone
call-next-method dup buttons>> clone >>buttons ; call-next-method dup buttons>> clone >>buttons ;
{ {
{ [ os windows? ] [ "game.input.dinput" require ] } { [ os windows? ] [ "game.input.xinput" require ] }
{ [ os macosx? ] [ "game.input.iokit" require ] } { [ os macosx? ] [ "game.input.iokit" require ] }
{ [ t ] [ ] } { [ t ] [ ] }
} cond } cond

1
basis/game/input/xinput/authors.txt Normal file
View File

@ -0,0 +1 @@
Erik Charlebois

1
basis/game/input/xinput/summary.txt Normal file
View File

@ -0,0 +1 @@
XInput backend for game.input, borrows keyboard and mouse handling from game.input.dinput

2
basis/game/input/xinput/tags.txt Normal file
View File

@ -0,0 +1,2 @@
unportable
games

142
basis/game/input/xinput/xinput.factor Normal file
View File

@ -0,0 +1,142 @@
USING: game.input math math.order kernel macros fry sequences quotations
arrays windows.directx.xinput combinators accessors windows.types
game.input.dinput sequences.private namespaces classes.struct
windows.errors windows.com.syntax io.encodings.utf16n alien.strings ;
IN: game.input.xinput
SINGLETON: xinput-game-input-backend
xinput-game-input-backend game-input-backend set-global
<PRIVATE
: >axis ( short -- float )
32768 /f ; inline
: >trigger ( byte -- float )
255 /f ; inline
: >vibration ( float -- short )
65535 * >fixnum 0 65535 clamp ; inline
MACRO: map-index-compose ( seq quot -- seq )
'[ '[ _ execute _ ] _ compose ] map-index 1quotation ;
: fill-buttons ( button-bitmap -- button-array )
10 0.0 <array> dup rot >fixnum
{ XINPUT_GAMEPAD_START
XINPUT_GAMEPAD_BACK
XINPUT_GAMEPAD_LEFT_THUMB
XINPUT_GAMEPAD_RIGHT_THUMB
XINPUT_GAMEPAD_LEFT_SHOULDER
XINPUT_GAMEPAD_RIGHT_SHOULDER
XINPUT_GAMEPAD_A
XINPUT_GAMEPAD_B
XINPUT_GAMEPAD_X
XINPUT_GAMEPAD_Y }
[ [ bitand ] dip swap 0 = [ 2drop ] [ 1.0 -rot swap set-nth ] if ]
map-index-compose 2cleave ;
: >pov ( byte -- symbol )
{
pov-neutral
pov-up
pov-down
pov-neutral
pov-left
pov-up-left
pov-down-left
pov-neutral
pov-right
pov-up-right
pov-down-right
pov-neutral
pov-neutral
pov-neutral
pov-neutral
pov-neutral
} nth ;
: fill-controller-state ( XINPUT_STATE -- controller-state )
Gamepad>> controller-state new dup rot
{
[ wButtons>> HEX: f bitand >pov swap (>>pov) ]
[ wButtons>> fill-buttons swap (>>buttons) ]
[ sThumbLX>> >axis swap (>>x) ]
[ sThumbLY>> >axis swap (>>y) ]
[ sThumbRX>> >axis swap (>>rx) ]
[ sThumbRY>> >axis swap (>>ry) ]
[ bLeftTrigger>> >trigger swap (>>z) ]
[ bRightTrigger>> >trigger swap (>>rz) ]
} 2cleave ;
PRIVATE>
M: xinput-game-input-backend (open-game-input)
TRUE XInputEnable
create-dinput
create-device-change-window
find-keyboard
find-mouse
add-wm-devicechange ;
M: xinput-game-input-backend (close-game-input)
remove-wm-devicechange
release-mouse
release-keyboard
close-device-change-window
delete-dinput
FALSE XInputEnable ;
M: xinput-game-input-backend (reset-game-input)
global [
{
+dinput+ +keyboard-device+ +keyboard-state+
+controller-devices+ +controller-guids+
+device-change-window+ +device-change-handle+
} [ off ] each
] bind ;
M: xinput-game-input-backend get-controllers
{ 0 1 2 3 } ;
M: xinput-game-input-backend product-string
dup number?
[ drop "Controller (Xbox 360 Wireless Receiver for Windows)" ]
[ handle>> device-info tszProductName>> utf16n alien>string ]
if ;
M: xinput-game-input-backend product-id
dup number?
[ drop GUID: {02a1045e-0000-0000-0000-504944564944} ]
[ handle>> device-info guidProduct>> ]
if ;
M: xinput-game-input-backend instance-id
dup number?
[ drop GUID: {c6075b30-fbca-11de-8001-444553540000} ]
[ handle>> device-guid ]
if ;
M: xinput-game-input-backend read-controller
XINPUT_STATE <struct> [ XInputGetState ] keep
swap drop fill-controller-state ;
M: xinput-game-input-backend calibrate-controller drop ;
M: xinput-game-input-backend vibrate-controller
[ >vibration ] bi@ XINPUT_VIBRATION <struct-boa> XInputSetState drop ;
M: xinput-game-input-backend read-keyboard
+keyboard-device+ get
[ +keyboard-state+ get [ keys>> underlying>> get-device-state ] keep ]
[ ] [ f ] with-acquisition ;
M: xinput-game-input-backend read-mouse
+mouse-device+ get [ +mouse-buffer+ get MOUSE-BUFFER-SIZE read-device-buffer ]
[ fill-mouse-state ] [ f ] with-acquisition ;
M: xinput-game-input-backend reset-mouse
+mouse-device+ get [ f MOUSE-BUFFER-SIZE read-device-buffer ]
[ 2drop ] [ ] with-acquisition
+mouse-state+ get
0 >>dx
0 >>dy
0 >>scroll-dx
0 >>scroll-dy
drop ;

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

@ -0,0 +1 @@
Erik Charlebois

290
basis/images/tga/tga.factor Normal file
View File

@ -0,0 +1,290 @@
! Copyright (C) 2010 Erik Charlebois
! See http://factorcode.org/license.txt for BSD license.
USING: accessors images images.loader io io.binary kernel
locals math sequences io.encodings.ascii io.encodings.string
calendar math.ranges math.parser colors arrays hashtables
ui.pixel-formats combinators continuations ;
IN: images.tga
SINGLETON: tga-image
"tga" tga-image register-image-class
ERROR: bad-tga-header ;
ERROR: bad-tga-footer ;
ERROR: bad-tga-extension-size ;
ERROR: bad-tga-timestamp ;
ERROR: bad-tga-unsupported ;
: read-id-length ( -- byte )
1 read le> ; inline
: read-color-map-type ( -- byte )
1 read le> dup
{ 0 1 } member? [ bad-tga-header ] unless ;
: read-image-type ( -- byte )
1 read le> dup
{ 0 1 2 3 9 10 11 } member? [ bad-tga-header ] unless ; inline
: read-color-map-first ( -- short )
2 read le> ; inline
: read-color-map-length ( -- short )
2 read le> ; inline
: read-color-map-entry-size ( -- byte )
1 read le> ; inline
: read-x-origin ( -- short )
2 read le> ; inline
: read-y-origin ( -- short )
2 read le> ; inline
: read-image-width ( -- short )
2 read le> ; inline
: read-image-height ( -- short )
2 read le> ; inline
: read-pixel-depth ( -- byte )
1 read le> ; inline
: read-image-descriptor ( -- alpha-bits pixel-order )
1 read le>
[ 7 bitand ] [ 24 bitand -3 shift ] bi ; inline
: read-image-id ( length -- image-id )
read ; inline
: read-color-map ( type length elt-size -- color-map )
pick 1 = [ 8 align 8 / * read ] [ 2drop f ] if swap drop ; inline
: read-image-data ( width height depth -- image-data )
8 align 8 / * * read ; inline
: read-extension-area-offset ( -- offset )
4 read le> ; inline
: read-developer-directory-offset ( -- offset )
4 read le> ; inline
: read-signature ( -- )
18 read ascii decode "TRUEVISION-XFILE.\0" = [ bad-tga-footer ] unless ; inline
: read-extension-size ( -- )
2 read le> 495 = [ bad-tga-extension-size ] unless ; inline
: read-author-name ( -- string )
41 read ascii decode [ 0 = ] trim ; inline
: read-author-comments ( -- string )
4 iota [ drop 81 read ascii decode [ 0 = ] trim ] map concat ; inline
: read-date-timestamp ( -- timestamp )
timestamp new
2 read le> dup 12 [1,b] member? [ bad-tga-timestamp ] unless >>month
2 read le> dup 31 [1,b] member? [ bad-tga-timestamp ] unless >>day
2 read le> >>year
2 read le> dup 23 [0,b] member? [ bad-tga-timestamp ] unless >>hour
2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
: read-job-name ( -- string )
41 read ascii decode [ 0 = ] trim ; inline
: read-job-time ( -- duration )
duration new
2 read le> >>hour
2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>minute
2 read le> dup 59 [0,b] member? [ bad-tga-timestamp ] unless >>second ; inline
: read-software-id ( -- string )
41 read ascii decode [ 0 = ] trim ; inline
: read-software-version ( -- string )
2 read le> 100 /f number>string
1 read ascii decode append [ " " = ] trim ; inline
:: read-key-color ( -- color )
1 read le> 255 /f :> alpha
1 read le> 255 /f
1 read le> 255 /f
1 read le> 255 /f
alpha <rgba> ; inline
: read-pixel-aspect-ratio ( -- aspect-ratio )
2 read le> 2 read le> /f ; inline
: read-gamma-value ( -- gamma-value )
2 read le> 2 read le> /f ; inline
: read-color-correction-offset ( -- offset )
4 read le> ; inline
: read-postage-stamp-offset ( -- offset )
4 read le> ; inline
: read-scan-line-offset ( -- offset )
4 read le> ; inline
: read-premultiplied-alpha ( -- boolean )
1 read le> 4 = ; inline
: read-scan-line-table ( height -- scan-offsets )
iota [ drop 4 read le> ] map ; inline
: read-postage-stamp-image ( depth -- postage-data )
8 align 8 / 1 read le> 1 read le> * * read ; inline
:: read-color-correction-table ( -- correction-table )
256 iota
[
drop
4 iota
[
drop
2 read le> 65535 /f :> alpha
2 read le> 65535 /f
2 read le> 65535 /f
2 read le> 65535 /f
alpha <rgba>
] map
] map ; inline
: read-developer-directory ( -- developer-directory )
2 read le> iota
[
drop
2 read le>
4 read le>
4 read le>
3array
] map ; inline
: read-developer-areas ( developer-directory -- developer-area-map )
[
[ first ]
[ dup third second seek-absolute seek-input read ] bi 2array
] map >hashtable ; inline
:: read-tga ( -- image )
#! Read header
read-id-length :> id-length
read-color-map-type :> map-type
read-image-type :> image-type
read-color-map-first :> map-first
read-color-map-length :> map-length
read-color-map-entry-size :> map-entry-size
read-x-origin :> x-origin
read-y-origin :> y-origin
read-image-width :> image-width
read-image-height :> image-height
read-pixel-depth :> pixel-depth
read-image-descriptor :> ( alpha-bits pixel-order )
id-length read-image-id :> image-id
map-type map-length map-entry-size read-color-map :> color-map-data
image-width image-height pixel-depth read-image-data :> image-data
[
#! Read optional footer
26 seek-end seek-input
read-extension-area-offset :> extension-offset
read-developer-directory-offset :> directory-offset
read-signature
#! Read optional extension section
extension-offset 0 =
[
extension-offset seek-absolute seek-input
read-extension-size
read-author-name :> author-name
read-author-comments :> author-comments
read-date-timestamp :> date-timestamp
read-job-name :> job-name
read-job-time :> job-time
read-software-id :> software-id
read-software-version :> software-version
read-key-color :> key-color
read-pixel-aspect-ratio :> aspect-ratio
read-gamma-value :> gamma-value
read-color-correction-offset :> color-correction-offset
read-postage-stamp-offset :> postage-stamp-offset
read-scan-line-offset :> scan-line-offset
read-premultiplied-alpha :> premultiplied-alpha
color-correction-offset 0 =
[
color-correction-offset seek-absolute seek-input
read-color-correction-table :> color-correction-table
] unless
postage-stamp-offset 0 =
[
postage-stamp-offset seek-absolute seek-input
pixel-depth read-postage-stamp-image :> postage-data
] unless
scan-line-offset seek-absolute seek-input
image-height read-scan-line-table :> scan-offsets
#! Read optional developer section
directory-offset 0 =
[ f ]
[
directory-offset seek-absolute seek-input
read-developer-directory read-developer-areas
] if :> developer-areas
] unless
] ignore-errors
#! Only 24-bit uncompressed RGB and 32-bit uncompressed ARGB are supported.
#! Other formats would need to be converted to work within the image class.
map-type 0 = [ bad-tga-unsupported ] unless
image-type 2 = [ bad-tga-unsupported ] unless
pixel-depth { 24 32 } member? [ bad-tga-unsupported ] unless
pixel-order { 0 2 } member? [ bad-tga-unsupported ] unless
#! Create image instance
image new
alpha-bits 0 = [ RGB ] [ ARGB ] if >>component-order
{ image-width image-height } >>dim
pixel-order 0 = >>upside-down?
image-data >>bitmap
ubyte-components >>component-type ;
M: tga-image stream>image
drop [ read-tga ] with-input-stream ;
M: tga-image image>stream
drop
[
component-order>> { RGB ARGB } member? [ bad-tga-unsupported ] unless
] keep
B{ 0 } write #! id-length
B{ 0 } write #! map-type
B{ 2 } write #! image-type
B{ 0 0 0 0 0 } write #! color map first, length, entry size
B{ 0 0 0 0 } write #! x-origin, y-origin
{
[ dim>> first 2 >le write ]
[ dim>> second 2 >le write ]
[ component-order>>
{
{ RGB [ B{ 24 } write ] }
{ ARGB [ B{ 32 } write ] }
} case
]
[
dup component-order>>
{
{ RGB [ 0 ] }
{ ARGB [ 8 ] }
} case swap
upside-down?>> [ 0 ] [ 2 ] if 3 shift bitor
1 >le write
]
[ bitmap>> write ]
} cleave ;

194
basis/windows/user32/user32.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: alien alien.c-types alien.syntax parser namespaces USING: alien alien.c-types alien.syntax parser namespaces
kernel math windows.types generalizations math.bitwise kernel math windows.types generalizations math.bitwise
classes.struct literals windows.kernel32 ; classes.struct literals windows.kernel32 system accessors ;
IN: windows.user32 IN: windows.user32
! HKL for ActivateKeyboardLayout ! HKL for ActivateKeyboardLayout
@ -608,6 +608,181 @@ CONSTANT: MF_HELP HEX: 4000
CONSTANT: MF_RIGHTJUSTIFY HEX: 4000 CONSTANT: MF_RIGHTJUSTIFY HEX: 4000
CONSTANT: MF_MOUSESELECT HEX: 8000 CONSTANT: MF_MOUSESELECT HEX: 8000
TYPEDEF: HANDLE HRAWINPUT
: GET_RAWINPUT_CODE_WPARAM ( wParam -- n ) HEX: ff bitand ; inline
CONSTANT: RIM_INPUT 0
CONSTANT: RIM_INPUTSINK 1
CONSTANT: RIM_TYPEMOUSE 0
CONSTANT: RIM_TYPEKEYBOARD 1
CONSTANT: RIM_TYPEHID 2
STRUCT: RAWINPUTHEADER
{ dwType DWORD }
{ dwSize DWORD }
{ hDevice HANDLE }
{ wParam WPARAM } ;
TYPEDEF: RAWINPUTHEADER* PRAWINPUTHEADER
TYPEDEF: RAWINPUTHEADER* LPRAWINPUTHEADER
STRUCT: RAWMOUSE_BUTTONS_USBUTTONS
{ usButtonFlags USHORT }
{ usButtonData USHORT } ;
UNION-STRUCT: RAWMOUSE_BUTTONS
{ ulButtons ULONG }
{ usButtons RAWMOUSE_BUTTONS_USBUTTONS } ;
STRUCT: RAWMOUSE
{ usFlags USHORT }
{ uButtons RAWMOUSE_BUTTONS }
{ ulRawButtons ULONG }
{ lLastX LONG }
{ lLastY LONG }
{ ulExtraInformation ULONG } ;
TYPEDEF: RAWMOUSE* PRAWMOUSE
TYPEDEF: RAWMOUSE* LPRAWMOUSE
CONSTANT: RI_MOUSE_LEFT_BUTTON_DOWN HEX: 0001
CONSTANT: RI_MOUSE_LEFT_BUTTON_UP HEX: 0002
CONSTANT: RI_MOUSE_RIGHT_BUTTON_DOWN HEX: 0004
CONSTANT: RI_MOUSE_RIGHT_BUTTON_UP HEX: 0008
CONSTANT: RI_MOUSE_MIDDLE_BUTTON_DOWN HEX: 0010
CONSTANT: RI_MOUSE_MIDDLE_BUTTON_UP HEX: 0020
: RI_MOUSE_BUTTON_1_DOWN ( -- n ) RI_MOUSE_LEFT_BUTTON_DOWN ; inline
: RI_MOUSE_BUTTON_1_UP ( -- n ) RI_MOUSE_LEFT_BUTTON_UP ; inline
: RI_MOUSE_BUTTON_2_DOWN ( -- n ) RI_MOUSE_RIGHT_BUTTON_DOWN ; inline
: RI_MOUSE_BUTTON_2_UP ( -- n ) RI_MOUSE_RIGHT_BUTTON_UP ; inline
: RI_MOUSE_BUTTON_3_DOWN ( -- n ) RI_MOUSE_MIDDLE_BUTTON_DOWN ; inline
: RI_MOUSE_BUTTON_3_UP ( -- n ) RI_MOUSE_MIDDLE_BUTTON_UP ; inline
CONSTANT: RI_MOUSE_BUTTON_4_DOWN HEX: 0040
CONSTANT: RI_MOUSE_BUTTON_4_UP HEX: 0080
CONSTANT: RI_MOUSE_BUTTON_5_DOWN HEX: 0100
CONSTANT: RI_MOUSE_BUTTON_5_UP HEX: 0200
CONSTANT: RI_MOUSE_WHEEL HEX: 0400
CONSTANT: MOUSE_MOVE_RELATIVE 0
CONSTANT: MOUSE_MOVE_ABSOLUTE 1
CONSTANT: MOUSE_VIRTUAL_DESKTOP HEX: 02
CONSTANT: MOUSE_ATTRIBUTES_CHANGED HEX: 04
CONSTANT: MOUSE_MOVE_NOCOALESCE HEX: 08
STRUCT: RAWKEYBOARD
{ MakeCode USHORT }
{ Flags USHORT }
{ Reserved USHORT }
{ VKey USHORT }
{ Message UINT }
{ ExtraInformation ULONG } ;
TYPEDEF: RAWKEYBOARD* PRAWKEYBOARD
TYPEDEF: RAWKEYBOARD* LPRAWKEYBOARD
CONSTANT: KEYBOARD_OVERRUN_MAKE_CODE HEX: FF
CONSTANT: RI_KEY_MAKE 0
CONSTANT: RI_KEY_BREAK 1
CONSTANT: RI_KEY_E0 2
CONSTANT: RI_KEY_E1 4
CONSTANT: RI_KEY_TERMSRV_SET_LED 8
CONSTANT: RI_KEY_TERMSRV_SHADOW HEX: 10
STRUCT: RAWHID
{ dwSizeHid DWORD }
{ dwCount DWORD }
{ bRawData BYTE[1] } ;
TYPEDEF: RAWHID* PRAWHID
TYPEDEF: RAWHID* LPRAWHID
UNION-STRUCT: RAWINPUT_UNION
{ mouse RAWMOUSE }
{ keyboard RAWKEYBOARD }
{ hid RAWHID } ;
STRUCT: RAWINPUT
{ header RAWINPUTHEADER }
{ data RAWINPUT_UNION } ;
TYPEDEF: RAWINPUT* PRAWINPUT
TYPEDEF: RAWINPUT* LPRAWINPUT
: RAWINPUT_ALIGN ( x -- y )
cpu x86.32 = [ 4 ] [ 8 ] if align ; inline
: NEXTRAWINPUTBLOCK ( struct -- next-struct )
dup header>> dwSize>> swap <displaced-alien> RAWINPUT_ALIGN RAWINPUT memory>struct ; inline
CONSTANT: RID_INPUT HEX: 10000003
CONSTANT: RID_HEADER HEX: 10000005
CONSTANT: RIDI_PREPARSEDDATA HEX: 20000005
CONSTANT: RIDI_DEVICENAME HEX: 20000007
CONSTANT: RIDI_DEVICEINFO HEX: 2000000b
STRUCT: RID_DEVICE_INFO_MOUSE
{ dwId DWORD }
{ dwNumberOfButtons DWORD }
{ dwSampleRate DWORD }
{ fHasHorizontalWheel BOOL } ;
TYPEDEF: RID_DEVICE_INFO_MOUSE* PRID_DEVICE_INFO_MOUSE
STRUCT: RID_DEVICE_INFO_KEYBOARD
{ dwType DWORD }
{ dwSubType DWORD }
{ dwKeyboardMode DWORD }
{ dwNumberOfFunctionKeys DWORD }
{ dwNumberOfIndicators DWORD }
{ dwNumberOfKeysTotal DWORD } ;
TYPEDEF: RID_DEVICE_INFO_KEYBOARD* PRID_DEVICE_INFO_KEYBOARD
STRUCT: RID_DEVICE_INFO_HID
{ dwVendorId DWORD }
{ dwProductId DWORD }
{ dwVersionNumber DWORD }
{ usUsagePage USHORT }
{ usUsage USHORT } ;
TYPEDEF: RID_DEVICE_INFO_HID* PRID_DEVICE_INFO_HID
UNION-STRUCT: RID_DEVICE_INFO_UNION
{ mouse RID_DEVICE_INFO_MOUSE }
{ keyboard RID_DEVICE_INFO_KEYBOARD }
{ hid RID_DEVICE_INFO_HID } ;
STRUCT: RID_DEVICE_INFO
{ cbSize DWORD }
{ dwType DWORD }
{ data RID_DEVICE_INFO_UNION } ;
TYPEDEF: RID_DEVICE_INFO* PRID_DEVICE_INFO
TYPEDEF: RID_DEVICE_INFO* LPRID_DEVICE_INFO
STRUCT: RAWINPUTDEVICE
{ usUsagePage USHORT }
{ usUsage USHORT }
{ dwFlags DWORD }
{ hwndTarget HWND } ;
TYPEDEF: RAWINPUTDEVICE* PRAWINPUTDEVICE
TYPEDEF: RAWINPUTDEVICE* LPRAWINPUTDEVICE
TYPEDEF: RAWINPUTDEVICE* PCRAWINPUTDEVICE
CONSTANT: RIDEV_REMOVE HEX: 00000001
CONSTANT: RIDEV_EXCLUDE HEX: 00000010
CONSTANT: RIDEV_PAGEONLY HEX: 00000020
CONSTANT: RIDEV_NOLEGACY HEX: 00000030
CONSTANT: RIDEV_INPUTSINK HEX: 00000100
CONSTANT: RIDEV_CAPTUREMOUSE HEX: 00000200
CONSTANT: RIDEV_NOHOTKEYS HEX: 00000200
CONSTANT: RIDEV_APPKEYS HEX: 00000400
CONSTANT: RIDEV_EXINPUTSINK HEX: 00001000
CONSTANT: RIDEV_DEVNOTIFY HEX: 00002000
CONSTANT: RIDEV_EXMODEMASK HEX: 000000F0
: RIDEV_EXMODE ( mode -- x ) RIDEV_EXMODEMASK bitand ; inline
CONSTANT: GIDC_ARRIVAL 1
CONSTANT: GIDC_REMOVAL 2
: GET_DEVICE_CHANGE_WPARAM ( wParam -- x ) HEX: ffff bitand ; inline
STRUCT: RAWINPUTDEVICELIST
{ hDevice HANDLE }
{ dwType DWORD } ;
TYPEDEF: RAWINPUTDEVICELIST* PRAWINPUTDEVICELIST
LIBRARY: user32 LIBRARY: user32
FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ; FUNCTION: HKL ActivateKeyboardLayout ( HKL hkl, UINT Flags ) ;
@ -775,7 +950,7 @@ ALIAS: CreateWindowEx CreateWindowExW
! FUNCTION: DefFrameProcW ! FUNCTION: DefFrameProcW
! FUNCTION: DefMDIChildProcA ! FUNCTION: DefMDIChildProcA
! FUNCTION: DefMDIChildProcW ! FUNCTION: DefMDIChildProcW
! FUNCTION: DefRawInputProc FUNCTION: LRESULT DefRawInputProc ( PRAWINPUT* paRawInput, INT nInput, UINT cbSizeHeader ) ;
FUNCTION: LRESULT DefWindowProcW ( HWND hWnd, UINT Msg, WPARAM wParam, LPARAM lParam ) ; FUNCTION: LRESULT DefWindowProcW ( HWND hWnd, UINT Msg, WPARAM wParam, LPARAM lParam ) ;
ALIAS: DefWindowProc DefWindowProcW ALIAS: DefWindowProc DefWindowProcW
! FUNCTION: DeleteMenu ! FUNCTION: DeleteMenu
@ -985,13 +1160,14 @@ FUNCTION: int GetPriorityClipboardFormat ( UINT* paFormatPriorityList, int cForm
! FUNCTION: GetPropA ! FUNCTION: GetPropA
! FUNCTION: GetPropW ! FUNCTION: GetPropW
! FUNCTION: GetQueueStatus ! FUNCTION: GetQueueStatus
! FUNCTION: GetRawInputBuffer FUNCTION: UINT GetRawInputBuffer ( PRAWINPUT pData, PUINT pcbSize, UINT cbSizeHeader ) ;
! FUNCTION: GetRawInputData FUNCTION: UINT GetRawInputData ( HRAWINPUT hRawInput, UINT uiCommand, LPVOID pData, PUINT pcbSize, UINT cbSizeHeader ) ;
! FUNCTION: GetRawInputDeviceInfoA FUNCTION: UINT GetRawInputDeviceInfoA ( HANDLE hDevice, UINT uiCommand, LPVOID pData, PUINT pcbSize ) ;
! FUNCTION: GetRawInputDeviceInfoW FUNCTION: UINT GetRawInputDeviceInfoW ( HANDLE hDevice, UINT uiCommand, LPVOID pData, PUINT pcbSize ) ;
! FUNCTION: GetRawInputDeviceList ALIAS: GetRawInputDeviceInfo GetRawInputDeviceInfoW
FUNCTION: UINT GetRawInputDeviceList ( PRAWINPUTDEVICELIST pRawInputDeviceList, PUINT puiNumDevices, UINT cbSize ) ;
FUNCTION: UINT GetRegisteredRawInputDevices ( PRAWINPUTDEVICE pRawInputDevices, PUINT puiNumDevices, UINT cbSize ) ;
! FUNCTION: GetReasonTitleFromReasonCode ! FUNCTION: GetReasonTitleFromReasonCode
! FUNCTION: GetRegisteredRawInputDevices
! FUNCTION: GetScrollBarInfo ! FUNCTION: GetScrollBarInfo
! FUNCTION: GetScrollInfo ! FUNCTION: GetScrollInfo
! FUNCTION: GetScrollPos ! FUNCTION: GetScrollPos
@ -1266,7 +1442,7 @@ ALIAS: RegisterDeviceNotification RegisterDeviceNotificationW
! FUNCTION: RegisterHotKey ! FUNCTION: RegisterHotKey
! FUNCTION: RegisterLogonProcess ! FUNCTION: RegisterLogonProcess
! FUNCTION: RegisterMessagePumpHook ! FUNCTION: RegisterMessagePumpHook
! FUNCTION: RegisterRawInputDevices FUNCTION: BOOL RegisterRawInputDevices ( PCRAWINPUTDEVICE pRawInputDevices, UINT uiNumDevices, UINT cbSize ) ;
! FUNCTION: RegisterServicesProcess ! FUNCTION: RegisterServicesProcess
! FUNCTION: RegisterShellHookWindow ! FUNCTION: RegisterShellHookWindow
! FUNCTION: RegisterSystemThread ! FUNCTION: RegisterSystemThread

690
core/classes/algebra/algebra-tests.factor
View File

@ -1,345 +1,345 @@
USING: alien arrays definitions generic assocs hashtables io USING: alien arrays definitions generic assocs hashtables io
kernel math namespaces parser prettyprint sequences strings kernel math namespaces parser prettyprint sequences strings
tools.test words quotations classes classes.algebra tools.test words quotations classes classes.algebra
classes.private classes.union classes.mixin classes.predicate classes.private classes.union classes.mixin classes.predicate
vectors source-files compiler.units growable random vectors source-files compiler.units growable random
stack-checker effects kernel.private sbufs math.order stack-checker effects kernel.private sbufs math.order
classes.tuple accessors generic.private ; classes.tuple accessors generic.private ;
IN: classes.algebra.tests IN: classes.algebra.tests
TUPLE: first-one ; TUPLE: first-one ;
TUPLE: second-one ; TUPLE: second-one ;
UNION: both first-one union-class ; UNION: both first-one union-class ;
PREDICATE: no-docs < word "documentation" word-prop not ; PREDICATE: no-docs < word "documentation" word-prop not ;
UNION: no-docs-union no-docs integer ; UNION: no-docs-union no-docs integer ;
TUPLE: a ; TUPLE: a ;
TUPLE: b ; TUPLE: b ;
UNION: c a b ; UNION: c a b ;
TUPLE: tuple-example ; TUPLE: tuple-example ;
TUPLE: a1 ; TUPLE: a1 ;
TUPLE: b1 ; TUPLE: b1 ;
TUPLE: c1 ; TUPLE: c1 ;
UNION: x1 a1 b1 ; UNION: x1 a1 b1 ;
UNION: y1 a1 c1 ; UNION: y1 a1 c1 ;
UNION: z1 b1 c1 ; UNION: z1 b1 c1 ;
SINGLETON: sa SINGLETON: sa
SINGLETON: sb SINGLETON: sb
SINGLETON: sc SINGLETON: sc
INTERSECTION: empty-intersection ; INTERSECTION: empty-intersection ;
INTERSECTION: generic-class generic class ; INTERSECTION: generic-class generic class ;
UNION: union-with-one-member a ; UNION: union-with-one-member a ;
MIXIN: mixin-with-one-member MIXIN: mixin-with-one-member
INSTANCE: union-with-one-member mixin-with-one-member INSTANCE: union-with-one-member mixin-with-one-member
! class<= ! class<=
[ t ] [ \ fixnum \ integer class<= ] unit-test [ t ] [ \ fixnum \ integer class<= ] unit-test
[ t ] [ \ fixnum \ fixnum class<= ] unit-test [ t ] [ \ fixnum \ fixnum class<= ] unit-test
[ f ] [ \ integer \ fixnum class<= ] unit-test [ f ] [ \ integer \ fixnum class<= ] unit-test
[ t ] [ \ integer \ object class<= ] unit-test [ t ] [ \ integer \ object class<= ] unit-test
[ f ] [ \ integer \ null class<= ] unit-test [ f ] [ \ integer \ null class<= ] unit-test
[ t ] [ \ null \ object class<= ] unit-test [ t ] [ \ null \ object class<= ] unit-test
[ t ] [ \ generic \ word class<= ] unit-test [ t ] [ \ generic \ word class<= ] unit-test
[ f ] [ \ word \ generic class<= ] unit-test [ f ] [ \ word \ generic class<= ] unit-test
[ f ] [ \ reversed \ slice class<= ] unit-test [ f ] [ \ reversed \ slice class<= ] unit-test
[ f ] [ \ slice \ reversed class<= ] unit-test [ f ] [ \ slice \ reversed class<= ] unit-test
[ t ] [ no-docs no-docs-union class<= ] unit-test [ t ] [ no-docs no-docs-union class<= ] unit-test
[ f ] [ no-docs-union no-docs class<= ] unit-test [ f ] [ no-docs-union no-docs class<= ] unit-test
[ t ] [ \ c \ tuple class<= ] unit-test [ t ] [ \ c \ tuple class<= ] unit-test
[ f ] [ \ tuple \ c class<= ] unit-test [ f ] [ \ tuple \ c class<= ] unit-test
[ t ] [ \ tuple-class \ class class<= ] unit-test [ t ] [ \ tuple-class \ class class<= ] unit-test
[ f ] [ \ class \ tuple-class class<= ] unit-test [ f ] [ \ class \ tuple-class class<= ] unit-test
[ t ] [ \ null \ tuple-example class<= ] unit-test [ t ] [ \ null \ tuple-example class<= ] unit-test
[ f ] [ \ object \ tuple-example class<= ] unit-test [ f ] [ \ object \ tuple-example class<= ] unit-test
[ f ] [ \ object \ tuple-example class<= ] unit-test [ f ] [ \ object \ tuple-example class<= ] unit-test
[ t ] [ \ tuple-example \ tuple class<= ] unit-test [ t ] [ \ tuple-example \ tuple class<= ] unit-test
[ f ] [ \ tuple \ tuple-example class<= ] unit-test [ f ] [ \ tuple \ tuple-example class<= ] unit-test
[ f ] [ z1 x1 y1 class-and class<= ] unit-test [ f ] [ z1 x1 y1 class-and class<= ] unit-test
[ t ] [ x1 y1 class-and a1 class<= ] unit-test [ t ] [ x1 y1 class-and a1 class<= ] unit-test
[ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test [ f ] [ b1 c1 class-or a1 b1 class-or a1 c1 class-and class-and class<= ] unit-test
[ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test [ t ] [ a1 b1 class-or a1 c1 class-or class-and a1 class<= ] unit-test
[ f ] [ growable tuple sequence class-and class<= ] unit-test [ f ] [ growable tuple sequence class-and class<= ] unit-test
[ f ] [ growable assoc class-and tuple class<= ] unit-test [ f ] [ growable assoc class-and tuple class<= ] unit-test
[ t ] [ object \ f \ f class-not class-or class<= ] unit-test [ t ] [ object \ f \ f class-not class-or class<= ] unit-test
[ t ] [ fixnum class-not integer class-and bignum class= ] unit-test [ t ] [ fixnum class-not integer class-and bignum class= ] unit-test
[ t ] [ array number class-not class<= ] unit-test [ t ] [ array number class-not class<= ] unit-test
[ f ] [ bignum number class-not class<= ] unit-test [ f ] [ bignum number class-not class<= ] unit-test
[ t ] [ fixnum fixnum bignum class-or class<= ] unit-test [ t ] [ fixnum fixnum bignum class-or class<= ] unit-test
[ f ] [ fixnum class-not integer class-and array class<= ] unit-test [ f ] [ fixnum class-not integer class-and array class<= ] unit-test
[ f ] [ fixnum class-not integer class<= ] unit-test [ f ] [ fixnum class-not integer class<= ] unit-test
[ f ] [ number class-not array class<= ] unit-test [ f ] [ number class-not array class<= ] unit-test
[ f ] [ fixnum class-not array class<= ] unit-test [ f ] [ fixnum class-not array class<= ] unit-test
[ t ] [ number class-not integer class-not class<= ] unit-test [ t ] [ number class-not integer class-not class<= ] unit-test
[ f ] [ fixnum class-not integer class<= ] unit-test [ f ] [ fixnum class-not integer class<= ] unit-test
[ t ] [ object empty-intersection class<= ] unit-test [ t ] [ object empty-intersection class<= ] unit-test
[ t ] [ empty-intersection object class<= ] unit-test [ t ] [ empty-intersection object class<= ] unit-test
[ t ] [ \ f class-not empty-intersection class<= ] unit-test [ t ] [ \ f class-not empty-intersection class<= ] unit-test
[ f ] [ empty-intersection \ f class-not class<= ] unit-test [ f ] [ empty-intersection \ f class-not class<= ] unit-test
[ t ] [ \ number empty-intersection class<= ] unit-test [ t ] [ \ number empty-intersection class<= ] unit-test
[ t ] [ empty-intersection class-not null class<= ] unit-test [ t ] [ empty-intersection class-not null class<= ] unit-test
[ t ] [ null empty-intersection class-not class<= ] unit-test [ t ] [ null empty-intersection class-not class<= ] unit-test
[ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test [ t ] [ \ f class-not \ f class-or empty-intersection class<= ] unit-test
[ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test [ t ] [ empty-intersection \ f class-not \ f class-or class<= ] unit-test
[ t ] [ object \ f class-not \ f class-or class<= ] unit-test [ t ] [ object \ f class-not \ f class-or class<= ] unit-test
[ t ] [ [ t ] [
fixnum class-not fixnum class-not
fixnum fixnum class-not class-or fixnum fixnum class-not class-or
class<= class<=
] unit-test ] unit-test
[ t ] [ generic-class generic class<= ] unit-test [ t ] [ generic-class generic class<= ] unit-test
[ t ] [ generic-class \ class class<= ] unit-test [ t ] [ generic-class \ class class<= ] unit-test
[ t ] [ a union-with-one-member class<= ] unit-test [ t ] [ a union-with-one-member class<= ] unit-test
[ f ] [ union-with-one-member class-not integer class<= ] unit-test [ f ] [ union-with-one-member class-not integer class<= ] unit-test
MIXIN: empty-mixin MIXIN: empty-mixin
[ f ] [ empty-mixin class-not null class<= ] unit-test [ f ] [ empty-mixin class-not null class<= ] unit-test
[ f ] [ empty-mixin null class<= ] unit-test [ f ] [ empty-mixin null class<= ] unit-test
[ t ] [ array sequence vector class-not class-and class<= ] unit-test [ t ] [ array sequence vector class-not class-and class<= ] unit-test
[ f ] [ vector sequence vector class-not class-and class<= ] unit-test [ f ] [ vector sequence vector class-not class-and class<= ] unit-test
! class-and ! class-and
: class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ; : class-and* ( cls1 cls2 cls3 -- ? ) [ class-and ] dip class= ;
[ t ] [ object object object class-and* ] unit-test [ t ] [ object object object class-and* ] unit-test
[ t ] [ fixnum object fixnum class-and* ] unit-test [ t ] [ fixnum object fixnum class-and* ] unit-test
[ t ] [ object fixnum fixnum class-and* ] unit-test [ t ] [ object fixnum fixnum class-and* ] unit-test
[ t ] [ fixnum fixnum fixnum class-and* ] unit-test [ t ] [ fixnum fixnum fixnum class-and* ] unit-test
[ t ] [ fixnum integer fixnum class-and* ] unit-test [ t ] [ fixnum integer fixnum class-and* ] unit-test
[ t ] [ integer fixnum fixnum class-and* ] unit-test [ t ] [ integer fixnum fixnum class-and* ] unit-test
[ t ] [ vector fixnum null class-and* ] unit-test [ t ] [ vector fixnum null class-and* ] unit-test
[ t ] [ number object number class-and* ] unit-test [ t ] [ number object number class-and* ] unit-test
[ t ] [ object number number class-and* ] unit-test [ t ] [ object number number class-and* ] unit-test
[ t ] [ slice reversed null class-and* ] unit-test [ t ] [ slice reversed null class-and* ] unit-test
[ t ] [ \ f class-not \ f null class-and* ] unit-test [ t ] [ \ f class-not \ f null class-and* ] unit-test
[ t ] [ vector array class-not vector class-and* ] unit-test [ t ] [ vector array class-not vector class-and* ] unit-test
! class-or ! class-or
: class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ; : class-or* ( cls1 cls2 cls3 -- ? ) [ class-or ] dip class= ;
[ t ] [ \ f class-not \ f object class-or* ] unit-test [ t ] [ \ f class-not \ f object class-or* ] unit-test
! class-not ! class-not
[ vector ] [ vector class-not class-not ] unit-test [ vector ] [ vector class-not class-not ] unit-test
! classes-intersect? ! classes-intersect?
[ t ] [ both tuple classes-intersect? ] unit-test [ t ] [ both tuple classes-intersect? ] unit-test
[ f ] [ vector virtual-sequence classes-intersect? ] unit-test [ f ] [ vector virtual-sequence classes-intersect? ] unit-test
[ t ] [ number vector class-or sequence classes-intersect? ] unit-test [ t ] [ number vector class-or sequence classes-intersect? ] unit-test
[ f ] [ number vector class-and sequence classes-intersect? ] unit-test [ f ] [ number vector class-and sequence classes-intersect? ] unit-test
[ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test [ f ] [ y1 z1 class-and x1 classes-intersect? ] unit-test
[ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test [ f ] [ a1 c1 class-or b1 c1 class-or class-and a1 b1 class-or classes-intersect? ] unit-test
[ f ] [ integer integer class-not classes-intersect? ] unit-test [ f ] [ integer integer class-not classes-intersect? ] unit-test
[ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test [ f ] [ fixnum class-not number class-and array classes-intersect? ] unit-test
[ t ] [ \ word generic-class classes-intersect? ] unit-test [ t ] [ \ word generic-class classes-intersect? ] unit-test
[ f ] [ number generic-class classes-intersect? ] unit-test [ f ] [ number generic-class classes-intersect? ] unit-test
[ f ] [ sa sb classes-intersect? ] unit-test [ f ] [ sa sb classes-intersect? ] unit-test
[ t ] [ a union-with-one-member classes-intersect? ] unit-test [ t ] [ a union-with-one-member classes-intersect? ] unit-test
[ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test [ f ] [ fixnum union-with-one-member classes-intersect? ] unit-test
[ t ] [ object union-with-one-member classes-intersect? ] unit-test [ t ] [ object union-with-one-member classes-intersect? ] unit-test
[ t ] [ union-with-one-member a classes-intersect? ] unit-test [ t ] [ union-with-one-member a classes-intersect? ] unit-test
[ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test [ f ] [ union-with-one-member fixnum classes-intersect? ] unit-test
[ t ] [ union-with-one-member object classes-intersect? ] unit-test [ t ] [ union-with-one-member object classes-intersect? ] unit-test
[ t ] [ a mixin-with-one-member classes-intersect? ] unit-test [ t ] [ a mixin-with-one-member classes-intersect? ] unit-test
[ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test [ f ] [ fixnum mixin-with-one-member classes-intersect? ] unit-test
[ t ] [ object mixin-with-one-member classes-intersect? ] unit-test [ t ] [ object mixin-with-one-member classes-intersect? ] unit-test
[ t ] [ mixin-with-one-member a classes-intersect? ] unit-test [ t ] [ mixin-with-one-member a classes-intersect? ] unit-test
[ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test [ f ] [ mixin-with-one-member fixnum classes-intersect? ] unit-test
[ t ] [ mixin-with-one-member object classes-intersect? ] unit-test [ t ] [ mixin-with-one-member object classes-intersect? ] unit-test
! class= ! class=
[ t ] [ null class-not object class= ] unit-test [ t ] [ null class-not object class= ] unit-test
[ t ] [ object class-not null class= ] unit-test [ t ] [ object class-not null class= ] unit-test
[ f ] [ object class-not object class= ] unit-test [ f ] [ object class-not object class= ] unit-test
[ f ] [ null class-not null class= ] unit-test [ f ] [ null class-not null class= ] unit-test
! class<=> ! class<=>
[ +lt+ ] [ sequence object class<=> ] unit-test [ +lt+ ] [ sequence object class<=> ] unit-test
[ +gt+ ] [ object sequence class<=> ] unit-test [ +gt+ ] [ object sequence class<=> ] unit-test
[ +eq+ ] [ integer integer class<=> ] unit-test [ +eq+ ] [ integer integer class<=> ] unit-test
! smallest-class etc ! smallest-class etc
[ real ] [ { real sequence } smallest-class ] unit-test [ real ] [ { real sequence } smallest-class ] unit-test
[ real ] [ { sequence real } smallest-class ] unit-test [ real ] [ { sequence real } smallest-class ] unit-test
: min-class ( class classes -- class/f ) : min-class ( class classes -- class/f )
interesting-classes smallest-class ; interesting-classes smallest-class ;
[ f ] [ fixnum { } min-class ] unit-test [ f ] [ fixnum { } min-class ] unit-test
[ string ] [ [ string ] [
\ string \ string
[ integer string array reversed sbuf [ integer string array reversed sbuf
slice vector quotation ] slice vector quotation ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ fixnum ] [ [ fixnum ] [
\ fixnum \ fixnum
[ fixnum integer object ] [ fixnum integer object ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ integer ] [ [ integer ] [
\ fixnum \ fixnum
[ integer float object ] [ integer float object ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ object ] [ [ object ] [
\ word \ word
[ integer float object ] [ integer float object ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ reversed ] [ [ reversed ] [
\ reversed \ reversed
[ integer reversed slice ] [ integer reversed slice ]
sort-classes min-class sort-classes min-class
] unit-test ] unit-test
[ f ] [ null { number fixnum null } min-class ] unit-test [ f ] [ null { number fixnum null } min-class ] unit-test
! Test for hangs? ! Test for hangs?
: random-class ( -- class ) classes random ; : random-class ( -- class ) classes random ;
: random-op ( -- word ) : random-op ( -- word )
{ {
class-and class-and
class-or class-or
class-not class-not
} random ; } random ;
10 [ 10 [
[ ] [ [ ] [
20 [ random-op ] [ ] replicate-as 20 [ random-op ] [ ] replicate-as
[ infer in>> length [ random-class ] times ] keep [ infer in>> length [ random-class ] times ] keep
call call
drop drop
] unit-test ] unit-test
] times ] times
: random-boolean ( -- ? ) : random-boolean ( -- ? )
{ t f } random ; { t f } random ;
: boolean>class ( ? -- class ) : boolean>class ( ? -- class )
object null ? ; object null ? ;
: random-boolean-op ( -- word ) : random-boolean-op ( -- word )
{ {
and and
or or
not not
xor xor
} random ; } random ;
: class-xor ( cls1 cls2 -- cls3 ) : class-xor ( cls1 cls2 -- cls3 )
[ class-or ] 2keep class-and class-not class-and ; [ class-or ] 2keep class-and class-not class-and ;
: boolean-op>class-op ( word -- word' ) : boolean-op>class-op ( word -- word' )
{ {
{ and class-and } { and class-and }
{ or class-or } { or class-or }
{ not class-not } { not class-not }
{ xor class-xor } { xor class-xor }
} at ; } at ;
20 [ 20 [
[ t ] [ [ t ] [
20 [ random-boolean-op ] [ ] replicate-as dup . 20 [ random-boolean-op ] [ ] replicate-as dup .
[ infer in>> length [ random-boolean ] replicate dup . ] keep [ infer in>> length [ random-boolean ] replicate dup . ] keep
[ [ [ ] each ] dip call ] 2keep [ [ [ ] each ] dip call ] 2keep
[ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class= [ [ boolean>class ] each ] dip [ boolean-op>class-op ] map call object class=
= =
] unit-test ] unit-test
] times ] times
SINGLETON: xxx SINGLETON: xxx
UNION: yyy xxx ; UNION: yyy xxx ;
[ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test [ { yyy xxx } ] [ { xxx yyy } sort-classes ] unit-test
[ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test [ { yyy xxx } ] [ { yyy xxx } sort-classes ] unit-test
[ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test [ { number ratio integer } ] [ { ratio number integer } sort-classes ] unit-test
[ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test [ { sequence number ratio } ] [ { ratio number sequence } sort-classes ] unit-test
TUPLE: xa ; TUPLE: xa ;
TUPLE: xb ; TUPLE: xb ;
TUPLE: xc < xa ; TUPLE: xc < xa ;
TUPLE: xd < xb ; TUPLE: xd < xb ;
TUPLE: xe ; TUPLE: xe ;
TUPLE: xf < xb ; TUPLE: xf < xb ;
TUPLE: xg < xb ; TUPLE: xg < xb ;
TUPLE: xh < xb ; TUPLE: xh < xb ;
[ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test [ t ] [ { xa xb xc xd xe xf xg xh } sort-classes dup sort-classes = ] unit-test
[ H{ { word word } } ] [ [ H{ { word word } } ] [
generic-class flatten-class generic-class flatten-class
] unit-test ] unit-test
[ sa ] [ sa { sa sb sc } min-class ] unit-test [ sa ] [ sa { sa sb sc } min-class ] unit-test
[ \ + flatten-class ] must-fail [ \ + flatten-class ] must-fail

486
core/classes/algebra/algebra.factor
View File

@ -1,243 +1,243 @@
! Copyright (C) 2004, 2010 Slava Pestov. ! Copyright (C) 2004, 2010 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: kernel classes combinators accessors sequences arrays USING: kernel classes combinators accessors sequences arrays
vectors assocs namespaces words sorting layouts math hashtables vectors assocs namespaces words sorting layouts math hashtables
kernel.private sets math.order ; kernel.private sets math.order ;
IN: classes.algebra IN: classes.algebra
<PRIVATE <PRIVATE
TUPLE: anonymous-union { members read-only } ; TUPLE: anonymous-union { members read-only } ;
: <anonymous-union> ( members -- class ) : <anonymous-union> ( members -- class )
[ null eq? not ] filter prune [ null eq? not ] filter prune
dup length 1 = [ first ] [ anonymous-union boa ] if ; dup length 1 = [ first ] [ anonymous-union boa ] if ;
TUPLE: anonymous-intersection { participants read-only } ; TUPLE: anonymous-intersection { participants read-only } ;
: <anonymous-intersection> ( participants -- class ) : <anonymous-intersection> ( participants -- class )
prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ; prune dup length 1 = [ first ] [ anonymous-intersection boa ] if ;
TUPLE: anonymous-complement { class read-only } ; TUPLE: anonymous-complement { class read-only } ;
C: <anonymous-complement> anonymous-complement C: <anonymous-complement> anonymous-complement
DEFER: (class<=) DEFER: (class<=)
DEFER: (class-not) DEFER: (class-not)
GENERIC: (classes-intersect?) ( first second -- ? ) GENERIC: (classes-intersect?) ( first second -- ? )
DEFER: (class-and) DEFER: (class-and)
DEFER: (class-or) DEFER: (class-or)
GENERIC: (flatten-class) ( class -- ) GENERIC: (flatten-class) ( class -- )
GENERIC: normalize-class ( class -- class' ) GENERIC: normalize-class ( class -- class' )
M: object normalize-class ; M: object normalize-class ;
PRIVATE> PRIVATE>
GENERIC: classoid? ( obj -- ? ) GENERIC: classoid? ( obj -- ? )
M: word classoid? class? ; M: word classoid? class? ;
M: anonymous-union classoid? members>> [ classoid? ] all? ; M: anonymous-union classoid? members>> [ classoid? ] all? ;
M: anonymous-intersection classoid? participants>> [ classoid? ] all? ; M: anonymous-intersection classoid? participants>> [ classoid? ] all? ;
M: anonymous-complement classoid? class>> classoid? ; M: anonymous-complement classoid? class>> classoid? ;
: class<= ( first second -- ? ) : class<= ( first second -- ? )
class<=-cache get [ (class<=) ] 2cache ; class<=-cache get [ (class<=) ] 2cache ;
: class< ( first second -- ? ) : class< ( first second -- ? )
{ {
{ [ 2dup class<= not ] [ 2drop f ] } { [ 2dup class<= not ] [ 2drop f ] }
{ [ 2dup swap class<= not ] [ 2drop t ] } { [ 2dup swap class<= not ] [ 2drop t ] }
[ [ rank-class ] bi@ < ] [ [ rank-class ] bi@ < ]
} cond ; } cond ;
: class<=> ( first second -- ? ) : class<=> ( first second -- ? )
{ {
{ [ 2dup class<= not ] [ 2drop +gt+ ] } { [ 2dup class<= not ] [ 2drop +gt+ ] }
{ [ 2dup swap class<= not ] [ 2drop +lt+ ] } { [ 2dup swap class<= not ] [ 2drop +lt+ ] }
[ [ rank-class ] bi@ <=> ] [ [ rank-class ] bi@ <=> ]
} cond ; } cond ;
: class= ( first second -- ? ) : class= ( first second -- ? )
[ class<= ] [ swap class<= ] 2bi and ; [ class<= ] [ swap class<= ] 2bi and ;
: class-not ( class -- complement ) : class-not ( class -- complement )
class-not-cache get [ (class-not) ] cache ; class-not-cache get [ (class-not) ] cache ;
: classes-intersect? ( first second -- ? ) : classes-intersect? ( first second -- ? )
classes-intersect-cache get [ classes-intersect-cache get [
normalize-class (classes-intersect?) normalize-class (classes-intersect?)
] 2cache ; ] 2cache ;
: class-and ( first second -- class ) : class-and ( first second -- class )
class-and-cache get [ (class-and) ] 2cache ; class-and-cache get [ (class-and) ] 2cache ;
: class-or ( first second -- class ) : class-or ( first second -- class )
class-or-cache get [ (class-or) ] 2cache ; class-or-cache get [ (class-or) ] 2cache ;
<PRIVATE <PRIVATE
: superclass<= ( first second -- ? ) : superclass<= ( first second -- ? )
swap superclass dup [ swap class<= ] [ 2drop f ] if ; swap superclass dup [ swap class<= ] [ 2drop f ] if ;
: left-anonymous-union<= ( first second -- ? ) : left-anonymous-union<= ( first second -- ? )
[ members>> ] dip [ class<= ] curry all? ; [ members>> ] dip [ class<= ] curry all? ;
: right-union<= ( first second -- ? ) : right-union<= ( first second -- ? )
members [ class<= ] with any? ; members [ class<= ] with any? ;
: right-anonymous-union<= ( first second -- ? ) : right-anonymous-union<= ( first second -- ? )
members>> [ class<= ] with any? ; members>> [ class<= ] with any? ;
: left-anonymous-intersection<= ( first second -- ? ) : left-anonymous-intersection<= ( first second -- ? )
[ participants>> ] dip [ class<= ] curry any? ; [ participants>> ] dip [ class<= ] curry any? ;
: right-anonymous-intersection<= ( first second -- ? ) : right-anonymous-intersection<= ( first second -- ? )
participants>> [ class<= ] with all? ; participants>> [ class<= ] with all? ;
: anonymous-complement<= ( first second -- ? ) : anonymous-complement<= ( first second -- ? )
[ class>> ] bi@ swap class<= ; [ class>> ] bi@ swap class<= ;
: normalize-complement ( class -- class' ) : normalize-complement ( class -- class' )
class>> normalize-class { class>> normalize-class {
{ [ dup anonymous-union? ] [ { [ dup anonymous-union? ] [
members>> members>>
[ class-not normalize-class ] map [ class-not normalize-class ] map
<anonymous-intersection> <anonymous-intersection>
] } ] }
{ [ dup anonymous-intersection? ] [ { [ dup anonymous-intersection? ] [
participants>> participants>>
[ class-not normalize-class ] map [ class-not normalize-class ] map
<anonymous-union> <anonymous-union>
] } ] }
[ drop object ] [ drop object ]
} cond ; } cond ;
: left-anonymous-complement<= ( first second -- ? ) : left-anonymous-complement<= ( first second -- ? )
[ normalize-complement ] dip class<= ; [ normalize-complement ] dip class<= ;
PREDICATE: nontrivial-anonymous-complement < anonymous-complement PREDICATE: nontrivial-anonymous-complement < anonymous-complement
class>> { class>> {
[ anonymous-union? ] [ anonymous-union? ]
[ anonymous-intersection? ] [ anonymous-intersection? ]
[ members ] [ members ]
[ participants ] [ participants ]
} cleave or or or ; } cleave or or or ;
PREDICATE: empty-union < anonymous-union members>> empty? ; PREDICATE: empty-union < anonymous-union members>> empty? ;
PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ; PREDICATE: empty-intersection < anonymous-intersection participants>> empty? ;
: (class<=) ( first second -- ? ) : (class<=) ( first second -- ? )
2dup eq? [ 2drop t ] [ 2dup eq? [ 2drop t ] [
[ normalize-class ] bi@ [ normalize-class ] bi@
2dup superclass<= [ 2drop t ] [ 2dup superclass<= [ 2drop t ] [
{ {
{ [ 2dup eq? ] [ 2drop t ] } { [ 2dup eq? ] [ 2drop t ] }
{ [ dup empty-intersection? ] [ 2drop t ] } { [ dup empty-intersection? ] [ 2drop t ] }
{ [ over empty-union? ] [ 2drop t ] } { [ over empty-union? ] [ 2drop t ] }
{ [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] } { [ 2dup [ anonymous-complement? ] both? ] [ anonymous-complement<= ] }
{ [ over anonymous-union? ] [ left-anonymous-union<= ] } { [ over anonymous-union? ] [ left-anonymous-union<= ] }
{ [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] } { [ over anonymous-intersection? ] [ left-anonymous-intersection<= ] }
{ [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] } { [ over nontrivial-anonymous-complement? ] [ left-anonymous-complement<= ] }
{ [ dup members ] [ right-union<= ] } { [ dup members ] [ right-union<= ] }
{ [ dup anonymous-union? ] [ right-anonymous-union<= ] } { [ dup anonymous-union? ] [ right-anonymous-union<= ] }
{ [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] } { [ dup anonymous-intersection? ] [ right-anonymous-intersection<= ] }
{ [ dup anonymous-complement? ] [ class>> classes-intersect? not ] } { [ dup anonymous-complement? ] [ class>> classes-intersect? not ] }
[ 2drop f ] [ 2drop f ]
} cond } cond
] if ] if
] if ; ] if ;
M: anonymous-union (classes-intersect?) M: anonymous-union (classes-intersect?)
members>> [ classes-intersect? ] with any? ; members>> [ classes-intersect? ] with any? ;
M: anonymous-intersection (classes-intersect?) M: anonymous-intersection (classes-intersect?)
participants>> [ classes-intersect? ] with all? ; participants>> [ classes-intersect? ] with all? ;
M: anonymous-complement (classes-intersect?) M: anonymous-complement (classes-intersect?)
class>> class<= not ; class>> class<= not ;
: anonymous-union-and ( first second -- class ) : anonymous-union-and ( first second -- class )
members>> [ class-and ] with map <anonymous-union> ; members>> [ class-and ] with map <anonymous-union> ;
: anonymous-intersection-and ( first second -- class ) : anonymous-intersection-and ( first second -- class )
participants>> swap suffix <anonymous-intersection> ; participants>> swap suffix <anonymous-intersection> ;
: (class-and) ( first second -- class ) : (class-and) ( first second -- class )
{ {
{ [ 2dup class<= ] [ drop ] } { [ 2dup class<= ] [ drop ] }
{ [ 2dup swap class<= ] [ nip ] } { [ 2dup swap class<= ] [ nip ] }
{ [ 2dup classes-intersect? not ] [ 2drop null ] } { [ 2dup classes-intersect? not ] [ 2drop null ] }
[ [
[ normalize-class ] bi@ { [ normalize-class ] bi@ {
{ [ dup anonymous-union? ] [ anonymous-union-and ] } { [ dup anonymous-union? ] [ anonymous-union-and ] }
{ [ dup anonymous-intersection? ] [ anonymous-intersection-and ] } { [ dup anonymous-intersection? ] [ anonymous-intersection-and ] }
{ [ over anonymous-union? ] [ swap anonymous-union-and ] } { [ over anonymous-union? ] [ swap anonymous-union-and ] }
{ [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] } { [ over anonymous-intersection? ] [ swap anonymous-intersection-and ] }
[ 2array <anonymous-intersection> ] [ 2array <anonymous-intersection> ]
} cond } cond
] ]
} cond ; } cond ;
: anonymous-union-or ( first second -- class ) : anonymous-union-or ( first second -- class )
members>> swap suffix <anonymous-union> ; members>> swap suffix <anonymous-union> ;
: ((class-or)) ( first second -- class ) : ((class-or)) ( first second -- class )
[ normalize-class ] bi@ { [ normalize-class ] bi@ {
{ [ dup anonymous-union? ] [ anonymous-union-or ] } { [ dup anonymous-union? ] [ anonymous-union-or ] }
{ [ over anonymous-union? ] [ swap anonymous-union-or ] } { [ over anonymous-union? ] [ swap anonymous-union-or ] }
[ 2array <anonymous-union> ] [ 2array <anonymous-union> ]
} cond ; } cond ;
: anonymous-complement-or ( first second -- class ) : anonymous-complement-or ( first second -- class )
2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ; 2dup class>> swap class<= [ 2drop object ] [ ((class-or)) ] if ;
: (class-or) ( first second -- class ) : (class-or) ( first second -- class )
{ {
{ [ 2dup class<= ] [ nip ] } { [ 2dup class<= ] [ nip ] }
{ [ 2dup swap class<= ] [ drop ] } { [ 2dup swap class<= ] [ drop ] }
{ [ dup anonymous-complement? ] [ anonymous-complement-or ] } { [ dup anonymous-complement? ] [ anonymous-complement-or ] }
{ [ over anonymous-complement? ] [ swap anonymous-complement-or ] } { [ over anonymous-complement? ] [ swap anonymous-complement-or ] }
[ ((class-or)) ] [ ((class-or)) ]
} cond ; } cond ;
: (class-not) ( class -- complement ) : (class-not) ( class -- complement )
{ {
{ [ dup anonymous-complement? ] [ class>> ] } { [ dup anonymous-complement? ] [ class>> ] }
{ [ dup object eq? ] [ drop null ] } { [ dup object eq? ] [ drop null ] }
{ [ dup null eq? ] [ drop object ] } { [ dup null eq? ] [ drop object ] }
[ <anonymous-complement> ] [ <anonymous-complement> ]
} cond ; } cond ;
M: anonymous-union (flatten-class) M: anonymous-union (flatten-class)
members>> [ (flatten-class) ] each ; members>> [ (flatten-class) ] each ;
PRIVATE> PRIVATE>
ERROR: topological-sort-failed ; ERROR: topological-sort-failed ;
: largest-class ( seq -- n elt ) : largest-class ( seq -- n elt )
dup [ [ class< ] with any? not ] curry find-last dup [ [ class< ] with any? not ] curry find-last
[ topological-sort-failed ] unless* ; [ topological-sort-failed ] unless* ;
: sort-classes ( seq -- newseq ) : sort-classes ( seq -- newseq )
[ name>> ] sort-with >vector [ name>> ] sort-with >vector
[ dup empty? not ] [ dup empty? not ]
[ dup largest-class [ swap remove-nth! ] dip ] [ dup largest-class [ swap remove-nth! ] dip ]
produce nip ; produce nip ;
: smallest-class ( classes -- class/f ) : smallest-class ( classes -- class/f )
[ f ] [ [ f ] [
natural-sort <reversed> natural-sort <reversed>
[ ] [ [ class<= ] most ] map-reduce [ ] [ [ class<= ] most ] map-reduce
] if-empty ; ] if-empty ;
: flatten-class ( class -- assoc ) : flatten-class ( class -- assoc )
[ (flatten-class) ] H{ } make-assoc ; [ (flatten-class) ] H{ } make-assoc ;

548
core/continuations/continuations-docs.factor
View File

@ -1,274 +1,274 @@
USING: help.markup help.syntax kernel kernel.private USING: help.markup help.syntax kernel kernel.private
continuations.private vectors arrays namespaces continuations.private vectors arrays namespaces
assocs words quotations lexer sequences math ; assocs words quotations lexer sequences math ;
IN: continuations IN: continuations
ARTICLE: "errors-restartable" "Restartable errors" ARTICLE: "errors-restartable" "Restartable errors"
"Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:" "Support for restartable errors is built on top of the basic error handling facility. The following words signals recoverable errors:"
{ $subsections { $subsections
throw-restarts throw-restarts
rethrow-restarts rethrow-restarts
} }
"The list of restarts from the most recently-thrown error is stored in a global variable:" "The list of restarts from the most recently-thrown error is stored in a global variable:"
{ $subsections restarts } { $subsections restarts }
"To invoke restarts, see " { $link "debugger" } "." ; "To invoke restarts, see " { $link "debugger" } "." ;
ARTICLE: "errors-post-mortem" "Post-mortem error inspection" ARTICLE: "errors-post-mortem" "Post-mortem error inspection"
"The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:" "The most recently thrown error, together with the continuation at that point, are stored in a pair of global variables:"
{ $subsections { $subsections
error error
error-continuation error-continuation
} }
"Developer tools for inspecting these values are found in " { $link "debugger" } "." ; "Developer tools for inspecting these values are found in " { $link "debugger" } "." ;
ARTICLE: "errors-anti-examples" "Common error handling pitfalls" ARTICLE: "errors-anti-examples" "Common error handling pitfalls"
"When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind." "When used correctly, exception handling can lead to more robust code with less duplication of error handling logic. However, there are some pitfalls to keep in mind."
{ $heading "Anti-pattern #1: Ignoring errors" } { $heading "Anti-pattern #1: Ignoring errors" }
"The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user." "The " { $link ignore-errors } " word should almost never be used. Ignoring errors does not make code more robust and in fact makes it much harder to debug if an intermittent error does show up when the code is run under previously unforseen circumstances. Never ignore unexpected errors; always report them to the user."
{ $heading "Anti-pattern #2: Catching errors too early" } { $heading "Anti-pattern #2: Catching errors too early" }
"A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible." "A less severe form of the previous anti-pattern is code that makes overly zealous use of " { $link recover } ". It is almost always a mistake to catch an error, log a message, and keep going. The only exception is network servers and other long-running processes that must remain running even if individual tasks fail. In these cases, place the " { $link recover } " as high up in the call stack as possible."
$nl $nl
"In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically." "In most other cases, " { $link cleanup } " should be used instead to handle an error and rethrow it automatically."
{ $heading "Anti-pattern #3: Dropping and rethrowing" } { $heading "Anti-pattern #3: Dropping and rethrowing" }
"Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught." "Do not use " { $link recover } " to handle an error by dropping it and throwing a new error. By losing the original error message, you signal to the user that something failed without leaving any indication of what actually went wrong. Either wrap the error in a new error containing additional information, or rethrow the original error. A more subtle form of this is using " { $link throw } " instead of " { $link rethrow } ". The " { $link throw } " word should only be used when throwing new errors, and never when rethrowing errors that have been caught."
{ $heading "Anti-pattern #4: Logging and rethrowing" } { $heading "Anti-pattern #4: Logging and rethrowing" }
"If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ; "If you are going to rethrow an error, do not log a message. If you do so, the user will see two log messages for the same error, which will clutter logs without adding any useful information." ;
ARTICLE: "errors" "Exception handling" ARTICLE: "errors" "Exception handling"
"Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations." "Support for handling exceptional situations such as bad user input, implementation bugs, and input/output errors is provided by a set of words built using continuations."
$nl $nl
"Two words raise an error in the innermost error handler for the current dynamic extent:" "Two words raise an error in the innermost error handler for the current dynamic extent:"
{ $subsections { $subsections
throw throw
rethrow rethrow
} }
"Words for establishing an error handler:" "Words for establishing an error handler:"
{ $subsections { $subsections
cleanup cleanup
recover recover
ignore-errors ignore-errors
} }
"Syntax sugar for defining errors:" "Syntax sugar for defining errors:"
{ $subsections POSTPONE: ERROR: } { $subsections POSTPONE: ERROR: }
"Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "." "Unhandled errors are reported in the listener and can be debugged using various tools. See " { $link "debugger" } "."
{ $subsections { $subsections
"errors-restartable" "errors-restartable"
"debugger" "debugger"
"errors-post-mortem" "errors-post-mortem"
"errors-anti-examples" "errors-anti-examples"
} }
"When Factor encouters a critical error, it calls the following word:" "When Factor encouters a critical error, it calls the following word:"
{ $subsections die } ; { $subsections die } ;
ARTICLE: "continuations.private" "Continuation implementation details" ARTICLE: "continuations.private" "Continuation implementation details"
"A continuation is simply a tuple holding the contents of the five stacks:" "A continuation is simply a tuple holding the contents of the five stacks:"
{ $subsections { $subsections
continuation continuation
>continuation< >continuation<
} }
"The five stacks can be read and written:" "The five stacks can be read and written:"
{ $subsections { $subsections
datastack datastack
set-datastack set-datastack
retainstack retainstack
set-retainstack set-retainstack
callstack callstack
set-callstack set-callstack
namestack namestack
set-namestack set-namestack
catchstack catchstack
set-catchstack set-catchstack
} ; } ;
ARTICLE: "continuations" "Continuations" ARTICLE: "continuations" "Continuations"
"At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation." "At any point in the execution of a program, the " { $emphasis "current continuation" } " represents the future of the computation."
$nl $nl
"Words for working with continuations are found in the " { $vocab-link "continuations" } " vocabulary; implementation details are in " { $vocab-link "continuations.private" } "." "Words for working with continuations are found in the " { $vocab-link "continuations" } " vocabulary; implementation details are in " { $vocab-link "continuations.private" } "."
$nl $nl
"Continuations can be reified with the following two words:" "Continuations can be reified with the following two words:"
{ $subsections { $subsections
callcc0 callcc0
callcc1 callcc1
} }
"Another two words resume continuations:" "Another two words resume continuations:"
{ $subsections { $subsections
continue continue
continue-with continue-with
} }
"Continuations as control-flow:" "Continuations as control-flow:"
{ $subsections { $subsections
attempt-all attempt-all
with-return with-return
} }
"Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "." "Continuations serve as the building block for a number of higher-level abstractions, such as " { $link "errors" } " and " { $link "threads" } "."
{ $subsections "continuations.private" } ; { $subsections "continuations.private" } ;
ABOUT: "continuations" ABOUT: "continuations"
HELP: catchstack* HELP: catchstack*
{ $values { "catchstack" "a vector of continuations" } } { $values { "catchstack" "a vector of continuations" } }
{ $description "Outputs the current catchstack." } ; { $description "Outputs the current catchstack." } ;
HELP: catchstack HELP: catchstack
{ $values { "catchstack" "a vector of continuations" } } { $values { "catchstack" "a vector of continuations" } }
{ $description "Outputs a copy of the current catchstack." } ; { $description "Outputs a copy of the current catchstack." } ;
HELP: set-catchstack HELP: set-catchstack
{ $values { "catchstack" "a vector of continuations" } } { $values { "catchstack" "a vector of continuations" } }
{ $description "Replaces the catchstack with a copy of the given vector." } ; { $description "Replaces the catchstack with a copy of the given vector." } ;
HELP: continuation HELP: continuation
{ $values { "continuation" continuation } } { $values { "continuation" continuation } }
{ $description "Reifies the current continuation from the point immediately after which the caller returns." } ; { $description "Reifies the current continuation from the point immediately after which the caller returns." } ;
HELP: >continuation< HELP: >continuation<
{ $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } } { $values { "continuation" continuation } { "data" vector } { "call" vector } { "retain" vector } { "name" vector } { "catch" vector } }
{ $description "Takes a continuation apart into its constituents." } ; { $description "Takes a continuation apart into its constituents." } ;
HELP: ifcc HELP: ifcc
{ $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } } { $values { "capture" { $quotation "( continuation -- )" } } { "restore" quotation } }
{ $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ; { $description "Reifies a continuation from the point immediately after which this word returns, and passes it to " { $snippet "capture" } ". When the continuation is restored, execution resumes and "{ $snippet "restore" } " is called." } ;
{ callcc0 continue callcc1 continue-with ifcc } related-words { callcc0 continue callcc1 continue-with ifcc } related-words
HELP: callcc0 HELP: callcc0
{ $values { "quot" { $quotation "( continuation -- )" } } } { $values { "quot" { $quotation "( continuation -- )" } } }
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ; { $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue } " word resumes the continuation." } ;
HELP: callcc1 HELP: callcc1
{ $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } } { $values { "quot" { $quotation "( continuation -- )" } } { "obj" "an object provided when resuming the continuation" } }
{ $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ; { $description "Applies the quotation to the current continuation, which is reified from the point immediately after which the caller returns. The " { $link continue-with } " word resumes the continuation, passing a value back to the original execution context." } ;
HELP: continue HELP: continue
{ $values { "continuation" continuation } } { $values { "continuation" continuation } }
{ $description "Resumes a continuation reified by " { $link callcc0 } "." } ; { $description "Resumes a continuation reified by " { $link callcc0 } "." } ;
HELP: continue-with HELP: continue-with
{ $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } } { $values { "obj" "an object to pass to the continuation's execution context" } { "continuation" continuation } }
{ $description "Resumes a continuation reified by " { $link callcc1 } ". The object will be placed on the data stack when the continuation resumes." } ; { $description "Resumes a continuation reified by " { $link callcc1 } ". The object will be placed on the data stack when the continuation resumes." } ;
HELP: error HELP: error
{ $description "Global variable holding most recently thrown error." } { $description "Global variable holding most recently thrown error." }
{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; { $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
HELP: error-continuation HELP: error-continuation
{ $description "Global variable holding current continuation of most recently thrown error." } { $description "Global variable holding current continuation of most recently thrown error." }
{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; { $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
HELP: restarts HELP: restarts
{ $var-description "Global variable holding the set of possible restarts for the most recently thrown error." } { $var-description "Global variable holding the set of possible restarts for the most recently thrown error." }
{ $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ; { $notes "Only updated by " { $link throw } ", not " { $link rethrow } "." } ;
HELP: >c HELP: >c
{ $values { "continuation" continuation } } { $values { "continuation" continuation } }
{ $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ; { $description "Pushes an exception handler continuation on the catch stack. The continuation must have been reified by " { $link callcc1 } "." } ;
HELP: c> HELP: c>
{ $values { "continuation" continuation } } { $values { "continuation" continuation } }
{ $description "Pops an exception handler continuation from the catch stack." } ; { $description "Pops an exception handler continuation from the catch stack." } ;
HELP: throw HELP: throw
{ $values { "error" object } } { $values { "error" object } }
{ $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ; { $description "Saves the current continuation in the " { $link error-continuation } " global variable and throws an error. Execution does not continue at the point after the " { $link throw } " call. Rather, the innermost catch block is invoked, and execution continues at that point." } ;
{ cleanup recover } related-words { cleanup recover } related-words
HELP: cleanup HELP: cleanup
{ $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } } { $values { "try" quotation } { "cleanup-always" quotation } { "cleanup-error" quotation } }
{ $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ; { $description "Calls the " { $snippet "try" } " quotation. If no error is thrown, calls " { $snippet "cleanup-always" } " without restoring the data stack. If an error is thrown, restores the data stack, calls " { $snippet "cleanup-always" } " followed by " { $snippet "cleanup-error" } ", and rethrows the error." } ;
HELP: recover HELP: recover
{ $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } } { $values { "try" quotation } { "recovery" { $quotation "( error -- )" } } }
{ $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ; { $description "Calls the " { $snippet "try" } " quotation. If an exception is thrown in the dynamic extent of the " { $snippet "try" } " quotation, restores the data stack and calls the " { $snippet "recovery" } " quotation to handle the error." } ;
HELP: ignore-errors HELP: ignore-errors
{ $values { "quot" quotation } } { $values { "quot" quotation } }
{ $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ; { $description "Calls the quotation. If an exception is thrown in the dynamic extent of the quotation, restores the data stack and returns." } ;
HELP: rethrow HELP: rethrow
{ $values { "error" object } } { $values { "error" object } }
{ $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." } { $description "Throws an error without saving the current continuation in the " { $link error-continuation } " global variable. This is done so that inspecting the error stacks sheds light on the original cause of the exception, rather than the point where it was rethrown." }
{ $notes { $notes
"This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler." "This word is intended to be used in conjunction with " { $link recover } " to implement error handlers which perform an action and pass the error to the next outermost error handler."
} }
{ $examples { $examples
"The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:" "The " { $link with-lexer } " word catches errors, annotates them with the current line and column number, and rethrows them:"
{ $see with-lexer } { $see with-lexer }
} ; } ;
HELP: throw-restarts HELP: throw-restarts
{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } { $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
{ $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." } { $description "Throws a restartable error using " { $link throw } ". The " { $snippet "restarts" } " parameter is a sequence of pairs where the first element in each pair is a human-readable description and the second is an arbitrary object. If the error reaches the top-level error handler, the user will be presented with the list of possible restarts, and upon invoking one, execution will continue after the call to " { $link throw-restarts } " with the object associated to the chosen restart on the stack." }
{ $examples { $examples
"Try invoking one of the two restarts which are offered after the below code throws an error:" "Try invoking one of the two restarts which are offered after the below code throws an error:"
{ $code { $code
": restart-test" ": restart-test"
" \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition" " \"Oops!\" { { \"One\" 1 } { \"Two\" 2 } } condition"
" \"You restarted: \" write . ;" " \"You restarted: \" write . ;"
"restart-test" "restart-test"
} }
} ; } ;
HELP: rethrow-restarts HELP: rethrow-restarts
{ $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } } { $values { "error" object } { "restarts" "a sequence of " { $snippet "{ string object }" } " pairs" } { "restart" object } }
{ $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ; { $description "Throws a restartable error using " { $link rethrow } ". Otherwise, this word is identical to " { $link throw-restarts } "." } ;
{ throw rethrow throw-restarts rethrow-restarts } related-words { throw rethrow throw-restarts rethrow-restarts } related-words
HELP: compute-restarts HELP: compute-restarts
{ $values { "error" object } { "seq" "a sequence" } } { $values { "error" object } { "seq" "a sequence" } }
{ $description "Outputs a sequence of triples, where each triple consists of a human-readable string, an object, and a continuation. Resuming a continuation with the corresponding object restarts execution immediately after the corresponding call to " { $link condition } "." { $description "Outputs a sequence of triples, where each triple consists of a human-readable string, an object, and a continuation. Resuming a continuation with the corresponding object restarts execution immediately after the corresponding call to " { $link condition } "."
$nl $nl
"This word recursively travels up the delegation chain to collate restarts from nested and wrapped conditions." } ; "This word recursively travels up the delegation chain to collate restarts from nested and wrapped conditions." } ;
HELP: save-error HELP: save-error
{ $values { "error" "an error" } } { $values { "error" "an error" } }
{ $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." } { $description "Called by the error handler to set the " { $link error } " and " { $link restarts } " global variables after an error was thrown." }
$low-level-note ; $low-level-note ;
HELP: with-datastack HELP: with-datastack
{ $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } } { $values { "stack" sequence } { "quot" quotation } { "newstack" sequence } }
{ $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." } { $description "Executes the quotation with the given data stack contents, and outputs the new data stack after the word returns. The input sequence is not modified; a new sequence is produced. Does not affect the data stack in surrounding code, other than consuming the two inputs and pushing the output." }
{ $examples { $examples
{ $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" } { $example "USING: continuations math prettyprint ;" "{ 3 7 } [ + ] with-datastack ." "{ 10 }" }
} ; } ;
HELP: attempt-all HELP: attempt-all
{ $values { $values
{ "seq" sequence } { "quot" quotation } { "seq" sequence } { "quot" quotation }
{ "obj" object } } { "obj" object } }
{ $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." } { $description "Applies the quotation to elements in a sequence and returns the value from the first quotation that does not throw an error. If all quotations throw an error, returns the last error thrown." }
{ $examples "The first two numbers throw, the last one doesn't:" { $examples "The first two numbers throw, the last one doesn't:"
{ $example { $example
"USING: prettyprint continuations kernel math ;" "USING: prettyprint continuations kernel math ;"
"{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ." "{ 1 3 6 } [ dup odd? [ \"Odd\" throw ] when ] attempt-all ."
"6" } "6" }
"All quotations throw, the last exception is rethrown:" "All quotations throw, the last exception is rethrown:"
{ $example { $example
"USING: prettyprint continuations kernel math ;" "USING: prettyprint continuations kernel math ;"
"[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ." "[ { 1 3 5 } [ dup odd? [ throw ] when ] attempt-all ] [ ] recover ."
"5" "5"
} }
} ; } ;
HELP: return HELP: return
{ $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ; { $description "Returns early from a quotation by reifying the continuation captured by " { $link with-return } " ; execution is resumed starting immediately after " { $link with-return } "." } ;
HELP: with-return HELP: with-return
{ $values { $values
{ "quot" quotation } } { "quot" quotation } }
{ $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." } { $description "Captures a continuation that can be reified by calling the " { $link return } " word. If so, it will resume execution immediatly after the " { $link with-return } " word. If " { $link return } " is not called, then execution proceeds as if this word were simply " { $link call } "." }
{ $examples { $examples
"Only \"Hi\" will print:" "Only \"Hi\" will print:"
{ $example { $example
"USING: prettyprint continuations io ;" "USING: prettyprint continuations io ;"
"[ \"Hi\" print return \"Bye\" print ] with-return" "[ \"Hi\" print return \"Bye\" print ] with-return"
"Hi" "Hi"
} } ; } } ;
{ return with-return } related-words { return with-return } related-words
HELP: restart HELP: restart
{ $values { "restart" restart } } { $values { "restart" restart } }
{ $description "Invokes a restart." } { $description "Invokes a restart." }
{ $class-description "The class of restarts." } ; { $class-description "The class of restarts." } ;

216
core/continuations/continuations-tests.factor
View File

@ -1,108 +1,108 @@
USING: kernel math namespaces io tools.test sequences vectors USING: kernel math namespaces io tools.test sequences vectors
continuations debugger parser memory arrays words continuations debugger parser memory arrays words
kernel.private accessors eval ; kernel.private accessors eval ;
IN: continuations.tests IN: continuations.tests
: (callcc1-test) ( n obj -- n' obj ) : (callcc1-test) ( n obj -- n' obj )
[ 1 - dup ] dip ?push [ 1 - dup ] dip ?push
over 0 = [ "test-cc" get continue-with ] when over 0 = [ "test-cc" get continue-with ] when
(callcc1-test) ; (callcc1-test) ;
: callcc1-test ( x -- list ) : callcc1-test ( x -- list )
[ [
"test-cc" set V{ } clone (callcc1-test) "test-cc" set V{ } clone (callcc1-test)
] callcc1 nip ; ] callcc1 nip ;
: callcc-namespace-test ( -- ? ) : callcc-namespace-test ( -- ? )
[ [
"test-cc" set "test-cc" set
5 "x" set 5 "x" set
[ [
6 "x" set "test-cc" get continue 6 "x" set "test-cc" get continue
] with-scope ] with-scope
] callcc0 "x" get 5 = ; ] callcc0 "x" get 5 = ;
[ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test [ t ] [ 10 callcc1-test 10 iota reverse >vector = ] unit-test
[ t ] [ callcc-namespace-test ] unit-test [ t ] [ callcc-namespace-test ] unit-test
[ 5 throw ] [ 5 = ] must-fail-with [ 5 throw ] [ 5 = ] must-fail-with
[ t ] [ [ t ] [
[ "Hello" throw ] ignore-errors [ "Hello" throw ] ignore-errors
error get-global error get-global
"Hello" = "Hello" =
] unit-test ] unit-test
"!!! The following error is part of the test" print "!!! The following error is part of the test" print
[ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test [ ] [ [ 6 [ 12 [ "2 car" ] ] ] print-error ] unit-test
"!!! The following error is part of the test" print "!!! The following error is part of the test" print
[ ] [ [ [ "2 car" ] eval ] try ] unit-test [ ] [ [ [ "2 car" ] eval ] try ] unit-test
[ f throw ] must-fail [ f throw ] must-fail
! Weird PowerPC bug. ! Weird PowerPC bug.
[ ] [ [ ] [
[ "4" throw ] ignore-errors [ "4" throw ] ignore-errors
gc gc
gc gc
] unit-test ] unit-test
! ! See how well callstack overflow is handled ! ! See how well callstack overflow is handled
! [ clear drop ] must-fail ! [ clear drop ] must-fail
! !
! : callstack-overflow callstack-overflow f ; ! : callstack-overflow callstack-overflow f ;
! [ callstack-overflow ] must-fail ! [ callstack-overflow ] must-fail
: don't-compile-me ( -- ) ; : don't-compile-me ( -- ) ;
: foo ( -- ) callstack "c" set don't-compile-me ; : foo ( -- ) callstack "c" set don't-compile-me ;
: bar ( -- a b ) 1 foo 2 ; : bar ( -- a b ) 1 foo 2 ;
<< { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >> << { don't-compile-me foo bar } [ t "no-compile" set-word-prop ] each >>
[ 1 2 ] [ bar ] unit-test [ 1 2 ] [ bar ] unit-test
[ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test [ t ] [ \ bar def>> "c" get innermost-frame-executing = ] unit-test
[ 1 ] [ "c" get innermost-frame-scan ] unit-test [ 1 ] [ "c" get innermost-frame-scan ] unit-test
SYMBOL: always-counter SYMBOL: always-counter
SYMBOL: error-counter SYMBOL: error-counter
[ [
0 always-counter set 0 always-counter set
0 error-counter set 0 error-counter set
[ ] [ always-counter inc ] [ error-counter inc ] cleanup [ ] [ always-counter inc ] [ error-counter inc ] cleanup
[ 1 ] [ always-counter get ] unit-test [ 1 ] [ always-counter get ] unit-test
[ 0 ] [ error-counter get ] unit-test [ 0 ] [ error-counter get ] unit-test
[ [
[ "a" throw ] [ "a" throw ]
[ always-counter inc ] [ always-counter inc ]
[ error-counter inc ] cleanup [ error-counter inc ] cleanup
] [ "a" = ] must-fail-with ] [ "a" = ] must-fail-with
[ 2 ] [ always-counter get ] unit-test [ 2 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test
[ [
[ ] [ ]
[ always-counter inc "a" throw ] [ always-counter inc "a" throw ]
[ error-counter inc ] cleanup [ error-counter inc ] cleanup
] [ "a" = ] must-fail-with ] [ "a" = ] must-fail-with
[ 3 ] [ always-counter get ] unit-test [ 3 ] [ always-counter get ] unit-test
[ 1 ] [ error-counter get ] unit-test [ 1 ] [ error-counter get ] unit-test
] with-scope ] with-scope
[ ] [ [ return ] with-return ] unit-test [ ] [ [ return ] with-return ] unit-test
[ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with [ { } [ ] attempt-all ] [ attempt-all-error? ] must-fail-with
[ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test [ { 4 } ] [ { 2 2 } [ + ] with-datastack ] unit-test
[ with-datastack ] must-infer [ with-datastack ] must-infer

2
misc/fuel/fuel-syntax.el
View File

@ -159,13 +159,13 @@
"MEMO" "MEMO:" "METHOD" "MEMO" "MEMO:" "METHOD"
"SYNTAX" "SYNTAX"
"PREDICATE" "PRIMITIVE" "PREDICATE" "PRIMITIVE"
"STRUCT" "TAG" "TUPLE" "UNION-STRUCT"
"UNION")) "UNION"))
(defconst fuel-syntax--no-indent-def-starts '("ARTICLE" (defconst fuel-syntax--no-indent-def-starts '("ARTICLE"
"HELP" "HELP"
"SINGLETONS" "SINGLETONS"
"SYMBOLS" "SYMBOLS"
"TUPLE"
"VARS")) "VARS"))
(defconst fuel-syntax--indent-def-start-regex (defconst fuel-syntax--indent-def-start-regex

198
unmaintained/odbc/odbc-docs.factor
View File

@ -1,99 +1,99 @@
! Copyright (C) 2007 Chris Double. ! Copyright (C) 2007 Chris Double.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: help.syntax help.markup threads ; USING: help.syntax help.markup threads ;
IN: odbc IN: odbc
HELP: odbc-init HELP: odbc-init
{ $values { "env" "an ODBC environment handle" } } { $values { "env" "an ODBC environment handle" } }
{ $description { $description
"Initializes the ODBC driver manager and returns the " "Initializes the ODBC driver manager and returns the "
"environment handle required by " { $link odbc-connect } "." "environment handle required by " { $link odbc-connect } "."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-connect HELP: odbc-connect
{ $values { "env" "an ODBC environment handle" } { "dsn" "a string" } { "dbc" "an ODBC database connection handle" } } { $values { "env" "an ODBC environment handle" } { "dsn" "a string" } { "dbc" "an ODBC database connection handle" } }
{ $description { $description
"Connects to the database identified by the ODBC data source name (DSN). " "Connects to the database identified by the ODBC data source name (DSN). "
"The environment handle is usually obtained by a call to " { $link odbc-init } ". The result is the ODBC connection handle which can be used in other ODBC calls. When finished with the connection handle " { $link odbc-disconnect } " must be called on it." "The environment handle is usually obtained by a call to " { $link odbc-init } ". The result is the ODBC connection handle which can be used in other ODBC calls. When finished with the connection handle " { $link odbc-disconnect } " must be called on it."
} }
{ $examples { $code "dbc get \"DSN=mydsn\" odbc-connect" } } { $examples { $code "dbc get \"DSN=mydsn\" odbc-connect" } }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-disconnect HELP: odbc-disconnect
{ $values { "dbc" "an ODBC database connection handle" } } { $values { "dbc" "an ODBC database connection handle" } }
{ $description { $description
"Disconnects from the given database." "Disconnects from the given database."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-prepare HELP: odbc-prepare
{ $values { "dbc" "an ODBC database connection handle" } { "string" "a string containing SQL" } { "statement" "an ODBC statement handle" } } { $values { "dbc" "an ODBC database connection handle" } { "string" "a string containing SQL" } { "statement" "an ODBC statement handle" } }
{ $description { $description
"Prepares (precompiles) the given SQL string, ready for execution with " { $link odbc-execute } ". When finished with the statement " { $link odbc-free-statement } " must be called on it." "Prepares (precompiles) the given SQL string, ready for execution with " { $link odbc-execute } ". When finished with the statement " { $link odbc-free-statement } " must be called on it."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-free-statement HELP: odbc-free-statement
{ $values { "statement" "an ODBC statement handle" } } { $values { "statement" "an ODBC statement handle" } }
{ $description { $description
"Closes the statement handle and frees up all resources associated with it." "Closes the statement handle and frees up all resources associated with it."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-execute HELP: odbc-execute
{ $values { "statement" "an ODBC statement handle" } } { $values { "statement" "an ODBC statement handle" } }
{ $description { $description
"Executes the statement. Once this is done " { $link odbc-next-row } " can be called to retrieve rows." "Executes the statement. Once this is done " { $link odbc-next-row } " can be called to retrieve rows."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-next-row HELP: odbc-next-row
{ $values { "statement" "an ODBC statement handle" } { "bool" "a boolean indicating success or failure" } } { $values { "statement" "an ODBC statement handle" } { "bool" "a boolean indicating success or failure" } }
{ $description { $description
"Retrieves the next available row from the database. If no next row is available then " { $link f } " is returned. Once the row is retrieved " { $link odbc-number-of-columns } ", " { $link odbc-describe-column } ", " { $link odbc-get-field } " and " { $link odbc-get-row-fields } " can be used to query the data retrieved." "Retrieves the next available row from the database. If no next row is available then " { $link f } " is returned. Once the row is retrieved " { $link odbc-number-of-columns } ", " { $link odbc-describe-column } ", " { $link odbc-get-field } " and " { $link odbc-get-row-fields } " can be used to query the data retrieved."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-number-of-columns HELP: odbc-number-of-columns
{ $values { "statement" "an ODBC statement handle" } { "number" "a number" } } { $values { "statement" "an ODBC statement handle" } { "number" "a number" } }
{ $description { $description
"Returns the number of columns of data retrieved." "Returns the number of columns of data retrieved."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-describe-column HELP: odbc-describe-column
{ $values { "statement" "an ODBC statement handle" } { "n" "a column number starting from one" } { "column" "a column object" } } { $values { "statement" "an ODBC statement handle" } { "n" "a column number starting from one" } { "column" "a column object" } }
{ $description { $description
"Retrieves column information for the given column number from the statement. The column number must be one or greater. The " { $link <column> } " object returned provides data type, name, etc." "Retrieves column information for the given column number from the statement. The column number must be one or greater. The " { $link <column> } " object returned provides data type, name, etc."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-get-field HELP: odbc-get-field
{ $values { "statement" "an ODBC statement handle" } { "column" "a column number starting from one or a <column> object" } { "field" "a <field> object" } } { $values { "statement" "an ODBC statement handle" } { "column" "a column number starting from one or a <column> object" } { "field" "a <field> object" } }
{ $description { $description
"Returns a field object which contains the data for the field in the given column in the current row. The column can be identified by a number or a <column> object. The datatype of the contents of the field depends on the type of the column itself. Note that this word can only be safely called once on each column in a given row with most ODBC drivers. Subsequent calls on the same row for the same column can fail." "Returns a field object which contains the data for the field in the given column in the current row. The column can be identified by a number or a <column> object. The datatype of the contents of the field depends on the type of the column itself. Note that this word can only be safely called once on each column in a given row with most ODBC drivers. Subsequent calls on the same row for the same column can fail."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-get-row-fields HELP: odbc-get-row-fields
{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } } { $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } }
{ $description { $description
"Returns a sequence of all field data for the current row. Note that this isnot the <field> objects, but the data for that field. This word can only be called once on a given row. Subsequent calls on the same row may fail on some ODBC drivers." "Returns a sequence of all field data for the current row. Note that this isnot the <field> objects, but the data for that field. This word can only be called once on a given row. Subsequent calls on the same row may fail on some ODBC drivers."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-get-all-rows HELP: odbc-get-all-rows
{ $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } } { $values { "statement" "an ODBC statement handle" } { "seq" "a sequence" } }
{ $description { $description
"Returns a sequence of all rows available from the statement. Effectively it is the contents of the entire query so may take some time and memory. Each element of the sequence is itself a sequence containing the data for that row. A " { $link yield } " is performed an various intervals so as to not lock up the Factor instance while it is running." "Returns a sequence of all rows available from the statement. Effectively it is the contents of the entire query so may take some time and memory. Each element of the sequence is itself a sequence containing the data for that row. A " { $link yield } " is performed an various intervals so as to not lock up the Factor instance while it is running."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;
HELP: odbc-query HELP: odbc-query
{ $values { "string" "a string containing SQL" } { "dsn" "a DSN string" } { "result" "a sequence" } } { $values { "string" "a string containing SQL" } { "dsn" "a DSN string" } { "result" "a sequence" } }
{ $description { $description
"This word initializes odbc, connects to the database with the given DSN, executes the query string and returns the result as a sequence. It cleans up all resources it uses. It is an inefficient way of running multiple queries but is useful for the occasional query, testing at the REPL, or as an example of how to do it." "This word initializes odbc, connects to the database with the given DSN, executes the query string and returns the result as a sequence. It cleans up all resources it uses. It is an inefficient way of running multiple queries but is useful for the occasional query, testing at the REPL, or as an example of how to do it."
} }
{ $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ; { $see-also odbc-init odbc-connect odbc-disconnect odbc-prepare odbc-free-statement odbc-execute odbc-next-row odbc-number-of-columns odbc-describe-column odbc-get-field odbc-get-row-fields odbc-get-all-rows odbc-query } ;

1262
unmaintained/ogg/player/player.factor
View File

File diff suppressed because it is too large Load Diff

124
unmaintained/tabs/tabs.factor
View File

@ -1,62 +1,62 @@
! Copyright (C) 2008 William Schlieper ! Copyright (C) 2008 William Schlieper
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel fry math math.vectors sequences arrays vectors assocs USING: accessors kernel fry math math.vectors sequences arrays vectors assocs
hashtables models models.range models.product combinators hashtables models models.range models.product combinators
ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs ui ui.gadgets ui.gadgets.buttons ui.gadgets.frames ui.gadgets.packs
ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ; ui.gadgets.grids ui.gadgets.viewports ui.gadgets.books locals ;
IN: ui.gadgets.tabs IN: ui.gadgets.tabs
TUPLE: tabbed < frame names toggler content ; TUPLE: tabbed < frame names toggler content ;
DEFER: (del-page) DEFER: (del-page)
:: add-toggle ( n name model toggler -- ) :: add-toggle ( n name model toggler -- )
<frame> <frame>
n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button> n name toggler parent>> '[ drop _ _ _ (del-page) ] "X" swap <bevel-button>
@right grid-add @right grid-add
n model name <toggle-button> @center grid-add n model name <toggle-button> @center grid-add
toggler swap add-gadget drop ; toggler swap add-gadget drop ;
: redo-toggler ( tabbed -- ) : redo-toggler ( tabbed -- )
[ names>> ] [ model>> ] [ toggler>> ] tri [ names>> ] [ model>> ] [ toggler>> ] tri
[ clear-gadget ] keep [ clear-gadget ] keep
[ [ length ] keep ] 2dip [ [ length ] keep ] 2dip
'[ _ _ add-toggle ] 2each ; '[ _ _ add-toggle ] 2each ;
: refresh-book ( tabbed -- ) : refresh-book ( tabbed -- )
model>> [ ] change-model ; model>> [ ] change-model ;
: (del-page) ( n name tabbed -- ) : (del-page) ( n name tabbed -- )
{ [ [ remove ] change-names redo-toggler ] { [ [ remove ] change-names redo-toggler ]
[ dupd [ names>> length ] [ model>> ] bi [ dupd [ names>> length ] [ model>> ] bi
[ [ = ] keep swap [ 1- ] when [ [ = ] keep swap [ 1- ] when
[ < ] keep swap [ 1- ] when ] change-model ] [ < ] keep swap [ 1- ] when ] change-model ]
[ content>> nth-gadget unparent ] [ content>> nth-gadget unparent ]
[ refresh-book ] [ refresh-book ]
} cleave ; } cleave ;
: add-page ( page name tabbed -- ) : add-page ( page name tabbed -- )
[ names>> push ] 2keep [ names>> push ] 2keep
[ [ names>> length 1 - swap ] [ [ names>> length 1 - swap ]
[ model>> ] [ model>> ]
[ toggler>> ] tri add-toggle ] [ toggler>> ] tri add-toggle ]
[ content>> swap add-gadget drop ] [ content>> swap add-gadget drop ]
[ refresh-book ] tri ; [ refresh-book ] tri ;
: del-page ( name tabbed -- ) : del-page ( name tabbed -- )
[ names>> index ] 2keep (del-page) ; [ names>> index ] 2keep (del-page) ;
: new-tabbed ( assoc class -- tabbed ) : new-tabbed ( assoc class -- tabbed )
new-frame new-frame
0 <model> >>model 0 <model> >>model
<pile> 1 >>fill >>toggler <pile> 1 >>fill >>toggler
dup toggler>> @left grid-add dup toggler>> @left grid-add
swap swap
[ keys >vector >>names ] [ keys >vector >>names ]
[ values over model>> <book> >>content dup content>> @center grid-add ] [ values over model>> <book> >>content dup content>> @center grid-add ]
bi bi
dup redo-toggler ; dup redo-toggler ;
: <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ; : <tabbed> ( assoc -- tabbed ) tabbed new-tabbed ;

40
vm/vm.cpp
View File

@ -1,20 +1,20 @@
#include "master.hpp" #include "master.hpp"
namespace factor namespace factor
{ {
factor_vm::factor_vm() : factor_vm::factor_vm() :
nursery(0,0), nursery(0,0),
c_to_factor_func(NULL), c_to_factor_func(NULL),
profiling_p(false), profiling_p(false),
gc_off(false), gc_off(false),
current_gc(NULL), current_gc(NULL),
gc_events(NULL), gc_events(NULL),
fep_disabled(false), fep_disabled(false),
full_output(false), full_output(false),
last_nano_count(0) last_nano_count(0)
{ {
primitive_reset_dispatch_stats(); primitive_reset_dispatch_stats();
} }
} }