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

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

db4
Aaron Schaefer 2009-05-05 12:16:03 -04:00
parent 17fa5ac5f1 786b9096e2
commit 3466b5d986
402 changed files with 9806 additions and 8724 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

31
Makefile
View File

@ -1,4 +1,5 @@
CC = gcc
CPP = g++
AR = ar
LD = ld
@ -9,7 +10,7 @@ VERSION = 0.92
BUNDLE = Factor.app
LIBPATH = -L/usr/X11R6/lib
CFLAGS = -Wall -Werror
CFLAGS = -Wall
ifdef DEBUG
CFLAGS += -g -DFACTOR_DEBUG
@ -35,6 +36,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/code_block.o \
vm/code_gc.o \
vm/code_heap.o \
vm/contexts.o \
vm/data_gc.o \
vm/data_heap.o \
vm/debug.o \
@ -45,6 +47,7 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/inline_cache.o \
vm/io.o \
vm/jit.o \
vm/local_roots.o \
vm/math.o \
vm/primitives.o \
vm/profiler.o \
@ -53,7 +56,8 @@ DLL_OBJS = $(PLAF_DLL_OBJS) \
vm/strings.o \
vm/tuples.o \
vm/utilities.o \
vm/words.o
vm/words.o \
vm/write_barrier.o
EXE_OBJS = $(PLAF_EXE_OBJS)
@ -161,12 +165,12 @@ macosx.app: factor
$(EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) -o $@$(EXE_SUFFIX)$(EXE_EXTENSION) $(EXE_OBJS)
$(CONSOLE_EXECUTABLE): $(DLL_OBJS) $(EXE_OBJS)
$(LINKER) $(ENGINE) $(DLL_OBJS)
$(CC) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CPP) $(LIBS) $(LIBPATH) -L. $(LINK_WITH_ENGINE) \
$(CFLAGS) $(CFLAGS_CONSOLE) -o factor$(EXE_SUFFIX)$(CONSOLE_EXTENSION) $(EXE_OBJS)
$(TEST_LIBRARY): vm/ffi_test.o
@ -174,7 +178,13 @@ $(TEST_LIBRARY): vm/ffi_test.o
clean:
rm -f vm/*.o
rm -f factor*.dll libfactor.{a,so,dylib} libfactor-ffi-test.{a,so,dylib} Factor.app/Contents/Frameworks/libfactor.dylib
rm -f factor.dll
rm -f libfactor.*
rm -f libfactor-ffi-test.*
rm -f Factor.app/Contents/Frameworks/libfactor.dylib
tags:
etags vm/*.{cpp,hpp,mm,S,c}
vm/resources.o:
$(WINDRES) vm/factor.rs vm/resources.o
@ -185,10 +195,15 @@ vm/ffi_test.o: vm/ffi_test.c
.c.o:
$(CC) -c $(CFLAGS) -o $@ $<
.cpp.o:
$(CPP) -c $(CFLAGS) -o $@ $<
.S.o:
$(CC) -x assembler-with-cpp -c $(CFLAGS) -o $@ $<
.m.o:
$(CC) -c $(CFLAGS) -o $@ $<
.mm.o:
$(CPP) -c $(CFLAGS) -o $@ $<
.PHONY: factor
.PHONY: factor tags clean
.SUFFIXES: .mm

4
README.txt
View File

@ -20,7 +20,7 @@ implementation. It is not an introduction to the language itself.
* Compiling the Factor VM
The Factor runtime is written in GNU C99, and is built with GNU make and
The Factor runtime is written in GNU C++, and is built with GNU make and
gcc.
Factor supports various platforms. For an up-to-date list, see
@ -138,7 +138,7 @@ usage documentation, enter the following in the UI listener:
The Factor source tree is organized as follows:
build-support/ - scripts used for compiling Factor
vm/ - sources for the Factor VM, written in C
vm/ - sources for the Factor VM, written in C++
core/ - Factor core library
basis/ - Factor basis library, compiler, tools
extra/ - more libraries and applications

65
basis/alien/arrays/arrays.factor
View File

@ -1,7 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien arrays alien.c-types alien.structs
sequences math kernel namespaces fry libc cpu.architecture ;
USING: alien alien.strings alien.c-types alien.accessors alien.structs
arrays words sequences math kernel namespaces fry libc cpu.architecture
io.encodings.utf8 io.encodings.utf16n ;
IN: alien.arrays
UNION: value-type array struct-type ;
@ -38,3 +39,61 @@ M: value-type c-type-getter
M: value-type c-type-setter ( type -- quot )
[ c-type-getter ] [ c-type-unboxer-quot ] [ heap-size ] tri
'[ @ swap @ _ memcpy ] ;
PREDICATE: string-type < pair
first2 [ "char*" = ] [ word? ] bi* and ;
M: string-type c-type ;
M: string-type c-type-class
drop object ;
M: string-type heap-size
drop "void*" heap-size ;
M: string-type c-type-align
drop "void*" c-type-align ;
M: string-type c-type-stack-align?
drop "void*" c-type-stack-align? ;
M: string-type unbox-parameter
drop "void*" unbox-parameter ;
M: string-type unbox-return
drop "void*" unbox-return ;
M: string-type box-parameter
drop "void*" box-parameter ;
M: string-type box-return
drop "void*" box-return ;
M: string-type stack-size
drop "void*" stack-size ;
M: string-type c-type-reg-class
drop int-regs ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;
M: string-type c-type-unboxer
drop "void*" c-type-unboxer ;
M: string-type c-type-boxer-quot
second '[ _ alien>string ] ;
M: string-type c-type-unboxer-quot
second '[ _ string>alien ] ;
M: string-type c-type-getter
drop [ alien-cell ] ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
{ "char*" utf8 } "char*" typedef
"char*" "uchar*" typedef
{ "char*" utf16n } "wchar_t*" typedef

36
basis/alien/c-types/c-types-docs.factor
View File

@ -1,7 +1,7 @@
IN: alien.c-types
USING: alien help.syntax help.markup libc kernel.private
byte-arrays math strings hashtables alien.syntax
debugger destructors ;
byte-arrays math strings hashtables alien.syntax alien.strings sequences
io.encodings.string debugger destructors ;
HELP: <c-type>
{ $values { "type" hashtable } }
@ -114,6 +114,38 @@ HELP: define-out
{ $description "Defines a word " { $snippet "<" { $emphasis "name" } ">" } " with stack effect " { $snippet "( value -- array )" } ". This word allocates a byte array large enough to hold a value with C type " { $snippet "name" } ", and writes the value at the top of the stack to the array." }
{ $notes "This is an internal word called when defining C types, there is no need to call it on your own." } ;
{ string>alien alien>string malloc-string } related-words
HELP: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if one of the following conditions occurs:"
{ $list
"the string contains null code points"
"the string contains characters not representable using the encoding specified"
"memory allocation fails"
}
} ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
$nl
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
$nl
"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
$nl
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>alien }
{ $subsection malloc-string }
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsection alien>string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
ARTICLE: "byte-arrays-gc" "Byte arrays and the garbage collector"
"The Factor garbage collector can move byte arrays around, and it is only safe to pass byte arrays to C functions if the garbage collector will not run while C code still has a reference to the data."
$nl

16
basis/alien/c-types/c-types.factor
View File

@ -2,9 +2,10 @@
! See http://factorcode.org/license.txt for BSD license.
USING: byte-arrays arrays assocs kernel kernel.private libc math
namespaces make parser sequences strings words assocs splitting
math.parser cpu.architecture alien alien.accessors quotations
layouts system compiler.units io.files io.encodings.binary
accessors combinators effects continuations fry classes ;
math.parser cpu.architecture alien alien.accessors alien.strings
quotations layouts system compiler.units io io.files
io.encodings.binary io.streams.memory accessors combinators effects
continuations fry classes ;
IN: alien.c-types
DEFER: <int>
@ -213,6 +214,15 @@ M: f byte-length drop 0 ;
: memory>byte-array ( alien len -- byte-array )
[ nip (byte-array) dup ] 2keep memcpy ;
: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
M: memory-stream stream-read
[
[ index>> ] [ alien>> ] bi <displaced-alien>
swap memory>byte-array
] [ [ + ] change-index drop ] 2bi ;
: byte-array>memory ( byte-array base -- )
swap dup byte-length memcpy ;

8
basis/alien/libraries/libraries.factor
View File

@ -1,8 +1,12 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien assocs io.backend kernel namespaces ;
USING: accessors alien alien.strings assocs io.backend kernel namespaces ;
IN: alien.libraries
: dlopen ( path -- dll ) native-string>alien (dlopen) ;
: dlsym ( name dll -- alien ) [ native-string>alien ] dip (dlsym) ;
SYMBOL: libraries
libraries [ H{ } clone ] initialize
@ -18,4 +22,4 @@ TUPLE: library path abi dll ;
library dup [ dll>> ] when ;
: add-library ( name path abi -- )
<library> swap libraries get set-at ;
<library> swap libraries get set-at ;

52
basis/alien/strings/strings-docs.factor
View File

@ -1,52 +0,0 @@
USING: help.markup help.syntax strings byte-arrays alien libc
debugger io.encodings.string sequences ;
IN: alien.strings
HELP: string>alien
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "byte-array" byte-array } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated byte array." }
{ $errors "Throws an error if the string contains null characters, or characters not representable in the given encoding." } ;
{ string>alien alien>string malloc-string } related-words
HELP: alien>string
{ $values { "c-ptr" c-ptr } { "encoding" "an encoding descriptor" } { "string/f" "a string or " { $link f } } }
{ $description "Reads a null-terminated C string from the specified address with the given encoding." } ;
HELP: malloc-string
{ $values { "string" string } { "encoding" "an encoding descriptor" } { "alien" c-ptr } }
{ $description "Encodes a string together with a trailing null code point using the given encoding, and stores the resulting bytes in a freshly-allocated unmanaged memory block." }
{ $warning "Don't forget to deallocate the memory with a call to " { $link free } "." }
{ $errors "Throws an error if one of the following conditions occurs:"
{ $list
"the string contains null code points"
"the string contains characters not representable using the encoding specified"
"memory allocation fails"
}
} ;
HELP: string>symbol
{ $values { "str" string } { "alien" alien } }
{ $description "Converts the string to a format which is a valid symbol name for the Factor VM's compiled code linker. By performing this conversion ahead of time, the image loader can run without allocating memory."
$nl
"On Windows CE, symbols are represented as UCS2 strings, and on all other platforms they are ASCII strings." } ;
ARTICLE: "c-strings" "C strings"
"C string types are arrays with shape " { $snippet "{ \"char*\" encoding }" } ", where " { $snippet "encoding" } " is an encoding descriptor. The type " { $snippet "\"char*\"" } " is an alias for " { $snippet "{ \"char*\" utf8 }" } ". See " { $link "encodings-descriptors" } " for information about encoding descriptors."
$nl
"Passing a Factor string to a C function expecting a C string allocates a " { $link byte-array } " in the Factor heap; the string is then converted to the requested format and a raw pointer is passed to the function."
$nl
"If the conversion fails, for example if the string contains null bytes or characters with values higher than 255, a " { $link c-string-error. } " is thrown."
$nl
"Care must be taken if the C function expects a " { $snippet "char*" } " with a length in bytes, rather than a null-terminated " { $snippet "char*" } "; passing the result of calling " { $link length } " on the string object will not suffice. This is because a Factor string of " { $emphasis "n" } " characters will not necessarily encode to " { $emphasis "n" } " bytes. The correct idiom for C functions which take a string with a length is to first encode the string using " { $link encode } ", and then pass the resulting byte array together with the length of this byte array."
$nl
"Sometimes a C function has a parameter type of " { $snippet "void*" } ", and various data types, among them strings, can be passed in. In this case, strings are not automatically converted to aliens, and instead you must call one of these words:"
{ $subsection string>alien }
{ $subsection malloc-string }
"The first allocates " { $link byte-array } "s, and the latter allocates manually-managed memory which is not moved by the garbage collector and has to be explicitly freed by calling " { $link free } ". See " { $link "byte-arrays-gc" } " for a discussion of the two approaches."
$nl
"A word to read strings from arbitrary addresses:"
{ $subsection alien>string }
"For example, if a C function returns a " { $snippet "char*" } " but stipulates that the caller must deallocate the memory afterward, you must define the function as returning " { $snippet "void*" } ", and call one of the above words before passing the pointer to " { $link free } "." ;
ABOUT: "c-strings"

109
basis/alien/strings/strings.factor
View File

@ -1,109 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: arrays sequences kernel accessors math alien.accessors
alien.c-types byte-arrays words io io.encodings
io.encodings.utf8 io.streams.byte-array io.streams.memory system
alien strings cpu.architecture fry vocabs.loader combinators ;
IN: alien.strings
GENERIC# alien>string 1 ( c-ptr encoding -- string/f )
M: c-ptr alien>string
[ <memory-stream> ] [ <decoder> ] bi*
"\0" swap stream-read-until drop ;
M: f alien>string
drop ;
ERROR: invalid-c-string string ;
: check-string ( string -- )
0 over memq? [ invalid-c-string ] [ drop ] if ;
GENERIC# string>alien 1 ( string encoding -- byte-array )
M: c-ptr string>alien drop ;
M: string string>alien
over check-string
<byte-writer>
[ stream-write ]
[ 0 swap stream-write1 ]
[ stream>> >byte-array ]
tri ;
: malloc-string ( string encoding -- alien )
string>alien malloc-byte-array ;
PREDICATE: string-type < pair
first2 [ "char*" = ] [ word? ] bi* and ;
M: string-type c-type ;
M: string-type c-type-class
drop object ;
M: string-type heap-size
drop "void*" heap-size ;
M: string-type c-type-align
drop "void*" c-type-align ;
M: string-type c-type-stack-align?
drop "void*" c-type-stack-align? ;
M: string-type unbox-parameter
drop "void*" unbox-parameter ;
M: string-type unbox-return
drop "void*" unbox-return ;
M: string-type box-parameter
drop "void*" box-parameter ;
M: string-type box-return
drop "void*" box-return ;
M: string-type stack-size
drop "void*" stack-size ;
M: string-type c-type-reg-class
drop int-regs ;
M: string-type c-type-boxer
drop "void*" c-type-boxer ;
M: string-type c-type-unboxer
drop "void*" c-type-unboxer ;
M: string-type c-type-boxer-quot
second '[ _ alien>string ] ;
M: string-type c-type-unboxer-quot
second '[ _ string>alien ] ;
M: string-type c-type-getter
drop [ alien-cell ] ;
M: string-type c-type-setter
drop [ set-alien-cell ] ;
HOOK: alien>native-string os ( alien -- string )
HOOK: native-string>alien os ( string -- alien )
: dll-path ( dll -- string )
path>> alien>native-string ;
: string>symbol ( str -- alien )
dup string?
[ native-string>alien ]
[ [ native-string>alien ] map ] if ;
{ "char*" utf8 } "char*" typedef
"char*" "uchar*" typedef
{
{ [ os windows? ] [ "alien.strings.windows" require ] }
{ [ os unix? ] [ "alien.strings.unix" require ] }
} cond

1
basis/alien/strings/unix/summary.txt
View File

@ -1 +0,0 @@
Default string encoding on Unix

8
basis/alien/strings/unix/unix.factor
View File

@ -1,8 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings io.encodings.utf8 system ;
IN: alien.strings.unix
M: unix alien>native-string utf8 alien>string ;
M: unix native-string>alien utf8 string>alien ;

1
basis/alien/strings/windows/summary.txt
View File

@ -1 +0,0 @@
Default string encoding on Windows

1
basis/alien/strings/windows/tags.txt
View File

@ -1 +0,0 @@
unportable

13
basis/alien/strings/windows/windows.factor
View File

@ -1,13 +0,0 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: alien.strings alien.c-types io.encodings.utf8
io.encodings.utf16n system ;
IN: alien.strings.windows
M: windows alien>native-string utf16n alien>string ;
M: wince native-string>alien utf16n string>alien ;
M: winnt native-string>alien utf8 string>alien ;
{ "char*" utf16n } "wchar_t*" typedef

1
basis/bootstrap/stage2.factor
View File

@ -65,7 +65,6 @@ SYMBOL: bootstrap-time
"stage2: deployment mode" print
] [
"debugger" require
"alien.prettyprint" require
"inspector" require
"tools.errors" require
"listener" require

5
basis/bootstrap/tools/tools.factor
View File

@ -14,7 +14,8 @@ IN: bootstrap.tools
"tools.test"
"tools.time"
"tools.threads"
"tools.vocabs"
"tools.vocabs.monitor"
"vocabs.hierarchy"
"vocabs.refresh"
"vocabs.refresh.monitor"
"editors"
} [ require ] each

12
basis/cocoa/cocoa.factor
View File

@ -1,4 +1,4 @@
! Copyright (C) 2006 Slava Pestov
! Copyright (C) 2006, 2009 Slava Pestov
! See http://factorcode.org/license.txt for BSD license.
USING: compiler io kernel cocoa.runtime cocoa.subclassing
cocoa.messages cocoa.types sequences words vocabs parser
@ -27,22 +27,16 @@ SYMBOL: frameworks
frameworks [ V{ } clone ] initialize
[ frameworks get [ load-framework ] each ] "cocoa.messages" add-init-hook
[ frameworks get [ load-framework ] each ] "cocoa" add-init-hook
SYNTAX: FRAMEWORK: scan [ load-framework ] [ frameworks get push ] bi ;
SYNTAX: IMPORT: scan [ ] import-objc-class ;
"Compiling Objective C bridge..." print
"Importing Cocoa classes..." print
"cocoa.classes" create-vocab drop
{
"cocoa" "cocoa.runtime" "cocoa.messages" "cocoa.subclassing"
} [ words ] map concat compile
"Importing Cocoa classes..." print
[
{
"NSApplication"

11
basis/cocoa/views/views-docs.factor
View File

@ -1,13 +1,9 @@
USING: help.syntax help.markup ;
USING: help.syntax help.markup ui.pixel-formats ;
IN: cocoa.views
HELP: <PixelFormat>
{ $values { "attributes" "a sequence of attributes" } { "pixelfmt" "an " { $snippet "NSOpenGLPixelFormat" } } }
{ $description "Creates an " { $snippet "NSOpenGLPixelFormat" } " with some reasonable defaults." } ;
HELP: <GLView>
{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "view" "a new " { $snippet "NSOpenGLView" } } }
{ $description "Creates a new instance of the specified class, giving it a default pixel format and the given size." } ;
{ $values { "class" "an subclass of " { $snippet "NSOpenGLView" } } { "dim" "a pair of real numbers" } { "pixel-format" pixel-format } { "view" "a new " { $snippet "NSOpenGLView" } } }
{ $description "Creates a new instance of the specified class, giving it the specified pixel format and size." } ;
HELP: view-dim
{ $values { "view" "an " { $snippet "NSView" } } { "dim" "a pair of real numbers" } }
@ -18,7 +14,6 @@ HELP: mouse-location
{ $description "Outputs the current mouse location." } ;
ARTICLE: "cocoa-view-utils" "Cocoa view utilities"
{ $subsection <PixelFormat> }
{ $subsection <GLView> }
{ $subsection view-dim }
{ $subsection mouse-location } ;

37
basis/cocoa/views/views.factor
View File

@ -42,39 +42,10 @@ CONSTANT: NSOpenGLPFAAllowOfflineRenderers 96
CONSTANT: NSOpenGLPFAVirtualScreenCount 128
CONSTANT: NSOpenGLCPSwapInterval 222
<PRIVATE
SYMBOL: software-renderer?
SYMBOL: multisample?
PRIVATE>
: with-software-renderer ( quot -- )
[ t software-renderer? ] dip with-variable ; inline
: with-multisample ( quot -- )
[ t multisample? ] dip with-variable ; inline
: <PixelFormat> ( attributes -- pixelfmt )
NSOpenGLPixelFormat -> alloc swap [
%
NSOpenGLPFADepthSize , 16 ,
software-renderer? get [
NSOpenGLPFARendererID , kCGLRendererGenericFloatID ,
] when
multisample? get [
NSOpenGLPFASupersample ,
NSOpenGLPFASampleBuffers , 1 ,
NSOpenGLPFASamples , 8 ,
] when
0 ,
] int-array{ } make
-> initWithAttributes:
-> autorelease ;
: <GLView> ( class dim -- view )
[ -> alloc 0 0 ] dip first2 <CGRect>
NSOpenGLPFAWindow NSOpenGLPFADoubleBuffer 2array <PixelFormat>
: <GLView> ( class dim pixel-format -- view )
[ -> alloc ]
[ [ 0 0 ] dip first2 <CGRect> ]
[ handle>> ] tri*
-> initWithFrame:pixelFormat:
dup 1 -> setPostsBoundsChangedNotifications:
dup 1 -> setPostsFrameChangedNotifications: ;

6
basis/command-line/command-line.factor
View File

@ -1,14 +1,14 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: init continuations hashtables io io.encodings.utf8
io.files io.pathnames kernel kernel.private namespaces parser
sequences strings system splitting vocabs.loader ;
sequences strings system splitting vocabs.loader alien.strings ;
IN: command-line
SYMBOL: script
SYMBOL: command-line
: (command-line) ( -- args ) 10 getenv sift ;
: (command-line) ( -- args ) 10 getenv sift [ alien>native-string ] map ;
: rc-path ( name -- path )
os windows? [ "." prepend ] unless

2
basis/compiler/codegen/codegen.factor
View File

@ -3,7 +3,7 @@
USING: namespaces make math math.order math.parser sequences accessors
kernel kernel.private layouts assocs words summary arrays
combinators classes.algebra alien alien.c-types alien.structs
alien.strings alien.arrays alien.complex sets libc alien.libraries
alien.strings alien.arrays alien.complex alien.libraries sets libc
continuations.private fry cpu.architecture
source-files.errors
compiler.errors

17
basis/compiler/compiler.factor
View File

@ -112,19 +112,18 @@ M: predicate-engine-word no-compile? "owner-generic" word-prop no-compile? ;
} cond ;
: optimize? ( word -- ? )
{
[ predicate-engine-word? ]
[ contains-breakpoints? ]
[ single-generic? ]
} 1|| not ;
{ [ predicate-engine-word? ] [ single-generic? ] } 1|| not ;
: contains-breakpoints? ( -- ? )
dependencies get keys [ "break?" word-prop ] any? ;
: frontend ( word -- nodes )
#! If the word contains breakpoints, don't optimize it, since
#! the walker does not support this.
dup optimize?
[ [ build-tree ] [ deoptimize ] recover optimize-tree ]
[ dup def>> deoptimize-with ]
if ;
dup optimize? [
[ [ build-tree ] [ deoptimize ] recover optimize-tree ] keep
contains-breakpoints? [ nip dup def>> deoptimize-with ] [ drop ] if
] [ dup def>> deoptimize-with ] if ;
: compile-dependency ( word -- )
#! If a word calls an unoptimized word, try to compile the callee.

4
basis/compiler/tests/simple.factor
View File

@ -60,8 +60,8 @@ IN: compiler.tests.simple
! Make sure error reporting works
[ [ dup ] compile-call ] must-fail
[ [ drop ] compile-call ] must-fail
! [ [ dup ] compile-call ] must-fail
! [ [ drop ] compile-call ] must-fail
! Regression

2
basis/compiler/tree/builder/builder.factor
View File

@ -65,5 +65,3 @@ PRIVATE>
] [ dup inference-error? [ drop f ] [ rethrow ] if ] recover
] with-variable ;
: contains-breakpoints? ( word -- ? )
def>> [ word? ] filter [ "break?" word-prop ] any? ;

6
basis/compiler/tree/propagation/inlining/inlining.factor
View File

@ -157,11 +157,7 @@ DEFER: (flat-length)
] sum-outputs ;
: should-inline? ( #call word -- ? )
{
{ [ dup contains-breakpoints? ] [ 2drop f ] }
{ [ dup "inline" word-prop ] [ 2drop t ] }
[ inlining-rank 5 >= ]
} cond ;
dup inline? [ 2drop t ] [ inlining-rank 5 >= ] if ;
SYMBOL: history

24
basis/debugger/debugger.factor
View File

@ -1,14 +1,13 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: slots arrays definitions generic hashtables summary io
kernel math namespaces make prettyprint prettyprint.config
sequences assocs sequences.private strings io.styles
io.pathnames vectors words system splitting math.parser
classes.mixin classes.tuple continuations continuations.private
combinators generic.math classes.builtin classes compiler.units
generic.standard generic.single vocabs init kernel.private io.encodings
accessors math.order destructors source-files parser
classes.tuple.parser effects.parser lexer
USING: slots arrays definitions generic hashtables summary io kernel
math namespaces make prettyprint prettyprint.config sequences assocs
sequences.private strings io.styles io.pathnames vectors words system
splitting math.parser classes.mixin classes.tuple continuations
continuations.private combinators generic.math classes.builtin classes
compiler.units generic.standard generic.single vocabs init
kernel.private io.encodings accessors math.order destructors
source-files parser classes.tuple.parser effects.parser lexer
generic.parser strings.parser vocabs.loader vocabs.parser see
source-files.errors ;
IN: debugger
@ -17,6 +16,7 @@ GENERIC: error. ( error -- )
GENERIC: error-help ( error -- topic )
M: object error. . ;
M: object error-help drop f ;
M: tuple error-help class ;
@ -77,7 +77,7 @@ M: string error. print ;
"Object did not survive image save/load: " write third . ;
: io-error. ( error -- )
"I/O error: " write third print ;
"I/O error #" write third . ;
: type-check-error. ( obj -- )
"Type check error" print
@ -98,9 +98,7 @@ HOOK: signal-error. os ( obj -- )
"Cannot convert to C string: " write third . ;
: ffi-error. ( obj -- )
"FFI: " write
dup third [ write ": " write ] when*
fourth print ;
"FFI error" print drop ;
: heap-scan-error. ( obj -- )
"Cannot do next-object outside begin/end-scan" print drop ;

2
basis/delegate/delegate-docs.factor
View File

@ -24,7 +24,7 @@ HELP: CONSULT:
HELP: SLOT-PROTOCOL:
{ $syntax "SLOT-PROTOCOL: protocol-name slots... ;" }
{ $description "Defines a protocol consisting of reader and writer words for the listen slot names." } ;
{ $description "Defines a protocol consisting of reader and writer words for the listed slot names." } ;
{ define-protocol POSTPONE: PROTOCOL: } related-words

10
basis/editors/editors.factor
View File

@ -1,10 +1,10 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: parser lexer kernel namespaces sequences definitions io.files
io.backend io.pathnames io summary continuations tools.crossref
tools.vocabs prettyprint source-files source-files.errors assocs
vocabs vocabs.loader splitting accessors debugger prettyprint
help.topics ;
USING: parser lexer kernel namespaces sequences definitions
io.files io.backend io.pathnames io summary continuations
tools.crossref vocabs.hierarchy prettyprint source-files
source-files.errors assocs vocabs vocabs.loader splitting
accessors debugger prettyprint help.topics ;
IN: editors
TUPLE: no-edit-hook ;

20
basis/formatting/formatting.factor
View File

@ -4,7 +4,7 @@
USING: accessors arrays ascii assocs calendar combinators fry kernel
generalizations io io.encodings.ascii io.files io.streams.string
macros math math.functions math.parser peg.ebnf quotations
sequences splitting strings unicode.case vectors ;
sequences splitting strings unicode.case vectors combinators.smart ;
IN: formatting
@ -113,7 +113,6 @@ MACRO: printf ( format-string -- )
: sprintf ( format-string -- result )
[ printf ] with-string-writer ; inline
<PRIVATE
: pad-00 ( n -- string ) number>string 2 CHAR: 0 pad-head ; inline
@ -129,12 +128,15 @@ MACRO: printf ( format-string -- )
[ pad-00 ] map "/" join ; inline
: >datetime ( timestamp -- string )
{ [ day-of-week day-abbreviation3 ]
[ month>> month-abbreviation ]
[ day>> pad-00 ]
[ >time ]
[ year>> number>string ]
} cleave 5 narray " " join ; inline
[
{
[ day-of-week day-abbreviation3 ]
[ month>> month-abbreviation ]
[ day>> pad-00 ]
[ >time ]
[ year>> number>string ]
} cleave
] output>array " " join ; inline
: (week-of-year) ( timestamp day -- n )
[ dup clone 1 >>month 1 >>day day-of-week dup ] dip > [ 7 swap - ] when
@ -187,5 +189,3 @@ PRIVATE>
MACRO: strftime ( format-string -- )
parse-strftime [ length ] keep [ ] join
'[ _ <vector> @ reverse concat nip ] ;

26
basis/functors/functors-tests.factor
View File

@ -81,7 +81,26 @@ SYMBOL: W
[ blorgh ] [ blorgh ] unit-test
GENERIC: some-generic ( a -- b )
<<
FUNCTOR: generic-test ( W -- )
W DEFINES ${W}
WHERE
GENERIC: W ( a -- b )
M: object W ;
M: integer W 1 + ;
;FUNCTOR
"snurv" generic-test
>>
[ 2 ] [ 1 snurv ] unit-test
[ 3.0 ] [ 3.0 snurv ] unit-test
! Does replacing an ordinary word with a functor-generated one work?
[ [ ] ] [
@ -89,6 +108,7 @@ GENERIC: some-generic ( a -- b )
TUPLE: some-tuple ;
: some-word ( -- ) ;
GENERIC: some-generic ( a -- b )
M: some-tuple some-generic ;
SYMBOL: some-symbol
"> <string-reader> "functors-test" parse-stream
@ -97,6 +117,7 @@ GENERIC: some-generic ( a -- b )
: test-redefinition ( -- )
[ t ] [ "some-word" "functors.tests" lookup >boolean ] unit-test
[ t ] [ "some-tuple" "functors.tests" lookup >boolean ] unit-test
[ t ] [ "some-generic" "functors.tests" lookup >boolean ] unit-test
[ t ] [
"some-tuple" "functors.tests" lookup
"some-generic" "functors.tests" lookup method >boolean
@ -109,13 +130,14 @@ FUNCTOR: redefine-test ( W -- )
W-word DEFINES ${W}-word
W-tuple DEFINES-CLASS ${W}-tuple
W-generic IS ${W}-generic
W-generic DEFINES ${W}-generic
W-symbol DEFINES ${W}-symbol
WHERE
TUPLE: W-tuple ;
: W-word ( -- ) ;
GENERIC: W-generic ( a -- b )
M: W-tuple W-generic ;
SYMBOL: W-symbol

20
basis/functors/functors.factor
View File

@ -1,11 +1,11 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel quotations classes.tuple make combinators generic
words interpolate namespaces sequences io.streams.string fry
classes.mixin effects lexer parser classes.tuple.parser
effects.parser locals.types locals.parser generic.parser
locals.rewrite.closures vocabs.parser classes.parser
arrays accessors words.symbol ;
USING: accessors arrays classes.mixin classes.parser
classes.tuple classes.tuple.parser combinators effects
effects.parser fry generic generic.parser generic.standard
interpolate io.streams.string kernel lexer locals.parser
locals.rewrite.closures locals.types make namespaces parser
quotations sequences vocabs.parser words words.symbol ;
IN: functors
! This is a hack
@ -18,6 +18,8 @@ IN: functors
: define-declared* ( word def effect -- ) pick set-word define-declared ;
: define-simple-generic* ( word effect -- ) over set-word define-simple-generic ;
TUPLE: fake-call-next-method ;
TUPLE: fake-quotation seq ;
@ -104,6 +106,11 @@ SYNTAX: `INSTANCE:
scan-param parsed
\ add-mixin-instance parsed ;
SYNTAX: `GENERIC:
scan-param parsed
complete-effect parsed
\ define-simple-generic* parsed ;
SYNTAX: `inline [ word make-inline ] over push-all ;
SYNTAX: `call-next-method T{ fake-call-next-method } parsed ;
@ -130,6 +137,7 @@ DEFER: ;FUNCTOR delimiter
{ "M:" POSTPONE: `M: }
{ "C:" POSTPONE: `C: }
{ ":" POSTPONE: `: }
{ "GENERIC:" POSTPONE: `GENERIC: }
{ "INSTANCE:" POSTPONE: `INSTANCE: }
{ "SYNTAX:" POSTPONE: `SYNTAX: }
{ "SYMBOL:" POSTPONE: `SYMBOL: }

4
basis/help/apropos/apropos.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2008 Slava Pestov.
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays assocs fry help.markup help.topics io
kernel make math math.parser namespaces sequences sorting
summary tools.completion tools.vocabs help.vocabs
summary tools.completion vocabs.hierarchy help.vocabs
vocabs words unicode.case help ;
IN: help.apropos

3
basis/help/handbook/handbook.factor
View File

@ -281,7 +281,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools"
{ $heading "Workflow" }
{ $subsection "listener" }
{ $subsection "editor" }
{ $subsection "tools.vocabs" }
{ $subsection "vocabs.refresh" }
{ $subsection "tools.test" }
{ $subsection "help" }
{ $heading "Debugging" }
@ -292,6 +292,7 @@ ARTICLE: "handbook-tools-reference" "Developer tools"
{ $heading "Browsing" }
{ $subsection "see" }
{ $subsection "tools.crossref" }
{ $subsection "vocabs.hierarchy" }
{ $heading "Performance" }
{ $subsection "timing" }
{ $subsection "profiling" }

2
basis/help/html/html.factor
View File

@ -3,7 +3,7 @@
USING: io.encodings.utf8 io.encodings.ascii io.encodings.binary
io.files io.files.temp io.directories html.streams help kernel
assocs sequences make words accessors arrays help.topics vocabs
tools.vocabs help.vocabs namespaces prettyprint io
vocabs.hierarchy help.vocabs namespaces prettyprint io
vocabs.loader serialize fry memoize ascii unicode.case math.order
sorting debugger html xml.syntax xml.writer math.parser ;
IN: help.html

4
basis/help/lint/lint.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: assocs continuations fry help help.lint.checks
help.topics io kernel namespaces parser sequences
source-files.errors tools.vocabs vocabs words classes
source-files.errors vocabs.hierarchy vocabs words classes
locals tools.errors ;
FROM: help.lint.checks => all-vocabs ;
IN: help.lint
@ -87,7 +87,7 @@ PRIVATE>
: help-lint-all ( -- ) "" help-lint ;
: :lint-failures ( -- ) lint-failures get errors. ;
: :lint-failures ( -- ) lint-failures get values errors. ;
: unlinked-words ( words -- seq )
all-word-help [ article-parent not ] filter ;

2
basis/help/tutorial/tutorial.factor
View File

@ -1,6 +1,6 @@
USING: help.markup help.syntax ui.commands ui.operations
editors vocabs.loader kernel sequences prettyprint tools.test
tools.vocabs strings unicode.categories unicode.case
vocabs.refresh strings unicode.categories unicode.case
ui.tools.browser ui.tools.common ;
IN: help.tutorial

3
basis/help/vocabs/vocabs.factor
View File

@ -6,7 +6,8 @@ classes.singleton classes.tuple classes.union combinators
definitions effects fry generic help help.markup help.stylesheet
help.topics io io.files io.pathnames io.styles kernel macros
make namespaces prettyprint sequences sets sorting summary
tools.vocabs vocabs vocabs.loader words words.symbol definitions.icons ;
vocabs vocabs.files vocabs.hierarchy vocabs.loader
vocabs.metadata words words.symbol definitions.icons ;
IN: help.vocabs
: about ( vocab -- )

2
basis/http/server/server-docs.factor
View File

@ -1,4 +1,4 @@
USING: help.markup help.syntax io.streams.string quotations strings urls http tools.vocabs math io.servers.connection ;
USING: help.markup help.syntax io.streams.string quotations strings urls http vocabs.refresh math io.servers.connection ;
IN: http.server
HELP: trivial-responder

4
basis/http/server/server.factor
View File

@ -1,8 +1,8 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel accessors sequences arrays namespaces splitting
vocabs.loader destructors assocs debugger continuations
combinators tools.vocabs tools.time math math.parser present
combinators vocabs.refresh tools.time math math.parser present
io vectors
io.sockets
io.sockets.secure

11
basis/inverse/inverse-tests.factor
View File

@ -1,5 +1,7 @@
! Copyright (C) 2007, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: inverse tools.test arrays math kernel sequences
math.functions math.constants continuations ;
math.functions math.constants continuations combinators.smart ;
IN: inverse-tests
[ 2 ] [ { 3 2 } [ 3 swap 2array ] undo ] unit-test
@ -69,7 +71,7 @@ C: <nil> nil
[ t ] [ pi [ pi ] matches? ] unit-test
[ 0.0 ] [ 0.0 pi + [ pi + ] undo ] unit-test
[ ] [ 3 [ _ ] undo ] unit-test
[ ] [ 3 [ __ ] undo ] unit-test
[ 2.0 ] [ 2 3 ^ [ 3 ^ ] undo ] unit-test
[ 3.0 ] [ 2 3 ^ [ 2 swap ^ ] undo ] unit-test
@ -88,4 +90,7 @@ TUPLE: funny-tuple ;
: <funny-tuple> ( -- funny-tuple ) \ funny-tuple boa ;
: funny-tuple ( -- ) "OOPS" throw ;
[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
[ ] [ [ <funny-tuple> ] [undo] drop ] unit-test
[ 0 ] [ { 1 2 } [ [ 1+ 2 ] { } output>sequence ] undo ] unit-test
[ { 0 1 } ] [ 1 2 [ [ [ 1+ ] bi@ ] input<sequence ] undo ] unit-test

59
basis/inverse/inverse.factor
View File

@ -1,12 +1,12 @@
! Copyright (C) 2007, 2008 Daniel Ehrenberg.
! Copyright (C) 2007, 2009 Daniel Ehrenberg.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel words summary slots quotations
sequences assocs math arrays stack-checker effects generalizations
continuations debugger classes.tuple namespaces make vectors
bit-arrays byte-arrays strings sbufs math.functions macros
sequences.private combinators mirrors splitting
combinators.short-circuit fry words.symbol generalizations ;
RENAME: _ fry => __
sequences.private combinators mirrors splitting combinators.smart
combinators.short-circuit fry words.symbol generalizations
classes ;
IN: inverse
ERROR: fail ;
@ -14,7 +14,7 @@ M: fail summary drop "Matching failed" ;
: assure ( ? -- ) [ fail ] unless ; inline
: =/fail ( obj1 obj2 -- ) = assure ;
: =/fail ( obj1 obj2 -- ) = assure ; inline
! Inverse of a quotation
@ -143,14 +143,19 @@ MACRO: undo ( quot -- ) [undo] ;
\ pick [ [ pick ] dip =/fail ] define-inverse
\ tuck [ swapd [ =/fail ] keep ] define-inverse
\ bi@ 1 [ [undo] '[ _ bi@ ] ] define-pop-inverse
\ tri@ 1 [ [undo] '[ _ tri@ ] ] define-pop-inverse
\ bi* 2 [ [ [undo] ] bi@ '[ _ _ bi* ] ] define-pop-inverse
\ tri* 3 [ [ [undo] ] tri@ '[ _ _ _ tri* ] ] define-pop-inverse
\ not define-involution
\ >boolean [ { t f } memq? assure ] define-inverse
\ >boolean [ dup { t f } memq? assure ] define-inverse
\ tuple>array \ >tuple define-dual
\ reverse define-involution
\ undo 1 [ [ call ] curry ] define-pop-inverse
\ map 1 [ [undo] [ over sequence? assure map ] curry ] define-pop-inverse
\ undo 1 [ ] define-pop-inverse
\ map 1 [ [undo] '[ dup sequence? assure _ map ] ] define-pop-inverse
\ exp \ log define-dual
\ sq \ sqrt define-dual
@ -173,16 +178,13 @@ ERROR: missing-literal ;
2curry
] define-pop-inverse
DEFER: _
\ _ [ drop ] define-inverse
DEFER: __
\ __ [ drop ] define-inverse
: both ( object object -- object )
dupd assert= ;
\ both [ dup ] define-inverse
: assure-length ( seq length -- seq )
over length =/fail ;
{
{ >array array? }
{ >vector vector? }
@ -194,14 +196,23 @@ DEFER: _
{ >string string? }
{ >sbuf sbuf? }
{ >quotation quotation? }
} [ \ dup swap \ assure 3array >quotation define-inverse ] assoc-each
} [ '[ dup _ execute assure ] define-inverse ] assoc-each
! These actually work on all seqs--should they?
\ 1array [ 1 assure-length first ] define-inverse
\ 2array [ 2 assure-length first2 ] define-inverse
\ 3array [ 3 assure-length first3 ] define-inverse
\ 4array [ 4 assure-length first4 ] define-inverse
\ narray 1 [ [ firstn ] curry ] define-pop-inverse
: assure-length ( seq length -- )
swap length =/fail ; inline
: assure-array ( array -- array )
dup array? assure ; inline
: undo-narray ( array n -- ... )
[ assure-array ] dip
[ assure-length ] [ firstn ] 2bi ; inline
\ 1array [ 1 undo-narray ] define-inverse
\ 2array [ 2 undo-narray ] define-inverse
\ 3array [ 3 undo-narray ] define-inverse
\ 4array [ 4 undo-narray ] define-inverse
\ narray 1 [ '[ _ undo-narray ] ] define-pop-inverse
\ first [ 1array ] define-inverse
\ first2 [ 2array ] define-inverse
@ -214,6 +225,12 @@ DEFER: _
\ append 1 [ [ ?tail assure ] curry ] define-pop-inverse
\ prepend 1 [ [ ?head assure ] curry ] define-pop-inverse
: assure-same-class ( obj1 obj2 -- )
[ class ] bi@ = assure ; inline
\ output>sequence 2 [ [undo] '[ dup _ assure-same-class _ input<sequence ] ] define-pop-inverse
\ input<sequence 1 [ [undo] '[ _ { } output>sequence ] ] define-pop-inverse
! Constructor inverse
: deconstruct-pred ( class -- quot )
"predicate" word-prop [ dupd call assure ] curry ;
@ -245,7 +262,7 @@ DEFER: _
] recover ; inline
: true-out ( quot effect -- quot' )
out>> '[ @ __ ndrop t ] ;
out>> '[ @ _ ndrop t ] ;
: false-recover ( effect -- quot )
in>> [ ndrop f ] curry [ recover-fail ] curry ;

5
basis/io/encodings/iana/iana.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: kernel strings values io.files assocs
splitting sequences io namespaces sets
io.encodings.ascii io.encodings.utf8 ;
io.encodings.ascii io.encodings.utf8 io.encodings.utf16 ;
IN: io.encodings.iana
<PRIVATE
@ -55,3 +55,6 @@ e>n-table [ initial-e>n ] initialize
] [ swap e>n-table get-global set-at ] 2bi ;
ascii "ANSI_X3.4-1968" register-encoding
utf16be "UTF-16BE" register-encoding
utf16le "UTF-16LE" register-encoding
utf16 "UTF-16" register-encoding

2
basis/json/reader/reader.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2008 Peter Burns.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel peg peg.ebnf math.parser math.private strings math
USING: kernel peg peg.ebnf math.parser math.parser.private strings math
math.functions sequences arrays vectors hashtables assocs
prettyprint json ;
IN: json.reader

0
extra/literals/authors.txt → basis/literals/authors.txt
View File

0
extra/literals/literals-docs.factor → basis/literals/literals-docs.factor
View File

6
extra/literals/literals-tests.factor → basis/literals/literals-tests.factor
View File

@ -19,3 +19,9 @@ IN: literals.tests
[ { 0.5 2.0 } ] [ { $[ 1.0 2.0 / ] 2.0 } ] unit-test
[ { 1.0 { 0.5 1.5 } 4.0 } ] [ { 1.0 { $[ 1.0 2.0 / ] 1.5 } $[ 2.0 2.0 * ] } ] unit-test
<<
CONSTANT: constant-a 3
>>
[ { 3 10 "ftw" } ] [ ${ constant-a 10 "ftw" } ] unit-test

4
extra/literals/literals.factor → basis/literals/literals.factor
View File

@ -1,6 +1,8 @@
! (c) Joe Groff, see license for details
USING: accessors continuations kernel parser words quotations vectors ;
USING: accessors continuations kernel parser words quotations
combinators.smart vectors sequences ;
IN: literals
SYNTAX: $ scan-word [ def>> call ] curry with-datastack >vector ;
SYNTAX: $[ parse-quotation with-datastack >vector ;
SYNTAX: ${ \ } [ [ ?execute ] { } map-as ] parse-literal ;

0
extra/literals/summary.txt → basis/literals/summary.txt
View File

0
extra/literals/tags.txt → basis/literals/tags.txt
View File

28
basis/math/rectangles/rectangles-tests.factor
View File

@ -1,42 +1,42 @@
USING: tools.test math.rectangles ;
IN: math.rectangles.tests
[ T{ rect f { 10 10 } { 20 20 } } ]
[ RECT: { 10 10 } { 20 20 } ]
[
T{ rect f { 10 10 } { 50 50 } }
T{ rect f { -10 -10 } { 40 40 } }
RECT: { 10 10 } { 50 50 }
RECT: { -10 -10 } { 40 40 }
rect-intersect
] unit-test
[ T{ rect f { 200 200 } { 0 0 } } ]
[ RECT: { 200 200 } { 0 0 } ]
[
T{ rect f { 100 100 } { 50 50 } }
T{ rect f { 200 200 } { 40 40 } }
RECT: { 100 100 } { 50 50 }
RECT: { 200 200 } { 40 40 }
rect-intersect
] unit-test
[ f ] [
T{ rect f { 100 100 } { 50 50 } }
T{ rect f { 200 200 } { 40 40 } }
RECT: { 100 100 } { 50 50 }
RECT: { 200 200 } { 40 40 }
contains-rect?
] unit-test
[ t ] [
T{ rect f { 100 100 } { 50 50 } }
T{ rect f { 120 120 } { 40 40 } }
RECT: { 100 100 } { 50 50 }
RECT: { 120 120 } { 40 40 }
contains-rect?
] unit-test
[ f ] [
T{ rect f { 1000 100 } { 50 50 } }
T{ rect f { 120 120 } { 40 40 } }
RECT: { 1000 100 } { 50 50 }
RECT: { 120 120 } { 40 40 }
contains-rect?
] unit-test
[ T{ rect f { 10 20 } { 20 20 } } ] [
[ RECT: { 10 20 } { 20 20 } ] [
{
{ 20 20 }
{ 10 40 }
{ 30 30 }
} rect-containing
] unit-test
] unit-test

10
basis/math/rectangles/rectangles.factor
View File

@ -1,12 +1,18 @@
! Copyright (C) 2008, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel arrays sequences math math.vectors accessors ;
USING: kernel arrays sequences math math.vectors accessors
parser prettyprint.custom prettyprint.backend ;
IN: math.rectangles
TUPLE: rect { loc initial: { 0 0 } } { dim initial: { 0 0 } } ;
: <rect> ( loc dim -- rect ) rect boa ; inline
SYNTAX: RECT: scan-object scan-object <rect> parsed ;
M: rect pprint*
\ RECT: [ [ loc>> ] [ dim>> ] bi [ pprint* ] bi@ ] pprint-prefix ;
: <zero-rect> ( -- rect ) rect new ; inline
: point>rect ( loc -- rect ) { 0 0 } <rect> ; inline
@ -55,4 +61,4 @@ M: rect contains-point?
: set-rect-bounds ( rect1 rect -- )
[ [ loc>> ] dip (>>loc) ]
[ [ dim>> ] dip (>>dim) ]
2bi ; inline
2bi ; inline

7
basis/opengl/gl/windows/windows.factor
View File

@ -1,6 +1,11 @@
USING: kernel windows.opengl32 ;
USING: alien.syntax kernel windows.types ;
IN: opengl.gl.windows
LIBRARY: gl
FUNCTION: HGLRC wglGetCurrentContext ( ) ;
FUNCTION: void* wglGetProcAddress ( char* name ) ;
: gl-function-context ( -- context ) wglGetCurrentContext ; inline
: gl-function-address ( name -- address ) wglGetProcAddress ; inline
: gl-function-calling-convention ( -- str ) "stdcall" ; inline

9
basis/opengl/shaders/shaders.factor
View File

@ -92,11 +92,16 @@ PREDICATE: fragment-shader < gl-shader (fragment-shader?) ;
: gl-program-shaders-length ( program -- shaders-length )
GL_ATTACHED_SHADERS gl-program-get-int ; inline
! On some macosx-x86-64 graphics drivers, glGetAttachedShaders tries to treat the
! shaders parameter as a ulonglong array rather than a GLuint array as documented.
! We hack around this by allocating a buffer twice the size and sifting out the zero
! values
: gl-program-shaders ( program -- shaders )
dup gl-program-shaders-length
dup gl-program-shaders-length 2 *
0 <int>
over <uint-array>
[ glGetAttachedShaders ] keep ;
[ glGetAttachedShaders ] keep [ zero? not ] filter ;
: delete-gl-program-only ( program -- )
glDeleteProgram ; inline

2
basis/present/present-tests.factor
View File

@ -1,5 +1,5 @@
IN: present.tests
USING: tools.test present math vocabs tools.vocabs sequences kernel ;
USING: tools.test vocabs.hierarchy present math vocabs sequences kernel ;
[ "3" ] [ 3 present ] unit-test
[ "Hi" ] [ "Hi" present ] unit-test

21
basis/prettyprint/backend/backend.factor
View File

@ -1,11 +1,10 @@
! Copyright (C) 2003, 2008 Slava Pestov.
! Copyright (C) 2003, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors arrays byte-arrays generic hashtables io assocs
kernel math namespaces make sequences strings sbufs vectors
USING: accessors arrays byte-arrays byte-vectors generic hashtables io
assocs kernel math namespaces make sequences strings sbufs vectors
words prettyprint.config prettyprint.custom prettyprint.sections
quotations io io.pathnames io.styles math.parser effects
classes.tuple math.order classes.tuple.private classes
combinators colors ;
quotations io io.pathnames io.styles math.parser effects classes.tuple
math.order classes.tuple.private classes combinators colors ;
IN: prettyprint.backend
M: effect pprint* effect>string "(" ")" surround text ;
@ -135,8 +134,8 @@ M: pathname pprint*
[ text ] [ f <inset pprint* block> ] bi*
\ } pprint-word block> ;
M: tuple pprint*
boa-tuples? get [ call-next-method ] [
: pprint-tuple ( tuple -- )
boa-tuples? get [ pprint-object ] [
[
<flow
\ T{ pprint-word
@ -149,6 +148,9 @@ M: tuple pprint*
] check-recursion
] if ;
M: tuple pprint*
pprint-tuple ;
: do-length-limit ( seq -- trimmed n/f )
length-limit get dup [
over length over [-]
@ -165,6 +167,7 @@ M: curry pprint-delims drop \ [ \ ] ;
M: compose pprint-delims drop \ [ \ ] ;
M: array pprint-delims drop \ { \ } ;
M: byte-array pprint-delims drop \ B{ \ } ;
M: byte-vector pprint-delims drop \ BV{ \ } ;
M: vector pprint-delims drop \ V{ \ } ;
M: hashtable pprint-delims drop \ H{ \ } ;
M: tuple pprint-delims drop \ T{ \ } ;
@ -173,6 +176,7 @@ M: callstack pprint-delims drop \ CS{ \ } ;
M: object >pprint-sequence ;
M: vector >pprint-sequence ;
M: byte-vector >pprint-sequence ;
M: curry >pprint-sequence ;
M: compose >pprint-sequence ;
M: hashtable >pprint-sequence >alist ;
@ -202,6 +206,7 @@ M: object pprint-object ( obj -- )
M: object pprint* pprint-object ;
M: vector pprint* pprint-object ;
M: byte-vector pprint* pprint-object ;
M: hashtable pprint* pprint-object ;
M: curry pprint* pprint-object ;
M: compose pprint* pprint-object ;

2
basis/random/random.factor
View File

@ -54,7 +54,7 @@ PRIVATE>
: randomize ( seq -- seq )
dup length [ dup 1 > ]
[ [ random ] [ 1- ] bi [ pick exchange ] keep ]
[ [ iota random ] [ 1- ] bi [ pick exchange ] keep ]
while drop ;
: delete-random ( seq -- elt )

40
basis/stack-checker/known-words/known-words.factor
View File

@ -1,16 +1,16 @@
! Copyright (C) 2004, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: fry accessors alien alien.accessors arrays byte-arrays
classes sequences.private continuations.private effects generic
hashtables hashtables.private io io.backend io.files
io.files.private io.streams.c kernel kernel.private math
math.private memory namespaces namespaces.private parser
quotations quotations.private sbufs sbufs.private
sequences sequences.private slots.private strings
USING: fry accessors alien alien.accessors arrays byte-arrays classes
sequences.private continuations.private effects generic hashtables
hashtables.private io io.backend io.files io.files.private
io.streams.c kernel kernel.private math math.private
math.parser.private memory memory.private namespaces
namespaces.private parser quotations quotations.private sbufs
sbufs.private sequences sequences.private slots.private strings
strings.private system threads.private classes.tuple
classes.tuple.private vectors vectors.private words definitions
assocs summary compiler.units system.private
combinators combinators.short-circuit locals locals.backend locals.types
classes.tuple.private vectors vectors.private words definitions assocs
summary compiler.units system.private combinators
combinators.short-circuit locals locals.backend locals.types
quotations.private combinators.private stack-checker.values
generic.single generic.single.private
alien.libraries
@ -290,11 +290,11 @@ M: object infer-call*
\ bignum>float { bignum } { float } define-primitive
\ bignum>float make-foldable
\ string>float { string } { float } define-primitive
\ string>float make-foldable
\ (string>float) { byte-array } { float } define-primitive
\ (string>float) make-foldable
\ float>string { float } { string } define-primitive
\ float>string make-foldable
\ (float>string) { float } { byte-array } define-primitive
\ (float>string) make-foldable
\ float>bits { real } { integer } define-primitive
\ float>bits make-foldable
@ -465,9 +465,9 @@ M: object infer-call*
\ gc-stats { } { array } define-primitive
\ save-image { string } { } define-primitive
\ (save-image) { byte-array } { } define-primitive
\ save-image-and-exit { string } { } define-primitive
\ (save-image-and-exit) { byte-array } { } define-primitive
\ data-room { } { integer integer array } define-primitive
\ data-room make-flushable
@ -481,9 +481,9 @@ M: object infer-call*
\ tag { object } { fixnum } define-primitive
\ tag make-foldable
\ dlopen { string } { dll } define-primitive
\ (dlopen) { byte-array } { dll } define-primitive
\ dlsym { string object } { c-ptr } define-primitive
\ (dlsym) { byte-array object } { c-ptr } define-primitive
\ dlclose { dll } { } define-primitive
@ -598,7 +598,7 @@ M: object infer-call*
\ die { } { } define-primitive
\ fopen { string string } { alien } define-primitive
\ (fopen) { byte-array byte-array } { alien } define-primitive
\ fgetc { alien } { object } define-primitive
@ -651,7 +651,7 @@ M: object infer-call*
\ become { array array } { } define-primitive
\ innermost-frame-quot { callstack } { quotation } define-primitive
\ innermost-frame-executing { callstack } { object } define-primitive
\ innermost-frame-scan { callstack } { fixnum } define-primitive

8
basis/tools/completion/completion.factor
View File

@ -1,9 +1,9 @@
! Copyright (C) 2005, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel arrays sequences math namespaces
strings io fry vectors words assocs combinators sorting
unicode.case unicode.categories math.order vocabs
tools.vocabs unicode.data locals ;
USING: accessors kernel arrays sequences math namespaces strings io
fry vectors words assocs combinators sorting unicode.case
unicode.categories math.order vocabs vocabs.hierarchy unicode.data
locals ;
IN: tools.completion
:: (fuzzy) ( accum i full ch -- accum i full ? )

32
basis/tools/continuations/continuations.factor
View File

@ -4,7 +4,7 @@ USING: threads kernel namespaces continuations combinators
sequences math namespaces.private continuations.private
concurrency.messaging quotations kernel.private words
sequences.private assocs models models.arrow arrays accessors
generic generic.single definitions make sbufs tools.crossref ;
generic generic.single definitions make sbufs tools.crossref fry ;
IN: tools.continuations
<PRIVATE
@ -79,21 +79,18 @@ M: object add-breakpoint ;
(step-into-call-next-method)
} [ t "no-compile" set-word-prop ] each >>
: >innermost-frame< ( callstack -- n quot )
[ innermost-frame-scan 1 + ] [ innermost-frame-executing ] bi ;
: (change-frame) ( callstack quot -- callstack' )
[ dup innermost-frame-executing quotation? ] dip '[
clone [ >innermost-frame< @ ] [ set-innermost-frame-quot ] [ ] tri
] when ; inline
: change-frame ( continuation quot -- continuation' )
#! Applies quot to innermost call frame of the
#! continuation.
[ clone ] dip [
[ clone ] dip
[
[
[ innermost-frame-scan 1+ ]
[ innermost-frame-quot ] bi
] dip call
]
[ drop set-innermost-frame-quot ]
[ drop ]
2tri
] curry change-call ; inline
[ clone ] dip '[ _ (change-frame) ] change-call ; inline
PRIVATE>
@ -101,7 +98,7 @@ PRIVATE>
[
2dup length = [ nip [ break ] append ] [
2dup nth \ break = [ nip ] [
swap 1+ cut [ break ] glue
swap 1 + cut [ break ] glue
] if
] if
] change-frame ;
@ -109,7 +106,6 @@ PRIVATE>
: continuation-step-out ( continuation -- continuation' )
[ nip \ break suffix ] change-frame ;
{
{ call [ (step-into-quot) ] }
{ dip [ (step-into-dip) ] }
@ -124,7 +120,7 @@ PRIVATE>
! Never step into these words
: don't-step-into ( word -- )
dup [ execute break ] curry "step-into" set-word-prop ;
dup '[ _ execute break ] "step-into" set-word-prop ;
{
>n ndrop >c c>
@ -151,6 +147,4 @@ PRIVATE>
] change-frame ;
: continuation-current ( continuation -- obj )
call>>
[ innermost-frame-scan 1+ ]
[ innermost-frame-quot ] bi ?nth ;
call>> >innermost-frame< ?nth ;

2
basis/tools/deploy/config/editor/editor.factor
View File

@ -1,7 +1,7 @@
! Copyright (C) 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs io.pathnames kernel parser prettyprint sequences
splitting tools.deploy.config tools.vocabs vocabs.loader ;
splitting tools.deploy.config vocabs.loader vocabs.metadata ;
IN: tools.deploy.config.editor
: deploy-config-path ( vocab -- string )

12
basis/tools/deploy/shaker/shaker.factor
View File

@ -37,7 +37,7 @@ IN: tools.deploy.shaker
] when
strip-dictionary? [
"compiler.units" init-hooks get delete-at
"tools.vocabs" init-hooks get delete-at
"vocabs.cache" init-hooks get delete-at
] when ;
: strip-debugger ( -- )
@ -346,13 +346,6 @@ IN: tools.deploy.shaker
: compress-wrappers ( -- )
[ wrapper? ] [ ] "wrappers" compress ;
: finish-deploy ( final-image -- )
"Finishing up" show
V{ } set-namestack
V{ } set-catchstack
"Saving final image" show
save-image-and-exit ;
SYMBOL: deploy-vocab
: [:c] ( -- word ) ":c" "debugger" lookup ;
@ -437,7 +430,8 @@ SYMBOL: deploy-vocab
"Vocabulary has no MAIN: word." print flush 1 exit
] unless
strip
finish-deploy
"Saving final image" show
save-image-and-exit
] deploy-error-handler
] bind ;

6
basis/tools/test/test.factor
View File

@ -4,9 +4,9 @@ USING: accessors arrays assocs combinators compiler.units
continuations debugger effects fry generalizations io io.files
io.styles kernel lexer locals macros math.parser namespaces
parser prettyprint quotations sequences source-files splitting
stack-checker summary unicode.case vectors vocabs vocabs.loader words
tools.vocabs tools.errors source-files.errors io.streams.string make
compiler.errors ;
stack-checker summary unicode.case vectors vocabs vocabs.loader
vocabs.files words tools.errors source-files.errors
io.streams.string make compiler.errors ;
IN: tools.test
TUPLE: test-failure < source-file-error continuation ;

1
basis/tools/vocabs/summary.txt
View File

@ -1 +0,0 @@
Reloading vocabularies and cross-referencing vocabularies

75
basis/tools/vocabs/vocabs-docs.factor
View File

@ -1,75 +0,0 @@
USING: help.markup help.syntax strings ;
IN: tools.vocabs
ARTICLE: "tools.vocabs" "Vocabulary tools"
"Reloading source files changed on disk:"
{ $subsection refresh }
{ $subsection refresh-all }
"Vocabulary summaries:"
{ $subsection vocab-summary }
{ $subsection set-vocab-summary }
"Vocabulary tags:"
{ $subsection vocab-tags }
{ $subsection set-vocab-tags }
{ $subsection add-vocab-tags }
"Getting and setting vocabulary meta-data:"
{ $subsection vocab-file-contents }
{ $subsection set-vocab-file-contents }
"Global meta-data:"
{ $subsection all-vocabs }
{ $subsection all-vocabs-seq }
{ $subsection all-tags }
{ $subsection all-authors }
"Because loading the above data is expensive, it is cached. The cache is flushed by the " { $vocab-link "tools.vocabs.monitor" } " vocabulary. It can also be flushed manually when file system change monitors are not available:"
{ $subsection reset-cache } ;
ABOUT: "tools.vocabs"
HELP: vocab-files
{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
HELP: vocab-tests
{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;
HELP: source-modified?
{ $values { "path" "a pathname string" } { "?" "a boolean" } }
{ $description "Tests if the source file has been modified since it was last loaded. This compares the file's CRC32 checksum of the file's contents against the previously-recorded value." } ;
HELP: refresh
{ $values { "prefix" string } }
{ $description "Reloads source files and documentation belonging to loaded vocabularies whose names are prefixed by " { $snippet "prefix" } " which have been modified on disk." } ;
HELP: refresh-all
{ $description "Reloads source files and documentation for all loaded vocabularies which have been modified on disk." } ;
{ refresh refresh-all } related-words
HELP: vocab-file-contents
{ $values { "vocab" "a vocabulary specifier" } { "name" string } { "seq" "a sequence of lines, or " { $link f } } }
{ $description "Outputs the contents of the file named " { $snippet "name" } " from the vocabulary's directory, or " { $link f } " if the file does not exist." } ;
HELP: set-vocab-file-contents
{ $values { "seq" "a sequence of lines" } { "vocab" "a vocabulary specifier" } { "name" string } }
{ $description "Stores a sequence of lines to the file named " { $snippet "name" } " from the vocabulary's directory." } ;
HELP: vocab-summary
{ $values { "vocab" "a vocabulary specifier" } { "summary" "a string or " { $link f } } }
{ $description "Outputs a one-line string description of the vocabulary's intended purpose from the " { $snippet "summary.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
HELP: set-vocab-summary
{ $values { "string" "a string or " { $link f } } { "vocab" "a vocabulary specifier" } }
{ $description "Stores a one-line string description of the vocabulary to the " { $snippet "summary.txt" } " file in the vocabulary's directory." } ;
HELP: vocab-tags
{ $values { "vocab" "a vocabulary specifier" } { "tags" "a sequence of strings" } }
{ $description "Outputs a list of short tags classifying the vocabulary from the " { $snippet "tags.txt" } " file in the vocabulary's directory. Outputs " { $link f } " if the file does not exist." } ;
HELP: set-vocab-tags
{ $values { "tags" "a sequence of strings" } { "vocab" "a vocabulary specifier" } }
{ $description "Stores a list of short tags classifying the vocabulary to the " { $snippet "tags.txt" } " file in the vocabulary's directory." } ;
HELP: all-vocabs
{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;

296
basis/tools/vocabs/vocabs.factor
View File

@ -1,296 +0,0 @@
! Copyright (C) 2007, 2008 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: kernel io io.styles io.files io.files.info io.directories
io.pathnames io.encodings.utf8 vocabs.loader vocabs sequences
namespaces make math.parser arrays hashtables assocs memoize
summary sorting splitting combinators source-files debugger
continuations compiler.errors init checksums checksums.crc32
sets accessors generic definitions words ;
IN: tools.vocabs
: vocab-tests-file ( vocab -- path )
dup "-tests.factor" vocab-dir+ vocab-append-path dup
[ dup exists? [ drop f ] unless ] [ drop f ] if ;
: vocab-tests-dir ( vocab -- paths )
dup vocab-dir "tests" append-path vocab-append-path dup [
dup exists? [
dup directory-files [ ".factor" tail? ] filter
[ append-path ] with map
] [ drop f ] if
] [ drop f ] if ;
: vocab-tests ( vocab -- tests )
[
[ vocab-tests-file [ , ] when* ]
[ vocab-tests-dir [ % ] when* ] bi
] { } make ;
: vocab-files ( vocab -- seq )
[
[ vocab-source-path [ , ] when* ]
[ vocab-docs-path [ , ] when* ]
[ vocab-tests % ] tri
] { } make ;
: vocab-heading. ( vocab -- )
nl
"==== " write
[ vocab-name ] [ vocab write-object ] bi ":" print
nl ;
: load-error. ( triple -- )
[ first vocab-heading. ] [ second print-error ] bi ;
: load-failures. ( failures -- )
[ load-error. nl ] each ;
SYMBOL: failures
: require-all ( vocabs -- failures )
[
V{ } clone blacklist set
V{ } clone failures set
[
[ require ]
[ swap vocab-name failures get set-at ]
recover
] each
failures get
] with-scope ;
: source-modified? ( path -- ? )
dup source-files get at [
dup path>>
dup exists? [
utf8 file-lines crc32 checksum-lines
swap checksum>> = not
] [
2drop f
] if
] [
exists?
] ?if ;
SYMBOL: changed-vocabs
: changed-vocab ( vocab -- )
dup vocab changed-vocabs get and
[ dup changed-vocabs get set-at ] [ drop ] if ;
: unchanged-vocab ( vocab -- )
changed-vocabs get delete-at ;
: unchanged-vocabs ( vocabs -- )
[ unchanged-vocab ] each ;
: changed-vocab? ( vocab -- ? )
changed-vocabs get dup [ key? ] [ 2drop t ] if ;
: filter-changed ( vocabs -- vocabs' )
[ changed-vocab? ] filter ;
SYMBOL: modified-sources
SYMBOL: modified-docs
: (to-refresh) ( vocab variable loaded? path -- )
dup [
swap [
pick changed-vocab? [
source-modified? [ get push ] [ 2drop ] if
] [ 3drop ] if
] [ drop get push ] if
] [ 2drop 2drop ] if ;
: to-refresh ( prefix -- modified-sources modified-docs unchanged )
[
V{ } clone modified-sources set
V{ } clone modified-docs set
child-vocabs [
[
[
[ modified-sources ]
[ vocab source-loaded?>> ]
[ vocab-source-path ]
tri (to-refresh)
] [
[ modified-docs ]
[ vocab docs-loaded?>> ]
[ vocab-docs-path ]
tri (to-refresh)
] bi
] each
modified-sources get
modified-docs get
]
[ modified-docs get modified-sources get append diff ] bi
] with-scope ;
: do-refresh ( modified-sources modified-docs unchanged -- )
unchanged-vocabs
[
[ [ vocab f >>source-loaded? drop ] each ]
[ [ vocab f >>docs-loaded? drop ] each ] bi*
]
[
append prune
[ unchanged-vocabs ]
[ require-all load-failures. ] bi
] 2bi ;
: refresh ( prefix -- ) to-refresh do-refresh ;
: refresh-all ( -- ) "" refresh ;
MEMO: vocab-file-contents ( vocab name -- seq )
vocab-append-path dup
[ dup exists? [ utf8 file-lines ] [ drop f ] if ] when ;
: set-vocab-file-contents ( seq vocab name -- )
dupd vocab-append-path [
utf8 set-file-lines
\ vocab-file-contents reset-memoized
] [
"The " swap vocab-name
" vocabulary was not loaded from the file system"
3append throw
] ?if ;
: vocab-summary-path ( vocab -- string )
vocab-dir "summary.txt" append-path ;
: vocab-summary ( vocab -- summary )
dup dup vocab-summary-path vocab-file-contents
[
vocab-name " vocabulary" append
] [
nip first
] if-empty ;
M: vocab summary
[
dup vocab-summary %
" (" %
words>> assoc-size #
" words)" %
] "" make ;
M: vocab-link summary vocab-summary ;
: set-vocab-summary ( string vocab -- )
[ 1array ] dip
dup vocab-summary-path
set-vocab-file-contents ;
: vocab-tags-path ( vocab -- string )
vocab-dir "tags.txt" append-path ;
: vocab-tags ( vocab -- tags )
dup vocab-tags-path vocab-file-contents harvest ;
: set-vocab-tags ( tags vocab -- )
dup vocab-tags-path set-vocab-file-contents ;
: add-vocab-tags ( tags vocab -- )
[ vocab-tags append prune ] keep set-vocab-tags ;
: vocab-authors-path ( vocab -- string )
vocab-dir "authors.txt" append-path ;
: vocab-authors ( vocab -- authors )
dup vocab-authors-path vocab-file-contents harvest ;
: set-vocab-authors ( authors vocab -- )
dup vocab-authors-path set-vocab-file-contents ;
: subdirs ( dir -- dirs )
[
[ link-info directory? ] filter
] with-directory-files natural-sort ;
: (all-child-vocabs) ( root name -- vocabs )
[
vocab-dir append-path dup exists?
[ subdirs ] [ drop { } ] if
] keep [
swap [ "." glue ] with map
] unless-empty ;
: vocab-dir? ( root name -- ? )
over
[ ".factor" vocab-dir+ append-path exists? ]
[ 2drop f ]
if ;
: vocabs-in-dir ( root name -- )
dupd (all-child-vocabs) [
2dup vocab-dir? [ dup >vocab-link , ] when
vocabs-in-dir
] with each ;
: all-vocabs ( -- assoc )
vocab-roots get [
dup [ "" vocabs-in-dir ] { } make
] { } map>assoc ;
MEMO: all-vocabs-seq ( -- seq )
all-vocabs values concat ;
: unportable? ( name -- ? )
vocab-tags "unportable" swap member? ;
: filter-unportable ( seq -- seq' )
[ vocab-name unportable? not ] filter ;
: try-everything ( -- failures )
all-vocabs-seq
filter-unportable
require-all ;
: load-everything ( -- )
try-everything load-failures. ;
: unrooted-child-vocabs ( prefix -- seq )
dup empty? [ CHAR: . suffix ] unless
vocabs
[ find-vocab-root not ] filter
[
vocab-name swap ?head CHAR: . rot member? not and
] with filter
[ vocab ] map ;
: all-child-vocabs ( prefix -- assoc )
vocab-roots get [
dup pick (all-child-vocabs) [ >vocab-link ] map
] { } map>assoc
swap unrooted-child-vocabs f swap 2array suffix ;
: all-child-vocabs-seq ( prefix -- assoc )
vocab-roots get swap [
dupd (all-child-vocabs)
[ vocab-dir? ] with filter
] curry map concat ;
MEMO: all-tags ( -- seq )
all-vocabs-seq [ vocab-tags ] gather natural-sort ;
MEMO: all-authors ( -- seq )
all-vocabs-seq [ vocab-authors ] gather natural-sort ;
: reset-cache ( -- )
root-cache get-global clear-assoc
\ vocab-file-contents reset-memoized
\ all-vocabs-seq reset-memoized
\ all-authors reset-memoized
\ all-tags reset-memoized ;
SINGLETON: cache-observer
M: cache-observer vocabs-changed drop reset-cache ;
[
f changed-vocabs set-global
cache-observer add-vocab-observer
] "tools.vocabs" add-init-hook

18
basis/tools/walker/walker-tests.factor
View File

@ -2,7 +2,7 @@ USING: tools.walker io io.streams.string kernel math
math.private namespaces prettyprint sequences tools.test
continuations math.parser threads arrays tools.walker.debug
generic.single sequences.private kernel.private
tools.continuations accessors words ;
tools.continuations accessors words combinators ;
IN: tools.walker.tests
[ { } ] [
@ -131,4 +131,18 @@ M: method-breakpoint-tuple method-breakpoint-test break drop 1 2 + ;
\ method-breakpoint-test don't-step-into
[ { 3 } ]
[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
[ [ T{ method-breakpoint-tuple } method-breakpoint-test ] test-walker ] unit-test
: case-breakpoint-test ( -- x )
5 { [ break 1 + ] } case ;
\ case-breakpoint-test don't-step-into
[ { 6 } ] [ [ case-breakpoint-test ] test-walker ] unit-test
: call(-breakpoint-test ( -- x )
[ break 1 ] call( -- x ) 2 + ;
\ call(-breakpoint-test don't-step-into
[ { 3 } ] [ [ call(-breakpoint-test ] test-walker ] unit-test

74
basis/ui/backend/cocoa/cocoa.factor
View File

@ -1,14 +1,16 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors math arrays assocs cocoa cocoa.application
command-line kernel memory namespaces cocoa.messages
cocoa.runtime cocoa.subclassing cocoa.pasteboard cocoa.types
cocoa.windows cocoa.classes cocoa.nibs sequences ui ui.private
ui.backend ui.clipboards ui.gadgets ui.gadgets.worlds
ui.backend.cocoa.views core-foundation core-foundation.run-loop
core-graphics.types threads math.rectangles fry libc
generalizations alien.c-types cocoa.views
combinators io.thread locals ;
USING: accessors alien.c-types arrays assocs classes cocoa
cocoa.application cocoa.classes cocoa.messages cocoa.nibs
cocoa.pasteboard cocoa.runtime cocoa.subclassing cocoa.types
cocoa.views cocoa.windows combinators command-line
core-foundation core-foundation.run-loop core-graphics
core-graphics.types destructors fry generalizations io.thread
kernel libc literals locals math math.rectangles memory
namespaces sequences specialized-arrays.int threads ui
ui.backend ui.backend.cocoa.views ui.clipboards ui.gadgets
ui.gadgets.worlds ui.pixel-formats ui.pixel-formats.private
ui.private words.symbol ;
IN: ui.backend.cocoa
TUPLE: handle ;
@ -20,6 +22,42 @@ C: <offscreen-handle> offscreen-handle
SINGLETON: cocoa-ui-backend
PIXEL-FORMAT-ATTRIBUTE-TABLE: NSOpenGLPFA { } H{
{ double-buffered { $ NSOpenGLPFADoubleBuffer } }
{ stereo { $ NSOpenGLPFAStereo } }
{ offscreen { $ NSOpenGLPFAOffScreen } }
{ fullscreen { $ NSOpenGLPFAFullScreen } }
{ windowed { $ NSOpenGLPFAWindow } }
{ accelerated { $ NSOpenGLPFAAccelerated } }
{ software-rendered { $ NSOpenGLPFASingleRenderer $ kCGLRendererGenericFloatID } }
{ backing-store { $ NSOpenGLPFABackingStore } }
{ multisampled { $ NSOpenGLPFAMultisample } }
{ supersampled { $ NSOpenGLPFASupersample } }
{ sample-alpha { $ NSOpenGLPFASampleAlpha } }
{ color-float { $ NSOpenGLPFAColorFloat } }
{ color-bits { $ NSOpenGLPFAColorSize } }
{ alpha-bits { $ NSOpenGLPFAAlphaSize } }
{ accum-bits { $ NSOpenGLPFAAccumSize } }
{ depth-bits { $ NSOpenGLPFADepthSize } }
{ stencil-bits { $ NSOpenGLPFAStencilSize } }
{ aux-buffers { $ NSOpenGLPFAAuxBuffers } }
{ sample-buffers { $ NSOpenGLPFASampleBuffers } }
{ samples { $ NSOpenGLPFASamples } }
}
M: cocoa-ui-backend (make-pixel-format)
nip >NSOpenGLPFA-int-array
NSOpenGLPixelFormat -> alloc swap -> initWithAttributes: ;
M: cocoa-ui-backend (free-pixel-format)
handle>> -> release ;
M: cocoa-ui-backend (pixel-format-attribute)
[ handle>> ] [ >NSOpenGLPFA ] bi*
[ drop f ]
[ first 0 <int> [ swap 0 -> getValues:forAttribute:forVirtualScreen: ] keep *int ]
if-empty ;
TUPLE: pasteboard handle ;
C: <pasteboard> pasteboard
@ -70,7 +108,8 @@ M: cocoa-ui-backend fullscreen* ( world -- ? )
handle>> view>> -> isInFullScreenMode zero? not ;
M:: cocoa-ui-backend (open-window) ( world -- )
world dim>> <FactorView> :> view
world [ [ dim>> ] dip <FactorView> ]
with-world-pixel-format :> view
view world world>NSRect <ViewWindow> :> window
view -> release
world view register-window
@ -97,18 +136,19 @@ M: cocoa-ui-backend raise-window* ( world -- )
] when* ;
: pixel-size ( pixel-format -- size )
0 <int> [ NSOpenGLPFAColorSize 0 -> getValues:forAttribute:forVirtualScreen: ]
keep *int -3 shift ;
color-bits pixel-format-attribute -3 shift ;
: offscreen-buffer ( world pixel-format -- alien w h pitch )
[ dim>> first2 ] [ pixel-size ] bi*
{ [ * * malloc ] [ 2drop ] [ drop nip ] [ nip * ] } 3cleave ;
: gadget-offscreen-context ( world -- context buffer )
NSOpenGLPFAOffScreen 1array <PixelFormat>
[ nip NSOpenGLContext -> alloc swap f -> initWithFormat:shareContext: dup ]
[ offscreen-buffer ] 2bi
4 npick [ -> setOffScreen:width:height:rowbytes: ] dip ;
:: gadget-offscreen-context ( world -- context buffer )
world [
nip :> pf
NSOpenGLContext -> alloc pf handle>> f -> initWithFormat:shareContext:
dup world pf offscreen-buffer
4 npick [ -> setOffScreen:width:height:rowbytes: ] dip
] with-world-pixel-format ;
M: cocoa-ui-backend (open-offscreen-buffer) ( world -- )
dup gadget-offscreen-context <offscreen-handle> >>handle drop ;

3
basis/ui/backend/cocoa/tools/tools.factor
View File

@ -4,7 +4,8 @@ USING: alien.syntax cocoa cocoa.nibs cocoa.application
cocoa.classes cocoa.dialogs cocoa.pasteboard cocoa.subclassing
core-foundation core-foundation.strings help.topics kernel
memory namespaces parser system ui ui.tools.browser
ui.tools.listener ui.backend.cocoa eval locals tools.vocabs ;
ui.tools.listener ui.backend.cocoa eval locals
vocabs.refresh ;
IN: ui.backend.cocoa.tools
: finder-run-files ( alien -- )

6
basis/ui/backend/cocoa/views/views.factor
View File

@ -9,7 +9,7 @@ threads combinators math.rectangles ;
IN: ui.backend.cocoa.views
: send-mouse-moved ( view event -- )
[ mouse-location ] [ drop window ] 2bi move-hand fire-motion ;
[ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ;
: button ( event -- n )
#! Cocoa -> Factor UI button mapping
@ -365,8 +365,8 @@ CLASS: {
-> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
CGLSetParameter drop ;
: <FactorView> ( dim -- view )
FactorView swap <GLView> [ sync-refresh-to-screen ] keep ;
: <FactorView> ( dim pixel-format -- view )
[ FactorView ] 2dip <GLView> [ sync-refresh-to-screen ] keep ;
: save-position ( world window -- )
-> frame CGRect-top-left 2array >>window-loc drop ;

199
basis/ui/backend/windows/windows.factor
View File

@ -10,11 +10,161 @@ windows.messages windows.types windows.offscreen windows.nt
threads libc combinators fry combinators.short-circuit continuations
command-line shuffle opengl ui.render ascii math.bitwise locals
accessors math.rectangles math.order ascii calendar
io.encodings.utf16n windows.errors ;
io.encodings.utf16n windows.errors literals ui.pixel-formats
ui.pixel-formats.private memoize classes ;
IN: ui.backend.windows
SINGLETON: windows-ui-backend
TUPLE: win-base hDC hRC ;
TUPLE: win < win-base hWnd world title ;
TUPLE: win-offscreen < win-base hBitmap bits ;
C: <win> win
C: <win-offscreen> win-offscreen
<PRIVATE
PIXEL-FORMAT-ATTRIBUTE-TABLE: WGL_ARB { $ WGL_SUPPORT_OPENGL_ARB 1 } H{
{ double-buffered { $ WGL_DOUBLE_BUFFER_ARB 1 } }
{ stereo { $ WGL_STEREO_ARB 1 } }
{ offscreen { $ WGL_DRAW_TO_BITMAP_ARB 1 } }
{ fullscreen { $ WGL_DRAW_TO_WINDOW_ARB 1 } }
{ windowed { $ WGL_DRAW_TO_WINDOW_ARB 1 } }
{ accelerated { $ WGL_ACCELERATION_ARB $ WGL_FULL_ACCELERATION_ARB } }
{ software-rendered { $ WGL_ACCELERATION_ARB $ WGL_NO_ACCELERATION_ARB } }
{ backing-store { $ WGL_SWAP_METHOD_ARB $ WGL_SWAP_COPY_ARB } }
{ color-float { $ WGL_TYPE_RGBA_FLOAT_ARB 1 } }
{ color-bits { $ WGL_COLOR_BITS_ARB } }
{ red-bits { $ WGL_RED_BITS_ARB } }
{ green-bits { $ WGL_GREEN_BITS_ARB } }
{ blue-bits { $ WGL_BLUE_BITS_ARB } }
{ alpha-bits { $ WGL_ALPHA_BITS_ARB } }
{ accum-bits { $ WGL_ACCUM_BITS_ARB } }
{ accum-red-bits { $ WGL_ACCUM_RED_BITS_ARB } }
{ accum-green-bits { $ WGL_ACCUM_GREEN_BITS_ARB } }
{ accum-blue-bits { $ WGL_ACCUM_BLUE_BITS_ARB } }
{ accum-alpha-bits { $ WGL_ACCUM_ALPHA_BITS_ARB } }
{ depth-bits { $ WGL_DEPTH_BITS_ARB } }
{ stencil-bits { $ WGL_STENCIL_BITS_ARB } }
{ aux-buffers { $ WGL_AUX_BUFFERS_ARB } }
{ sample-buffers { $ WGL_SAMPLE_BUFFERS_ARB } }
{ samples { $ WGL_SAMPLES_ARB } }
}
MEMO: (has-wglChoosePixelFormatARB?) ( dc -- ? )
{ "WGL_ARB_pixel_format" } has-wgl-extensions? ;
: has-wglChoosePixelFormatARB? ( world -- ? )
handle>> hDC>> (has-wglChoosePixelFormatARB?) ;
: arb-make-pixel-format ( world attributes -- pf )
[ handle>> hDC>> ] dip >WGL_ARB-int-array f 1 0 <int> 0 <int>
[ wglChoosePixelFormatARB win32-error=0/f ] 2keep drop *int ;
: arb-pixel-format-attribute ( pixel-format attribute -- value )
>WGL_ARB
[ drop f ] [
[ [ world>> handle>> hDC>> ] [ handle>> ] bi 0 1 ] dip
first <int> 0 <int>
[ wglGetPixelFormatAttribivARB win32-error=0/f ]
keep *int
] if-empty ;
CONSTANT: pfd-flag-map H{
{ double-buffered $ PFD_DOUBLEBUFFER }
{ stereo $ PFD_STEREO }
{ offscreen $ PFD_DRAW_TO_BITMAP }
{ fullscreen $ PFD_DRAW_TO_WINDOW }
{ windowed $ PFD_DRAW_TO_WINDOW }
{ backing-store $ PFD_SWAP_COPY }
{ software-rendered $ PFD_GENERIC_FORMAT }
}
: >pfd-flag ( attribute -- value )
pfd-flag-map at [ ] [ 0 ] if* ;
: >pfd-flags ( attributes -- flags )
[ >pfd-flag ] [ bitor ] map-reduce
PFD_SUPPORT_OPENGL bitor ;
: attr-value ( attributes name -- value )
[ instance? ] curry find nip
[ value>> ] [ 0 ] if* ;
: >pfd ( attributes -- pfd )
"PIXELFORMATDESCRIPTOR" <c-object>
"PIXELFORMATDESCRIPTOR" heap-size over set-PIXELFORMATDESCRIPTOR-nSize
1 over set-PIXELFORMATDESCRIPTOR-nVersion
over >pfd-flags over set-PIXELFORMATDESCRIPTOR-dwFlags
PFD_TYPE_RGBA over set-PIXELFORMATDESCRIPTOR-iPixelType
over color-bits attr-value over set-PIXELFORMATDESCRIPTOR-cColorBits
over red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cRedBits
over green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cGreenBits
over blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cBlueBits
over alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAlphaBits
over accum-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBits
over accum-red-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumRedBits
over accum-green-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumGreenBits
over accum-blue-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumBlueBits
over accum-alpha-bits attr-value over set-PIXELFORMATDESCRIPTOR-cAccumAlphaBits
over depth-bits attr-value over set-PIXELFORMATDESCRIPTOR-cDepthBits
over stencil-bits attr-value over set-PIXELFORMATDESCRIPTOR-cStencilBits
over aux-buffers attr-value over set-PIXELFORMATDESCRIPTOR-cAuxBuffers
PFD_MAIN_PLANE over set-PIXELFORMATDESCRIPTOR-dwLayerMask
nip ;
: pfd-make-pixel-format ( world attributes -- pf )
[ handle>> hDC>> ] [ >pfd ] bi*
ChoosePixelFormat dup win32-error=0/f ;
: get-pfd ( pixel-format -- pfd )
[ world>> handle>> hDC>> ] [ handle>> ] bi
"PIXELFORMATDESCRIPTOR" heap-size
"PIXELFORMATDESCRIPTOR" <c-object>
[ DescribePixelFormat win32-error=0/f ] keep ;
: pfd-flag? ( pfd flag -- ? )
[ PIXELFORMATDESCRIPTOR-dwFlags ] dip bitand c-bool> ;
: (pfd-pixel-format-attribute) ( pfd attribute -- value )
{
{ double-buffered [ PFD_DOUBLEBUFFER pfd-flag? ] }
{ stereo [ PFD_STEREO pfd-flag? ] }
{ offscreen [ PFD_DRAW_TO_BITMAP pfd-flag? ] }
{ fullscreen [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
{ windowed [ PFD_DRAW_TO_WINDOW pfd-flag? ] }
{ software-rendered [ PFD_GENERIC_FORMAT pfd-flag? ] }
{ color-bits [ PIXELFORMATDESCRIPTOR-cColorBits ] }
{ red-bits [ PIXELFORMATDESCRIPTOR-cRedBits ] }
{ green-bits [ PIXELFORMATDESCRIPTOR-cGreenBits ] }
{ blue-bits [ PIXELFORMATDESCRIPTOR-cBlueBits ] }
{ alpha-bits [ PIXELFORMATDESCRIPTOR-cAlphaBits ] }
{ accum-bits [ PIXELFORMATDESCRIPTOR-cAccumBits ] }
{ accum-red-bits [ PIXELFORMATDESCRIPTOR-cAccumRedBits ] }
{ accum-green-bits [ PIXELFORMATDESCRIPTOR-cAccumGreenBits ] }
{ accum-blue-bits [ PIXELFORMATDESCRIPTOR-cAccumBlueBits ] }
{ accum-alpha-bits [ PIXELFORMATDESCRIPTOR-cAccumAlphaBits ] }
{ depth-bits [ PIXELFORMATDESCRIPTOR-cDepthBits ] }
{ stencil-bits [ PIXELFORMATDESCRIPTOR-cStencilBits ] }
{ aux-buffers [ PIXELFORMATDESCRIPTOR-cAuxBuffers ] }
[ 2drop f ]
} case ;
: pfd-pixel-format-attribute ( pixel-format attribute -- value )
[ get-pfd ] dip (pfd-pixel-format-attribute) ;
M: windows-ui-backend (make-pixel-format)
over has-wglChoosePixelFormatARB?
[ arb-make-pixel-format ] [ pfd-make-pixel-format ] if ;
M: windows-ui-backend (free-pixel-format)
drop ;
M: windows-ui-backend (pixel-format-attribute)
over world>> has-wglChoosePixelFormatARB?
[ arb-pixel-format-attribute ] [ pfd-pixel-format-attribute ] if ;
PRIVATE>
: lo-word ( wparam -- lo ) <short> *short ; inline
: hi-word ( wparam -- hi ) -16 shift lo-word ; inline
: >lo-hi ( WORD -- array ) [ lo-word ] [ hi-word ] bi 2array ;
@ -73,12 +223,6 @@ M: pasteboard set-clipboard-contents drop copy ;
<pasteboard> clipboard set-global
<clipboard> selection set-global ;
TUPLE: win-base hDC hRC ;
TUPLE: win < win-base hWnd world title ;
TUPLE: win-offscreen < win-base hBitmap bits ;
C: <win> win
C: <win-offscreen> win-offscreen
SYMBOLS: msg-obj class-name-ptr mouse-captured ;
: style ( -- n ) WS_OVERLAPPEDWINDOW ; inline
@ -477,25 +621,24 @@ M: windows-ui-backend do-events
f class-name-ptr set-global
f msg-obj set-global ;
: setup-pixel-format ( hdc flags -- )
32 make-pfd [ ChoosePixelFormat dup win32-error=0/f ] 2keep
swapd SetPixelFormat win32-error=0/f ;
: get-dc ( world -- ) handle>> dup hWnd>> GetDC dup win32-error=0/f >>hDC drop ;
: get-dc ( hWnd -- hDC ) GetDC dup win32-error=0/f ;
: get-rc ( world -- )
handle>> dup hDC>> dup wglCreateContext dup win32-error=0/f
[ wglMakeCurrent win32-error=0/f ] keep >>hRC drop ;
: get-rc ( hDC -- hRC )
dup wglCreateContext dup win32-error=0/f
[ wglMakeCurrent win32-error=0/f ] keep ;
: set-pixel-format ( pixel-format hdc -- )
swap handle>> "PIXELFORMATDESCRIPTOR" <c-object> SetPixelFormat win32-error=0/f ;
: setup-gl ( hwnd -- hDC hRC )
get-dc dup windowed-pfd-dwFlags setup-pixel-format dup get-rc ;
: setup-gl ( world -- )
[ get-dc ] keep
[ swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi ]
with-world-pixel-format ;
M: windows-ui-backend (open-window) ( world -- )
[ create-window [ setup-gl ] keep ] keep
[ f <win> ] keep
[ swap hWnd>> register-window ] 2keep
dupd (>>handle)
hWnd>> show-window ;
[ dup create-window [ f f ] dip f f <win> >>handle setup-gl ]
[ dup handle>> hWnd>> register-window ]
[ handle>> hWnd>> show-window ] tri ;
M: win-base select-gl-context ( handle -- )
[ hDC>> ] [ hRC>> ] bi wglMakeCurrent win32-error=0/f
@ -504,15 +647,15 @@ M: win-base select-gl-context ( handle -- )
M: win-base flush-gl-context ( handle -- )
hDC>> SwapBuffers win32-error=0/f ;
: setup-offscreen-gl ( dim -- hDC hRC hBitmap bits )
make-offscreen-dc-and-bitmap [
[ dup offscreen-pfd-dwFlags setup-pixel-format ]
[ get-rc ] bi
] 2dip ;
: setup-offscreen-gl ( world -- )
dup [ handle>> ] [ dim>> ] bi make-offscreen-dc-and-bitmap
[ >>hDC ] [ >>hBitmap ] [ >>bits ] tri* drop [
swap [ handle>> hDC>> set-pixel-format ] [ get-rc ] bi
] with-world-pixel-format ;
M: windows-ui-backend (open-offscreen-buffer) ( world -- )
dup dim>> setup-offscreen-gl <win-offscreen>
>>handle drop ;
win-offscreen new >>handle
setup-offscreen-gl ;
M: windows-ui-backend (close-offscreen-buffer) ( handle -- )
[ hDC>> DeleteDC drop ]

44
basis/ui/backend/x11/x11.factor
View File

@ -7,7 +7,8 @@ namespaces opengl sequences strings x11 x11.xlib x11.events x11.xim
x11.glx x11.clipboard x11.constants x11.windows x11.io
io.encodings.string io.encodings.ascii io.encodings.utf8 combinators
command-line math.vectors classes.tuple opengl.gl threads
math.rectangles environment ascii ;
math.rectangles environment ascii literals
ui.pixel-formats ui.pixel-formats.private ;
IN: ui.backend.x11
SINGLETON: x11-ui-backend
@ -29,6 +30,40 @@ M: world configure-event
! In case dimensions didn't change
relayout-1 ;
PIXEL-FORMAT-ATTRIBUTE-TABLE: glx-visual { $ GLX_USE_GL $ GLX_RGBA } H{
{ double-buffered { $ GLX_DOUBLEBUFFER } }
{ stereo { $ GLX_STEREO } }
{ color-bits { $ GLX_BUFFER_SIZE } }
{ red-bits { $ GLX_RED_SIZE } }
{ green-bits { $ GLX_GREEN_SIZE } }
{ blue-bits { $ GLX_BLUE_SIZE } }
{ alpha-bits { $ GLX_ALPHA_SIZE } }
{ accum-red-bits { $ GLX_ACCUM_RED_SIZE } }
{ accum-green-bits { $ GLX_ACCUM_GREEN_SIZE } }
{ accum-blue-bits { $ GLX_ACCUM_BLUE_SIZE } }
{ accum-alpha-bits { $ GLX_ACCUM_ALPHA_SIZE } }
{ depth-bits { $ GLX_DEPTH_SIZE } }
{ stencil-bits { $ GLX_STENCIL_SIZE } }
{ aux-buffers { $ GLX_AUX_BUFFERS } }
{ sample-buffers { $ GLX_SAMPLE_BUFFERS } }
{ samples { $ GLX_SAMPLES } }
}
M: x11-ui-backend (make-pixel-format)
[ drop dpy get scr get ] dip
>glx-visual-int-array glXChooseVisual ;
M: x11-ui-backend (free-pixel-format)
handle>> XFree ;
M: x11-ui-backend (pixel-format-attribute)
[ dpy get ] 2dip
[ handle>> ] [ >glx-visual ] bi*
[ 2drop f ] [
first
0 <int> [ glXGetConfig drop ] keep *int
] if-empty ;
CONSTANT: modifiers
{
{ S+ HEX: 1 }
@ -187,7 +222,8 @@ M: world client-event
: gadget-window ( world -- )
dup
[ window-loc>> ] [ dim>> ] bi glx-window swap
[ [ [ window-loc>> ] [ dim>> ] bi ] dip handle>> glx-window ]
with-world-pixel-format swap
dup "Factor" create-xic
<x11-handle>
[ window>> register-window ] [ >>handle drop ] 2bi ;
@ -274,7 +310,9 @@ M: x11-pixmap-handle flush-gl-context ( handle -- )
drop ;
M: x11-ui-backend (open-offscreen-buffer) ( world -- )
dup dim>> glx-pixmap <x11-pixmap-handle> >>handle drop ;
dup [ [ dim>> ] [ handle>> ] bi* glx-pixmap ]
with-world-pixel-format
<x11-pixmap-handle> >>handle drop ;
M: x11-ui-backend (close-offscreen-buffer) ( handle -- )
dpy get swap
[ glx-pixmap>> glXDestroyGLXPixmap ]

6
basis/ui/gadgets/gadgets.factor
View File

@ -3,7 +3,8 @@
USING: accessors arrays hashtables kernel models math namespaces
make sequences quotations math.vectors combinators sorting
binary-search vectors dlists deques models threads
concurrency.flags math.order math.rectangles fry locals ;
concurrency.flags math.order math.rectangles fry locals
prettyprint.backend prettyprint.custom ;
IN: ui.gadgets
! Values for orientation slot
@ -27,6 +28,9 @@ interior
boundary
model ;
! Don't print gadgets with RECT: syntax
M: gadget pprint* pprint-tuple ;
M: gadget equal? 2drop f ;
M: gadget hashcode* nip [ [ \ gadget counter ] unless* ] change-id id>> ;

12
basis/ui/gadgets/glass/glass-tests.factor
View File

@ -1,10 +1,14 @@
IN: ui.gadgets.glass.tests
USING: tools.test ui.gadgets.glass ui.gadgets.worlds ui.gadgets
math.rectangles namespaces accessors models sequences ;
math.rectangles namespaces accessors models sequences arrays ;
<gadget> "" f <model> <world>
{ 1000 1000 } >>dim
"w" set
[ ] [
<world-attributes>
<gadget> 1array >>gadgets
<world>
{ 1000 1000 } >>dim
"w" set
] unit-test
[ ] [ <gadget> "g" set ] unit-test

4
basis/ui/gadgets/status-bar/status-bar-docs.factor
View File

@ -18,7 +18,7 @@ HELP: <status-bar>
{ $notes "If the " { $snippet "model" } " is " { $snippet "status" } ", this gadget will display mouse over help for " { $link "ui.gadgets.presentations" } "." } ;
HELP: open-status-window
{ $values { "gadget" gadget } { "title" string } }
{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
{ $description "Like " { $link open-window } ", with the additional feature that the new window iwll have a status bar displaying the value stored in the world's " { $slot "status" } " slot." }
{ $see-also show-status hide-status } ;
@ -30,4 +30,4 @@ ARTICLE: "ui.gadgets.status-bar" "Status bars and mouse-over help"
{ $subsection hide-status }
{ $link "ui.gadgets.presentations" } " use the status bar to display object summary." ;
ABOUT: "ui.gadgets.status-bar"
ABOUT: "ui.gadgets.status-bar"

8
basis/ui/gadgets/status-bar/status-bar.factor
View File

@ -2,7 +2,7 @@
! See http://factorcode.org/license.txt for BSD license.
USING: accessors models models.delay models.arrow
sequences ui.gadgets.labels ui.gadgets.tracks
ui.gadgets.worlds ui.gadgets ui kernel calendar summary ;
ui.gadgets.worlds ui.gadgets ui ui.private kernel calendar summary ;
IN: ui.gadgets.status-bar
: <status-bar> ( model -- gadget )
@ -10,9 +10,9 @@ IN: ui.gadgets.status-bar
reverse-video-theme
t >>root? ;
: open-status-window ( gadget title -- )
f <model> [ <world> ] keep
<status-bar> f track-add
: open-status-window ( gadget title/attributes -- )
?attributes f <model> >>status <world>
dup status>> <status-bar> f track-add
open-world-window ;
: show-summary ( object gadget -- )

33
basis/ui/gadgets/worlds/worlds-docs.factor Normal file → Executable file
View File

@ -1,6 +1,6 @@
USING: ui.gadgets ui.render ui.text ui.text.private
ui.gestures ui.backend help.markup help.syntax
models opengl strings ;
models opengl sequences strings ;
IN: ui.gadgets.worlds
HELP: user-input
@ -48,8 +48,8 @@ HELP: world
} ;
HELP: <world>
{ $values { "gadget" gadget } { "title" string } { "status" model } { "world" "a new " { $link world } } }
{ $description "Creates a new " { $link world } " delegating to the given gadget." } ;
{ $values { "world-attributes" world-attributes } { "world" "a new " { $link world } } }
{ $description "Creates a new " { $link world } " or world subclass with the given attributes." } ;
HELP: find-world
{ $values { "gadget" gadget } { "world/f" { $maybe world } } }
@ -65,6 +65,30 @@ HELP: find-gl-context
{ $description "Makes the OpenGL context of the gadget's containing native window the current OpenGL context." }
{ $notes "This word should be called from " { $link graft* } " and " { $link ungraft* } " methods which need to allocate and deallocate OpenGL resources, such as textures, display lists, and so on." } ;
HELP: begin-world
{ $values { "world" world } }
{ $description "Called immediately after " { $snippet "world" } "'s OpenGL context has been created. The world's OpenGL context is current when this method is called." } ;
HELP: end-world
{ $values { "world" world } }
{ $description "Called immediately before " { $snippet "world" } "'s OpenGL context is destroyed. The world's OpenGL context is current when this method is called." } ;
HELP: resize-world
{ $values { "world" world } }
{ $description "Called when the window containing " { $snippet "world" } " is resized. The " { $snippet "loc" } " and " { $snippet "dim" } " slots of " { $snippet "world" } " will be updated with the world's new position and size. The world's OpenGL context is current when this method is called." } ;
HELP: draw-world*
{ $values { "world" world } }
{ $description "Called when " { $snippet "world" } " needs to be redrawn. The world's OpenGL context is current when this method is called." } ;
ARTICLE: "ui.gadgets.worlds-subclassing" "Subclassing worlds"
"The " { $link world } " gadget can be subclassed, giving Factor code full control of the window's OpenGL context. The following generic words can be overridden to replace standard UI behavior:"
{ $subsection begin-world }
{ $subsection end-world }
{ $subsection resize-world }
{ $subsection draw-world* }
"See the " { $vocab-link "spheres" } " and " { $vocab-link "bunny" } " demos for examples." ;
ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
"The UI uses OpenGL to render gadgets. Custom rendering logic can be plugged in with the " { $link "ui-pen-protocol" } ", or by implementing a generic word:"
{ $subsection draw-gadget* }
@ -72,7 +96,8 @@ ARTICLE: "ui-paint-custom" "Implementing custom drawing logic"
$nl
"Gadgets which need to allocate and deallocate OpenGL resources such as textures, display lists, and so on, should perform the allocation in the " { $link graft* } " method, and the deallocation in the " { $link ungraft* } " method. Since those words are not necessarily called with the gadget's OpenGL context active, a utility word can be used to find and make the correct OpenGL context current:"
{ $subsection find-gl-context }
"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa."
"OpenGL state must not be altered as a result of drawing a gadget, so any flags which were enabled should be disabled, and vice versa. To take full control of the OpenGL context, see " { $link "ui.gadgets.worlds-subclassing" } "."
{ $subsection "ui-paint-coord" }
{ $subsection "ui.gadgets.worlds-subclassing" }
{ $subsection "gl-utilities" }
{ $subsection "text-rendering" } ;

4
basis/ui/gadgets/worlds/worlds-tests.factor
View File

@ -1,12 +1,12 @@
USING: ui.gadgets ui.gadgets.packs ui.gadgets.worlds tools.test
namespaces models kernel accessors ;
namespaces models kernel accessors arrays ;
IN: ui.gadgets.worlds.tests
! Test focus behavior
<gadget> "g1" set
: <test-world> ( gadget -- world )
"Hi" f <world> ;
<world-attributes> "Hi" >>title swap 1array >>gadgets <world> ;
[ ] [
"g1" get <test-world> "w" set

104
basis/ui/gadgets/worlds/worlds.factor Normal file → Executable file
View File

@ -4,15 +4,29 @@ USING: accessors arrays assocs continuations kernel math models
namespaces opengl opengl.textures sequences io combinators
combinators.short-circuit fry math.vectors math.rectangles cache
ui.gadgets ui.gestures ui.render ui.backend ui.gadgets.tracks
ui.commands ;
ui.commands ui.pixel-formats destructors literals ;
IN: ui.gadgets.worlds
CONSTANT: default-world-pixel-format-attributes
{ windowed double-buffered T{ depth-bits { value 16 } } }
TUPLE: world < track
active? focused?
layers
title status status-owner
text-handle handle images
window-loc ;
active? focused?
layers
title status status-owner
text-handle handle images
window-loc
pixel-format-attributes ;
TUPLE: world-attributes
{ world-class initial: world }
title
status
gadgets
{ pixel-format-attributes initial: $ default-world-pixel-format-attributes } ;
: <world-attributes> ( -- world-attributes )
world-attributes new ; inline
: find-world ( gadget -- world/f ) [ world? ] find-parent ;
@ -45,18 +59,23 @@ M: world request-focus-on ( child gadget -- )
2dup eq?
[ 2drop ] [ dup focused?>> (request-focus) ] if ;
: new-world ( gadget title status class -- world )
: new-world ( class -- world )
vertical swap new-track
t >>root?
t >>active?
{ 0 0 } >>window-loc
swap >>status
swap >>title
swap 1 track-add
dup request-focus ;
{ 0 0 } >>window-loc ;
: <world> ( gadget title status -- world )
world new-world ;
: apply-world-attributes ( world attributes -- world )
{
[ title>> >>title ]
[ status>> >>status ]
[ pixel-format-attributes>> >>pixel-format-attributes ]
[ gadgets>> [ 1 track-add ] each ]
} cleave ;
: <world> ( world-attributes -- world )
[ world-class>> new-world ] keep apply-world-attributes
dup request-focus ;
: as-big-as-possible ( world gadget -- )
dup [ { 0 0 } >>loc over dim>> >>dim ] when 2drop ; inline
@ -77,17 +96,36 @@ SYMBOL: flush-layout-cache-hook
flush-layout-cache-hook [ [ ] ] initialize
: (draw-world) ( world -- )
dup handle>> [
check-extensions
{
[ init-gl ]
[ draw-gadget ]
[ text-handle>> [ purge-cache ] when* ]
[ images>> [ purge-cache ] when* ]
} cleave
] with-gl-context
flush-layout-cache-hook get call( -- ) ;
GENERIC: begin-world ( world -- )
GENERIC: end-world ( world -- )
GENERIC: resize-world ( world -- )
M: world begin-world
drop ;
M: world end-world
drop ;
M: world resize-world
drop ;
M: world (>>dim)
[ call-next-method ]
[
dup handle>>
[ select-gl-context resize-world ]
[ drop ] if*
] bi ;
GENERIC: draw-world* ( world -- )
M: world draw-world*
check-extensions
{
[ init-gl ]
[ draw-gadget ]
[ text-handle>> [ purge-cache ] when* ]
[ images>> [ purge-cache ] when* ]
} cleave ;
: draw-world? ( world -- ? )
#! We don't draw deactivated worlds, or those with 0 size.
@ -108,7 +146,10 @@ ui-error-hook [ [ rethrow ] ] initialize
: draw-world ( world -- )
dup draw-world? [
dup world [
[ (draw-world) ] [
[
dup handle>> [ draw-world* ] with-gl-context
flush-layout-cache-hook get call( -- )
] [
over <world-error> ui-error
f >>active? drop
] recover
@ -149,3 +190,14 @@ M: world handle-gesture ( gesture gadget -- ? )
: close-global ( world global -- )
[ get-global find-world eq? ] keep '[ f _ set-global ] when ;
M: world world-pixel-format-attributes
pixel-format-attributes>> ;
M: world check-world-pixel-format
2drop ;
: with-world-pixel-format ( world quot -- )
[ dup dup world-pixel-format-attributes <pixel-format> ]
dip [ 2dup check-world-pixel-format ] prepose with-disposal ; inline

0
extra/ui/offscreen/authors.txt → basis/ui/pixel-formats/authors.txt
View File

198
basis/ui/pixel-formats/pixel-formats-docs.factor Normal file
View File

@ -0,0 +1,198 @@
USING: destructors help.markup help.syntax kernel math multiline sequences
vocabs vocabs.parser words ;
IN: ui.pixel-formats
! break circular dependency
<<
"ui.gadgets.worlds" create-vocab drop
"world" "ui.gadgets.worlds" create drop
"ui.gadgets.worlds" (use+)
>>
ARTICLE: "ui.pixel-formats-attributes" "Pixel format attributes"
"The following pixel format attributes can be requested and queried of " { $link pixel-format } "s. Binary attributes are represented by the presence of a symbol in an attribute sequence:"
{ $subsection double-buffered }
{ $subsection stereo }
{ $subsection offscreen }
{ $subsection fullscreen }
{ $subsection windowed }
{ $subsection accelerated }
{ $subsection software-rendered }
{ $subsection backing-store }
{ $subsection multisampled }
{ $subsection supersampled }
{ $subsection sample-alpha }
{ $subsection color-float }
"Integer attributes are represented by a " { $link tuple } " with a single " { $snippet "value" } "slot:"
{ $subsection color-bits }
{ $subsection red-bits }
{ $subsection green-bits }
{ $subsection blue-bits }
{ $subsection alpha-bits }
{ $subsection accum-bits }
{ $subsection accum-red-bits }
{ $subsection accum-green-bits }
{ $subsection accum-blue-bits }
{ $subsection accum-alpha-bits }
{ $subsection depth-bits }
{ $subsection stencil-bits }
{ $subsection aux-buffers }
{ $subsection sample-buffers }
{ $subsection samples }
{ $examples
"The following " { $link world } " subclass will request a double-buffered window with minimum 24-bit color and depth buffers, and will throw an error if the requirements aren't met:"
{ $code <"
USING: kernel ui.worlds ui.pixel-formats ;
IN: ui.pixel-formats.examples
TUPLE: picky-depth-buffered-world < world ;
M: picky-depth-buffered-world world-pixel-format-attributes
drop {
double-buffered
T{ color-bits { value 24 } }
T{ depth-bits { value 24 } }
} ;
M: picky-depth-buffered-world check-world-pixel-format
nip
[ double-buffered pixel-format-attribute 0 = [ "Not double buffered!" throw ] when ]
[ color-bits pixel-format-attribute 24 < [ "Not enough color bits!" throw ] when ]
[ depth-bits pixel-format-attribute 24 < [ "Not enough depth bits!" throw ] when ]
tri ;
"> } }
;
HELP: double-buffered
{ $class-description "Requests a double-buffered pixel format." } ;
HELP: stereo
{ $class-description "Requests a stereoscopic pixel format." } ;
HELP: offscreen
{ $class-description "Requests a pixel format suitable for offscreen rendering." } ;
HELP: fullscreen
{ $class-description "Requests a pixel format suitable for fullscreen rendering." }
{ $notes "On some window systems this is not distinct from " { $link windowed } "." } ;
HELP: windowed
{ $class-description "Requests a pixel format suitable for rendering to a window." } ;
{ offscreen fullscreen windowed } related-words
HELP: accelerated
{ $class-description "Requests a pixel format supported by GPU hardware acceleration." } ;
HELP: software-rendered
{ $class-description "Requests a pixel format only supported by the window system's default software renderer." } ;
{ accelerated software-rendered } related-words
HELP: backing-store
{ $class-description "Used with " { $link double-buffered } " to request a double-buffered pixel format where the back buffer contents are preserved and copied to the front when buffers are swapped." } ;
{ double-buffered backing-store } related-words
HELP: multisampled
{ $class-description "Requests a pixel format with multisampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of multisampling." }
{ $notes "On some window systems this is not distinct from " { $link supersampled } "." } ;
HELP: supersampled
{ $class-description "Requests a pixel format with supersampled antialiasing enabled. The " { $link sample-buffers } " and " { $link samples } " attributes must also be provided to specify the level of supersampling." }
{ $notes "On some window systems this is not distinct from " { $link multisampled } "." } ;
HELP: sample-alpha
{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request more accurate multisampling of alpha values." } ;
HELP: color-float
{ $class-description "Requests a pixel format where the color buffer is stored in floating-point format." } ;
HELP: color-bits
{ $class-description "Requests a pixel format with a color buffer of at least " { $snippet "value" } " bits per pixel." } ;
HELP: red-bits
{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " red bits per pixel." } ;
HELP: green-bits
{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " green bits per pixel." } ;
HELP: blue-bits
{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
HELP: alpha-bits
{ $class-description "Requests a pixel format with a color buffer with at least " { $snippet "value" } " alpha bits per pixel." } ;
{ color-float color-bits red-bits green-bits blue-bits alpha-bits } related-words
HELP: accum-bits
{ $class-description "Requests a pixel format with an accumulation buffer of at least " { $snippet "value" } " bits per pixel." } ;
HELP: accum-red-bits
{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " red bits per pixel." } ;
HELP: accum-green-bits
{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " green bits per pixel." } ;
HELP: accum-blue-bits
{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " blue bits per pixel." } ;
HELP: accum-alpha-bits
{ $class-description "Requests a pixel format with an accumulation buffer with at least " { $snippet "value" } " alpha bits per pixel." } ;
{ accum-bits accum-red-bits accum-green-bits accum-blue-bits accum-alpha-bits } related-words
HELP: depth-bits
{ $class-description "Requests a pixel format with a depth buffer of at least " { $snippet "value" } " bits per pixel." } ;
HELP: stencil-bits
{ $class-description "Requests a pixel format with a stencil buffer of at least " { $snippet "value" } " bits per pixel." } ;
HELP: aux-buffers
{ $class-description "Requests a pixel format with at least " { $snippet "value" } " auxiliary buffers." } ;
HELP: sample-buffers
{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request a pixel format with at least " { $snippet "value" } " sampling buffers." } ;
HELP: samples
{ $class-description "Used with " { $link multisampled } " or " { $link supersampled } " to request at least " { $snippet "value" } " samples per pixel." } ;
{ multisampled supersampled sample-alpha sample-buffers samples } related-words
HELP: world-pixel-format-attributes
{ $values { "world" world } { "attributes" sequence } }
{ $description "Returns the set of " { $link "ui.pixel-formats-attributes" } " that " { $snippet "world" } " requests when grafted. This generic can be overridden by subclasses of " { $snippet "world" } "." }
{ $notes "The pixel format provided by the window system will not necessarily exactly match the requested attributes. To verify required pixel format attributes, override " { $link check-world-pixel-format } "." } ;
HELP: check-world-pixel-format
{ $values { "world" world } { "pixel-format" pixel-format } }
{ $description "Verifies that " { $snippet "pixel-format" } " fulfills the requirements of " { $snippet "world" } ". The default method does nothing. Subclasses can override this generic to perform their own checks on the pixel format." } ;
HELP: pixel-format
{ $class-description "The type of pixel format objects. The tuple slot contents should be considered opaque by user code. To check the value of a pixel format's attributes, use the " { $link pixel-format-attribute } " word. Pixel format objects must be freed using the " { $link dispose } " word when they are no longer needed." } ;
HELP: <pixel-format>
{ $values { "world" world } { "attributes" sequence } { "pixel-format" pixel-format } }
{ $description "Requests a pixel format suitable for " { $snippet "world" } " with a set of " { $link "ui.pixel-formats-attributes" } ". If no pixel format can be found that satisfies the given attributes, an " { $link invalid-pixel-format-attributes } " error is thrown. Pixel format attributes not supported by the window system are ignored. The returned " { $snippet "pixel-format" } " must be released using the " { $link dispose } " word when it is no longer needed." }
{ $notes "Pixel formats don't normally need to be directly allocated by user code. If you need to control the pixel format requested by a window, subclass " { $snippet "world" } " and override the " { $link world-pixel-format-attributes } " and " { $link check-world-pixel-format } " words."
$nl
"The returned pixel format does not necessarily exactly match the requested attributes; the window system will try to find the format that best matches the given attributes. Use " { $link pixel-format-attribute } " to check the actual values of the attributes on the returned pixel format." }
;
HELP: pixel-format-attribute
{ $values { "pixel-format" pixel-format } { "attribute-name" "one of the " { $link "ui.pixel-formats-attributes" } } { "value" object } }
{ $description "Returns the value of the requested " { $snippet "attribute-name" } " in " { $snippet "pixel-format" } ". If " { "attribute-name" } " is unsupported by the window system, " { $link f } " is returned." } ;
HELP: invalid-pixel-format-attributes
{ $values { "world" world } { "attributes" sequence } }
{ $class-description "Thrown by " { $link <pixel-format> } " when the window system is unable to find a pixel format for " { $snippet "world" } " that satisfies the requested " { $snippet "attributes" } "." } ;
{ world-pixel-format-attributes check-world-pixel-format pixel-format <pixel-format> pixel-format-attribute }
related-words
ARTICLE: "ui.pixel-formats" "Pixel formats"
"The UI allows you to control the window system's OpenGL interface with a cross-platform set of pixel format specifiers:"
{ $subsection "ui.pixel-formats-attributes" }
"Pixel formats can be requested using these attributes:"
{ $subsection pixel-format }
{ $subsection <pixel-format> }
{ $subsection pixel-format-attribute }
"If a request for a set of pixel format attributes cannot be satisfied, an error is thrown:"
{ $subsection invalid-pixel-format-attributes }
"Pixel formats are requested as part of opening a window for a " { $link world } ". These generics can be overridden on " { $snippet "world" } " subclasses to control pixel format selection:"
{ $subsection world-pixel-format-attributes }
{ $subsection check-world-pixel-format }
;
ABOUT: "ui.pixel-formats"

94
basis/ui/pixel-formats/pixel-formats.factor Normal file
View File

@ -0,0 +1,94 @@
USING: accessors assocs classes destructors functors kernel
lexer math parser sequences specialized-arrays.int ui.backend
words.symbol ;
IN: ui.pixel-formats
SYMBOLS:
double-buffered
stereo
offscreen
fullscreen
windowed
accelerated
software-rendered
backing-store
multisampled
supersampled
sample-alpha
color-float ;
TUPLE: pixel-format-attribute { value integer } ;
TUPLE: color-bits < pixel-format-attribute ;
TUPLE: red-bits < pixel-format-attribute ;
TUPLE: green-bits < pixel-format-attribute ;
TUPLE: blue-bits < pixel-format-attribute ;
TUPLE: alpha-bits < pixel-format-attribute ;
TUPLE: accum-bits < pixel-format-attribute ;
TUPLE: accum-red-bits < pixel-format-attribute ;
TUPLE: accum-green-bits < pixel-format-attribute ;
TUPLE: accum-blue-bits < pixel-format-attribute ;
TUPLE: accum-alpha-bits < pixel-format-attribute ;
TUPLE: depth-bits < pixel-format-attribute ;
TUPLE: stencil-bits < pixel-format-attribute ;
TUPLE: aux-buffers < pixel-format-attribute ;
TUPLE: sample-buffers < pixel-format-attribute ;
TUPLE: samples < pixel-format-attribute ;
HOOK: (make-pixel-format) ui-backend ( world attributes -- pixel-format-handle )
HOOK: (free-pixel-format) ui-backend ( pixel-format -- )
HOOK: (pixel-format-attribute) ui-backend ( pixel-format attribute-name -- value )
ERROR: invalid-pixel-format-attributes world attributes ;
TUPLE: pixel-format world handle ;
: <pixel-format> ( world attributes -- pixel-format )
2dup (make-pixel-format)
[ nip pixel-format boa ] [ invalid-pixel-format-attributes ] if* ;
M: pixel-format dispose
[ (free-pixel-format) ] [ f >>handle drop ] bi ;
: pixel-format-attribute ( pixel-format attribute-name -- value )
(pixel-format-attribute) ;
<PRIVATE
FUNCTOR: define-pixel-format-attribute-table ( NAME PERM TABLE -- )
>PFA DEFINES >${NAME}
>PFA-int-array DEFINES >${NAME}-int-array
WHERE
GENERIC: >PFA ( attribute -- pfas )
M: object >PFA
drop { } ;
M: symbol >PFA
TABLE at [ { } ] unless* ;
M: pixel-format-attribute >PFA
dup class TABLE at
[ swap value>> suffix ]
[ drop { } ] if* ;
: >PFA-int-array ( attribute -- int-array )
[ >PFA ] map concat PERM prepend 0 suffix >int-array ;
;FUNCTOR
SYNTAX: PIXEL-FORMAT-ATTRIBUTE-TABLE:
scan scan-object scan-object define-pixel-format-attribute-table ;
PRIVATE>
GENERIC: world-pixel-format-attributes ( world -- attributes )
GENERIC# check-world-pixel-format 1 ( world pixel-format -- )

1
basis/ui/pixel-formats/summary.txt Normal file
View File

@ -0,0 +1 @@
Cross-platform OpenGL context pixel format specifiers

12
basis/ui/text/text.factor
View File

@ -75,10 +75,8 @@ M: array draw-text
USING: vocabs.loader namespaces system combinators ;
"ui-backend" get [
{
{ [ os macosx? ] [ "core-text" ] }
{ [ os windows? ] [ "uniscribe" ] }
{ [ os unix? ] [ "pango" ] }
} cond
] unless* "ui.text." prepend require
{
{ [ os macosx? ] [ "core-text" ] }
{ [ os windows? ] [ "uniscribe" ] }
{ [ os unix? ] [ "pango" ] }
} cond "ui.text." prepend require

2
basis/ui/tools/listener/listener-docs.factor
View File

@ -1,7 +1,7 @@
USING: help.markup help.syntax ui.commands ui.operations
ui.gadgets.editors ui.gadgets.panes listener io words
ui.tools.listener.completion ui.tools.common help.tips
tools.vocabs vocabs ;
vocabs vocabs.refresh ;
IN: ui.tools.listener
HELP: interactor

5
basis/ui/tools/listener/listener.factor
View File

@ -6,14 +6,15 @@ compiler.units help.tips concurrency.flags concurrency.mailboxes
continuations destructors documents documents.elements fry hashtables
help help.markup io io.styles kernel lexer listener math models sets
models.delay models.arrow namespaces parser prettyprint quotations
sequences strings threads tools.vocabs vocabs vocabs.loader
sequences strings threads vocabs vocabs.refresh vocabs.loader
vocabs.parser words debugger ui ui.commands ui.pens.solid ui.gadgets
ui.gadgets.glass ui.gadgets.buttons ui.gadgets.editors
ui.gadgets.labeled ui.gadgets.panes ui.gadgets.scrollers
ui.gadgets.status-bar ui.gadgets.tracks ui.gadgets.borders ui.gestures
ui.operations ui.tools.browser ui.tools.common ui.tools.debugger
ui.tools.listener.completion ui.tools.listener.popups
ui.tools.listener.history ui.images ui.tools.error-list tools.errors.model ;
ui.tools.listener.history ui.images ui.tools.error-list
tools.errors.model ;
FROM: source-files.errors => all-errors ;
IN: ui.tools.listener

2
basis/ui/tools/operations/operations.factor
View File

@ -4,7 +4,7 @@ USING: continuations definitions generic help.topics threads
stack-checker summary io.pathnames io.styles kernel namespaces parser
prettyprint quotations tools.crossref tools.annotations editors
tools.profiler tools.test tools.time tools.walker vocabs vocabs.loader
words sequences tools.vocabs classes compiler.errors compiler.units
words sequences classes compiler.errors compiler.units
accessors vocabs.parser macros.expander ui ui.tools.browser
ui.tools.listener ui.tools.listener.completion ui.tools.profiler
ui.tools.inspector ui.tools.traceback ui.commands ui.gadgets.editors

2
basis/ui/tools/tools.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2006, 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: memory system kernel tools.vocabs ui.tools.operations
USING: memory system kernel vocabs.refresh ui.tools.operations
ui.tools.listener ui.tools.browser ui.tools.common ui.tools.error-list
ui.tools.walker ui.commands ui.gestures ui ui.private ;
IN: ui.tools

19
basis/ui/ui-docs.factor
View File

@ -2,17 +2,28 @@ USING: help.markup help.syntax strings quotations debugger
namespaces ui.backend ui.gadgets ui.gadgets.worlds
ui.gadgets.tracks ui.gadgets.packs ui.gadgets.grids
ui.gadgets.private math.rectangles colors ui.text fonts
kernel ui.private ;
kernel ui.private classes sequences ;
IN: ui
HELP: windows
{ $var-description "Global variable holding an association list mapping native window handles to " { $link world } " instances." } ;
{ windows open-window find-window } related-words
{ windows open-window find-window world-attributes } related-words
HELP: open-window
{ $values { "gadget" gadget } { "title" string } }
{ $description "Opens a native window with the specified title." } ;
{ $values { "gadget" gadget } { "title/attributes" { "a " { $link string } " or a " { $link world-attributes } " tuple" } } }
{ $description "Opens a native window containing " { $snippet "gadget" } " with the specified attributes. If a string is provided, it is used as the window title; otherwise, the window attributes are specified in a " { $link world-attributes } " tuple." } ;
HELP: world-attributes
{ $values { "world-class" class } { "title" string } { "status" gadget } { "gadgets" sequence } { "pixel-format-attributes" sequence } }
{ $class-description "Tuples of this class can be passed to " { $link open-window } " to control attributes of the window opened. The following attributes can be set:" }
{ $list
{ { $snippet "world-class" } " specifies the class of world to construct. " { $link world } " is the default." }
{ { $snippet "title" } " is the window title." }
{ { $snippet "status" } ", if specified, is a gadget that will be used as the window's status bar." }
{ { $snippet "gadgets" } " is a sequence of gadgets that will be placed inside the window." }
{ { $snippet "pixel-format-attributes" } " is a sequence of " { $link "ui.pixel-formats-attributes" } " that the window will request for its OpenGL pixel format." }
} ;
HELP: set-fullscreen?
{ $values { "?" "a boolean" } { "gadget" gadget } }

26
basis/ui/ui.factor
View File

@ -4,7 +4,8 @@ USING: arrays assocs io kernel math models namespaces make dlists
deques sequences threads sequences words continuations init
combinators combinators.short-circuit hashtables concurrency.flags
sets accessors calendar fry destructors ui.gadgets ui.gadgets.private
ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render ;
ui.gadgets.worlds ui.gadgets.tracks ui.gestures ui.backend ui.render
strings ;
IN: ui
<PRIVATE
@ -49,8 +50,20 @@ SYMBOL: windows
f >>focused?
focus-path f swap focus-gestures ;
: try-to-open-window ( world -- )
{
[ (open-window) ]
[ handle>> select-gl-context ]
[
[ begin-world ]
[ [ handle>> (close-window) ] [ ui-error ] bi* ]
recover
]
[ resize-world ]
} cleave ;
M: world graft*
[ (open-window) ]
[ try-to-open-window ]
[ [ title>> ] keep set-title ]
[ request-focus ] tri ;
@ -66,6 +79,7 @@ M: world graft*
[ images>> [ dispose ] when* ]
[ hand-clicked close-global ]
[ hand-gadget close-global ]
[ end-world ]
} cleave ;
M: world ungraft*
@ -166,13 +180,17 @@ PRIVATE>
: restore-windows? ( -- ? )
windows get empty? not ;
: ?attributes ( gadget title/attributes -- attributes )
dup string? [ world-attributes new swap >>title ] when
swap [ [ [ 1array ] [ f ] if* ] curry unless* ] curry change-gadgets ;
PRIVATE>
: open-world-window ( world -- )
dup pref-dim >>dim dup relayout graft ;
: open-window ( gadget title -- )
f <world> open-world-window ;
: open-window ( gadget title/attributes -- )
?attributes <world> open-world-window ;
: set-fullscreen? ( ? gadget -- )
find-world set-fullscreen* ;

1
basis/vocabs/cache/authors.txt vendored Normal file
View File

@ -0,0 +1 @@
Slava Pestov

21
basis/vocabs/cache/cache.factor vendored Normal file
View File

@ -0,0 +1,21 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs kernel namespaces memoize init vocabs
vocabs.hierarchy vocabs.loader vocabs.metadata vocabs.refresh ;
IN: vocabs.cache
: reset-cache ( -- )
root-cache get-global clear-assoc
\ vocab-file-contents reset-memoized
\ all-vocabs-seq reset-memoized
\ all-authors reset-memoized
\ all-tags reset-memoized ;
SINGLETON: cache-observer
M: cache-observer vocabs-changed drop reset-cache ;
[
f changed-vocabs set-global
cache-observer add-vocab-observer
] "vocabs.cache" add-init-hook

1
basis/vocabs/cache/summary.txt vendored Normal file
View File

@ -0,0 +1 @@
Caching vocabulary data from disk

1
basis/vocabs/errors/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

35
basis/vocabs/errors/errors.factor Normal file
View File

@ -0,0 +1,35 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: assocs continuations debugger io io.styles kernel
namespaces sequences vocabs vocabs.loader ;
IN: vocabs.errors
<PRIVATE
: vocab-heading. ( vocab -- )
nl
"==== " write
[ vocab-name ] [ vocab write-object ] bi ":" print
nl ;
: load-error. ( triple -- )
[ first vocab-heading. ] [ second print-error ] bi ;
SYMBOL: failures
PRIVATE>
: load-failures. ( failures -- )
[ load-error. nl ] each ;
: require-all ( vocabs -- failures )
[
V{ } clone blacklist set
V{ } clone failures set
[
[ require ]
[ swap vocab-name failures get set-at ]
recover
] each
failures get
] with-scope ;

1
basis/vocabs/errors/summary.txt Normal file
View File

@ -0,0 +1 @@
Loading vocabularies and batching errors

1
basis/vocabs/files/authors.txt Normal file
View File

@ -0,0 +1 @@
Slava Pestov

11
basis/vocabs/files/files-docs.factor Normal file
View File

@ -0,0 +1,11 @@
USING: help.markup help.syntax strings ;
IN: vocabs.files
HELP: vocab-files
{ $values { "vocab" "a vocabulary specifier" } { "seq" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of files comprising this vocabulary, or " { $link f } " if the vocabulary does not have a directory on disk." } ;
HELP: vocab-tests
{ $values { "vocab" "a vocabulary specifier" } { "tests" "a sequence of pathname strings" } }
{ $description "Outputs a sequence of pathnames where the unit tests for " { $snippet "vocab" } " are located." } ;

9
basis/vocabs/files/files-tests.factor Normal file
View File

@ -0,0 +1,9 @@
IN: vocabs.files.tests
USING: tools.test vocabs.files vocabs arrays grouping ;
[ t ] [
"kernel" vocab-files
"kernel" vocab vocab-files
"kernel" <vocab-link> vocab-files
3array all-equal?
] unit-test

34
basis/vocabs/files/files.factor Normal file
View File

@ -0,0 +1,34 @@
! Copyright (C) 2009 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: io.directories io.files io.pathnames kernel make
sequences vocabs.loader ;
IN: vocabs.files
<PRIVATE
: vocab-tests-file ( vocab -- path )
dup "-tests.factor" vocab-dir+ vocab-append-path dup
[ dup exists? [ drop f ] unless ] [ drop f ] if ;
: vocab-tests-dir ( vocab -- paths )
dup vocab-dir "tests" append-path vocab-append-path dup [
dup exists? [
dup directory-files [ ".factor" tail? ] filter
[ append-path ] with map
] [ drop f ] if
] [ drop f ] if ;
PRIVATE>
: vocab-tests ( vocab -- tests )
[
[ vocab-tests-file [ , ] when* ]
[ vocab-tests-dir [ % ] when* ] bi
] { } make ;
: vocab-files ( vocab -- seq )
[
[ vocab-source-path [ , ] when* ]
[ vocab-docs-path [ , ] when* ]
[ vocab-tests % ] tri
] { } make ;

1
basis/vocabs/files/summary.txt Normal file
View File

@ -0,0 +1 @@
Getting a list of files in a vocabulary

33
basis/vocabs/hierarchy/hierarchy-docs.factor Normal file
View File

@ -0,0 +1,33 @@
USING: help.markup help.syntax strings vocabs.loader ;
IN: vocabs.hierarchy
ARTICLE: "vocabs.hierarchy" "Vocabulary hierarchy tools"
"These tools operate on all vocabularies found in the current set of " { $link vocab-roots } ", loaded or not."
$nl
"Loading vocabulary hierarchies:"
{ $subsection load }
{ $subsection load-all }
"Getting all vocabularies on disk:"
{ $subsection all-vocabs }
{ $subsection all-vocabs-seq }
"Getting " { $link "vocabs.metadata" } " for all vocabularies on disk:"
{ $subsection all-tags }
{ $subsection all-authors } ;
ABOUT: "vocabs.hierarchy"
HELP: all-vocabs
{ $values { "assoc" "an association list mapping vocabulary roots to sequences of vocabulary specifiers" } }
{ $description "Outputs an association list of all vocabularies which have been loaded or are available for loading." } ;
HELP: load
{ $values { "prefix" string } }
{ $description "Load all vocabularies that match the provided prefix." }
{ $notes "This word differs from " { $link require } " in that it loads all subvocabularies, not just the given one." } ;
HELP: load-all
{ $description "Load all vocabularies in the source tree." } ;
HELP: all-vocabs-under
{ $values { "prefix" string } { "vocabs" "a sequence of vocabularies" } }
{ $description "Return a sequence of vocab or vocab-links for each vocab matching the provided prefix. Unlike " { $link all-child-vocabs } " this word will return both loaded and unloaded vocabularies." } ;

Some files were not shown because too many files have changed in this diff Show More